1-- C34014C.ADA 2 3-- Grant of Unlimited Rights 4-- 5-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, 6-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained 7-- unlimited rights in the software and documentation contained herein. 8-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making 9-- this public release, the Government intends to confer upon all 10-- recipients unlimited rights equal to those held by the Government. 11-- These rights include rights to use, duplicate, release or disclose the 12-- released technical data and computer software in whole or in part, in 13-- any manner and for any purpose whatsoever, and to have or permit others 14-- to do so. 15-- 16-- DISCLAIMER 17-- 18-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR 19-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED 20-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE 21-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE 22-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A 23-- PARTICULAR PURPOSE OF SAID MATERIAL. 24--* 25-- OBJECTIVE: 26-- CHECK THAT A DERIVED SUBPROGRAM IS VISIBLE AND FURTHER DERIVABLE 27-- UNDER APPROPRIATE CIRCUMSTANCES. 28 29-- CHECK WHEN THE DERIVED SUBPROGRAM IS IMPLICITLY DECLARED IN THE 30-- VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC SUBPROGRAM IS LATER 31-- DECLARED EXPLICITLY IN THE PRIVATE PART. 32 33-- HISTORY: 34-- JRK 09/11/87 CREATED ORIGINAL TEST. 35-- GJD 11/15/95 REMOVED ADA 83 INCOMPATIBILITIES. 36-- PWN 10/24/96 RESTORED CHECK WITH NEW ADA 95 RESULTS EXPECTED. 37-- PWB.CTA 02/20/97 Made failure messages unique. 38 39WITH REPORT; USE REPORT; 40 41PROCEDURE C34014C IS 42 43 PACKAGE P IS 44 TYPE T IS RANGE -100 .. 100; 45 FUNCTION F RETURN T; 46 END P; 47 USE P; 48 49 PACKAGE BODY P IS 50 FUNCTION F RETURN T IS 51 BEGIN 52 RETURN T (IDENT_INT (1)); 53 END F; 54 END P; 55 56BEGIN 57 TEST ("C34014C", "CHECK THAT A DERIVED SUBPROGRAM IS VISIBLE " & 58 "AND FURTHER DERIVABLE UNDER APPROPRIATE " & 59 "CIRCUMSTANCES. CHECK WHEN THE DERIVED " & 60 "SUBPROGRAM IS IMPLICITLY DECLARED IN THE " & 61 "VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC " & 62 "SUBPROGRAM IS LATER DECLARED EXPLICITLY IN " & 63 "THE PRIVATE PART"); 64 65 ----------------------------------------------------------------- 66 67 COMMENT ("NEW SUBPROGRAM DECLARED BY SUBPROGRAM DECLARATION"); 68 69 DECLARE 70 71 PACKAGE Q IS 72 TYPE QT IS NEW T; 73 X : QT := F; 74 PRIVATE 75 FUNCTION F RETURN QT; 76 TYPE QR IS 77 RECORD 78 C : QT := F; 79 END RECORD; 80 TYPE QS IS NEW QT; 81 END Q; 82 USE Q; 83 84 PACKAGE BODY Q IS 85 FUNCTION F RETURN QT IS 86 BEGIN 87 RETURN QT (IDENT_INT (2)); 88 END F; 89 90 PACKAGE R IS 91 Y : QR; 92 Z : QS := F; 93 END R; 94 USE R; 95 BEGIN 96 IF X /= 1 THEN 97 FAILED ("OLD SUBPROGRAM NOT VISIBLE - SUBPROG " & 98 "DECL - 1"); 99 END IF; 100 101 IF Y.C /= 2 THEN 102 FAILED ("NEW SUBPROGRAM NOT VISIBLE - SUBPROG " & 103 "DECL"); 104 END IF; 105 106 IF Z /= 2 THEN 107 FAILED ("OLD SUBPROGRAM NOT DERIVED - SUBPROG " & 108 "DECL - 1"); 109 END IF; 110 END Q; 111 112 PACKAGE R IS 113 Y : QT := F; 114 TYPE RT IS NEW QT; 115 Z : RT := F; 116 END R; 117 USE R; 118 119 BEGIN 120 IF Y /= 1 THEN 121 FAILED ("OLD SUBPROGRAM NOT VISIBLE - SUBPROG DECL - 2"); 122 END IF; 123 124 IF Z /= 1 THEN 125 FAILED ("OLD SUBPROGRAM NOT DERIVED - SUBPROG DECL - 2"); 126 END IF; 127 END; 128 129 ----------------------------------------------------------------- 130 131 COMMENT ("NEW SUBPROGRAM DECLARED BY RENAMING"); 132 133 DECLARE 134 135 PACKAGE Q IS 136 TYPE QT IS NEW T; 137 X : QT := F; 138 PRIVATE 139 FUNCTION G RETURN QT; 140 FUNCTION F RETURN QT RENAMES G; 141 TYPE QR IS 142 RECORD 143 C : QT := F; 144 END RECORD; 145 TYPE QS IS NEW QT; 146 END Q; 147 USE Q; 148 149 PACKAGE BODY Q IS 150 FUNCTION G RETURN QT IS 151 BEGIN 152 RETURN QT (IDENT_INT (2)); 153 END G; 154 155 PACKAGE R IS 156 Y : QR; 157 Z : QS := F; 158 END R; 159 USE R; 160 BEGIN 161 IF X /= 1 THEN 162 FAILED ("OLD SUBPROGRAM NOT VISIBLE - RENAMING - " & 163 "1"); 164 END IF; 165 166 IF Y.C /= 2 THEN 167 FAILED ("NEW SUBPROGRAM NOT VISIBLE - RENAMING"); 168 END IF; 169 170 IF Z /= 2 THEN 171 FAILED ("OLD SUBPROGRAM NOT DERIVED - RENAMING - " & 172 "1"); 173 END IF; 174 END Q; 175 176 PACKAGE R IS 177 Y : QT := F; 178 TYPE RT IS NEW QT; 179 Z : RT := F; 180 END R; 181 USE R; 182 183 BEGIN 184 IF Y /= 1 THEN 185 FAILED ("OLD SUBPROGRAM NOT VISIBLE - RENAMING - 2"); 186 END IF; 187 188 IF Z /= 1 THEN 189 FAILED ("OLD SUBPROGRAM NOT DERIVED - RENAMING - 2"); 190 END IF; 191 END; 192 193 ----------------------------------------------------------------- 194 195 COMMENT ("NEW SUBPROGRAM DECLARED BY GENERIC INSTANTIATION"); 196 197 DECLARE 198 199 GENERIC 200 TYPE T IS RANGE <>; 201 FUNCTION G RETURN T; 202 203 FUNCTION G RETURN T IS 204 BEGIN 205 RETURN T (IDENT_INT (2)); 206 END G; 207 208 PACKAGE Q IS 209 TYPE QT IS NEW T; 210 X : QT := F; 211 PRIVATE 212 FUNCTION F IS NEW G (QT); 213 W : QT := F; 214 TYPE QS IS NEW QT; 215 Z : QS := F; 216 END Q; 217 USE Q; 218 219 PACKAGE BODY Q IS 220 BEGIN 221 IF X /= 1 THEN 222 FAILED ("OLD SUBPROGRAM NOT VISIBLE - " & 223 "INSTANTIATION - 1"); 224 END IF; 225 226 IF W /= 2 THEN 227 FAILED ("NEW SUBPROGRAM NOT VISIBLE - " & 228 "INSTANTIATION"); 229 END IF; 230 231 IF Z /= 2 THEN 232 FAILED ("OLD SUBPROGRAM NOT DERIVED - " & 233 "INSTANTIATION - 1"); 234 END IF; 235 END Q; 236 237 PACKAGE R IS 238 Y : QT := F; 239 TYPE RT IS NEW QT; 240 Z : RT := F; 241 END R; 242 USE R; 243 244 BEGIN 245 IF Y /= 1 THEN 246 FAILED ("OLD SUBPROGRAM NOT VISIBLE - INSTANTIATION - " & 247 "2"); 248 END IF; 249 250 IF Z /= 1 THEN 251 FAILED ("OLD SUBPROGRAM NOT DERIVED - INSTANTIATION - " & 252 "2"); 253 END IF; 254 END; 255 256 ----------------------------------------------------------------- 257 258 RESULT; 259END C34014C; 260