1-- C85005D.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 VARIABLE CREATED BY A GENERIC 'IN OUT' FORMAL 27-- PARAMETER CAN BE RENAMED AND HAS THE CORRECT VALUE, AND 28-- THAT THE NEW NAME CAN BE USED IN AN ASSIGNMENT STATEMENT AND 29-- PASSED ON AS AN ACTUAL SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' 30-- PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' PARAMETER, 31-- AND THAT WHEN THE VALUE OF THE RENAMED VARIABLE IS CHANGED, 32-- THE NEW VALUE IS REFLECTED BY THE VALUE OF THE NEW NAME. 33 34-- HISTORY: 35-- JET 03/15/88 CREATED ORIGINAL TEST. 36 37WITH REPORT; USE REPORT; 38PROCEDURE C85005D IS 39 40 TYPE ARRAY1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER; 41 TYPE RECORD1 (D : INTEGER) IS 42 RECORD 43 FIELD1 : INTEGER := 1; 44 END RECORD; 45 TYPE POINTER1 IS ACCESS INTEGER; 46 47 PACKAGE PACK1 IS 48 TYPE PRIVY IS PRIVATE; 49 ZERO : CONSTANT PRIVY; 50 ONE : CONSTANT PRIVY; 51 TWO : CONSTANT PRIVY; 52 THREE : CONSTANT PRIVY; 53 FOUR : CONSTANT PRIVY; 54 FIVE : CONSTANT PRIVY; 55 FUNCTION IDENT (I : PRIVY) RETURN PRIVY; 56 FUNCTION NEXT (I : PRIVY) RETURN PRIVY; 57 PRIVATE 58 TYPE PRIVY IS RANGE 0..127; 59 ZERO : CONSTANT PRIVY := 0; 60 ONE : CONSTANT PRIVY := 1; 61 TWO : CONSTANT PRIVY := 2; 62 THREE : CONSTANT PRIVY := 3; 63 FOUR : CONSTANT PRIVY := 4; 64 FIVE : CONSTANT PRIVY := 5; 65 END PACK1; 66 67 TASK TYPE TASK1 IS 68 ENTRY ASSIGN (J : IN INTEGER); 69 ENTRY VALU (J : OUT INTEGER); 70 ENTRY NEXT; 71 ENTRY STOP; 72 END TASK1; 73 74 DI1 : INTEGER := 0; 75 DA1 : ARRAY1(1..3) := (OTHERS => 0); 76 DR1 : RECORD1(1) := (D => 1, FIELD1 => 0); 77 DP1 : POINTER1 := NEW INTEGER'(0); 78 DV1 : PACK1.PRIVY := PACK1.ZERO; 79 DT1 : TASK1; 80 81 I : INTEGER; 82 83 GENERIC 84 GI1 : IN OUT INTEGER; 85 GA1 : IN OUT ARRAY1; 86 GR1 : IN OUT RECORD1; 87 GP1 : IN OUT POINTER1; 88 GV1 : IN OUT PACK1.PRIVY; 89 GT1 : IN OUT TASK1; 90 PACKAGE GENERIC1 IS 91 END GENERIC1; 92 93 FUNCTION IDENT (P : POINTER1) RETURN POINTER1 IS 94 BEGIN 95 IF EQUAL (3,3) THEN 96 RETURN P; 97 ELSE 98 RETURN NULL; 99 END IF; 100 END IDENT; 101 102 PACKAGE BODY PACK1 IS 103 FUNCTION IDENT (I : PRIVY) RETURN PRIVY IS 104 BEGIN 105 IF EQUAL(3,3) THEN 106 RETURN I; 107 ELSE 108 RETURN PRIVY'(0); 109 END IF; 110 END IDENT; 111 112 FUNCTION NEXT (I : PRIVY) RETURN PRIVY IS 113 BEGIN 114 RETURN I+1; 115 END NEXT; 116 END PACK1; 117 118 PACKAGE BODY GENERIC1 IS 119 XGI1 : INTEGER RENAMES GI1; 120 XGA1 : ARRAY1 RENAMES GA1; 121 XGR1 : RECORD1 RENAMES GR1; 122 XGP1 : POINTER1 RENAMES GP1; 123 XGV1 : PACK1.PRIVY RENAMES GV1; 124 XGT1 : TASK1 RENAMES GT1; 125 126 TASK TYPE TASK2 IS 127 ENTRY ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1; 128 TR1 : OUT RECORD1; TP1 : IN OUT POINTER1; 129 TV1 : IN OUT PACK1.PRIVY; 130 TT1 : IN OUT TASK1); 131 END TASK2; 132 133 G_CHK_TASK : TASK2; 134 135 GENERIC 136 GGI1 : IN OUT INTEGER; 137 GGA1 : IN OUT ARRAY1; 138 GGR1 : IN OUT RECORD1; 139 GGP1 : IN OUT POINTER1; 140 GGV1 : IN OUT PACK1.PRIVY; 141 GGT1 : IN OUT TASK1; 142 PACKAGE GENERIC2 IS 143 END GENERIC2; 144 145 PACKAGE BODY GENERIC2 IS 146 BEGIN 147 GGI1 := GGI1 + 1; 148 GGA1 := (GGA1(1)+1, GGA1(2)+1, GGA1(3)+1); 149 GGR1 := (D => 1, FIELD1 => GGR1.FIELD1 + 1); 150 GGP1 := NEW INTEGER'(GGP1.ALL + 1); 151 GGV1 := PACK1.NEXT(GGV1); 152 GGT1.NEXT; 153 END GENERIC2; 154 155 TASK BODY TASK2 IS 156 BEGIN 157 ACCEPT ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1; 158 TR1 : OUT RECORD1; TP1 : IN OUT POINTER1; 159 TV1 : IN OUT PACK1.PRIVY; 160 TT1 : IN OUT TASK1) 161 DO 162 TI1 := GI1 + 1; 163 TA1 := (GA1(1)+1, GA1(2)+1, GA1(3)+1); 164 TR1 := (D => 1, FIELD1 => GR1.FIELD1 + 1); 165 TP1 := NEW INTEGER'(TP1.ALL + 1); 166 TV1 := PACK1.NEXT(TV1); 167 TT1.NEXT; 168 END ENTRY1; 169 END TASK2; 170 171 PROCEDURE PROC1 (PI1 : IN OUT INTEGER; PA1 : IN OUT ARRAY1; 172 PR1 : IN OUT RECORD1; PP1 : OUT POINTER1; 173 PV1 : OUT PACK1.PRIVY; PT1 : IN OUT TASK1) IS 174 BEGIN 175 PI1 := PI1 + 1; 176 PA1 := (PA1(1)+1, PA1(2)+1, PA1(3)+1); 177 PR1 := (D => 1, FIELD1 => PR1.FIELD1 + 1); 178 PP1 := NEW INTEGER'(GP1.ALL + 1); 179 PV1 := PACK1.NEXT(GV1); 180 PT1.NEXT; 181 END PROC1; 182 183 PACKAGE GENPACK2 IS NEW GENERIC2 184 (XGI1, XGA1, XGR1, XGP1, XGV1, XGT1); 185 186 BEGIN 187 IF XGI1 /= IDENT_INT(1) THEN 188 FAILED ("INCORRECT VALUE OF XGI1 (1)"); 189 END IF; 190 191 IF XGA1 /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) THEN 192 FAILED ("INCORRECT VALUE OF XGA1 (1)"); 193 END IF; 194 195 IF XGR1 /= (D => 1, FIELD1 => IDENT_INT(1)) THEN 196 FAILED ("INCORRECT VALUE OF XGR1 (1)"); 197 END IF; 198 199 IF XGP1 /= IDENT(GP1) OR XGP1.ALL /= IDENT_INT(1) THEN 200 FAILED ("INCORRECT VALUE OF XGP1 (1)"); 201 END IF; 202 203 IF PACK1."/=" (XGV1, PACK1.IDENT(PACK1.ONE)) THEN 204 FAILED ("INCORRECT VALUE OF XGV1 (1)"); 205 END IF; 206 207 XGT1.VALU(I); 208 IF I /= IDENT_INT(1) THEN 209 FAILED ("INCORRECT RETURN VALUE OF XGT1.VALU (1)"); 210 END IF; 211 212 PROC1(XGI1, XGA1, XGR1, XGP1, XGV1, XGT1); 213 214 IF XGI1 /= IDENT_INT(2) THEN 215 FAILED ("INCORRECT VALUE OF XGI1 (2)"); 216 END IF; 217 218 IF XGA1 /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) THEN 219 FAILED ("INCORRECT VALUE OF XGA1 (2)"); 220 END IF; 221 222 IF XGR1 /= (D => 1, FIELD1 => IDENT_INT(2)) THEN 223 FAILED ("INCORRECT VALUE OF XGR1 (2)"); 224 END IF; 225 226 IF XGP1 /= IDENT(GP1) OR XGP1.ALL /= IDENT_INT(2) THEN 227 FAILED ("INCORRECT VALUE OF XGP1 (2)"); 228 END IF; 229 230 IF PACK1."/=" (XGV1, PACK1.IDENT(PACK1.TWO)) THEN 231 FAILED ("INCORRECT VALUE OF XGV1 (2)"); 232 END IF; 233 234 XGT1.VALU(I); 235 IF I /= IDENT_INT(2) THEN 236 FAILED ("INCORRECT RETURN VALUE OF XGT1.VALU (2)"); 237 END IF; 238 239 G_CHK_TASK.ENTRY1(XGI1, XGA1, XGR1, XGP1, XGV1, XGT1); 240 241 IF XGI1 /= IDENT_INT(3) THEN 242 FAILED ("INCORRECT VALUE OF XGI1 (3)"); 243 END IF; 244 245 IF XGA1 /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) THEN 246 FAILED ("INCORRECT VALUE OF XGA1 (3)"); 247 END IF; 248 249 IF XGR1 /= (D => 1, FIELD1 => IDENT_INT(3)) THEN 250 FAILED ("INCORRECT VALUE OF XGR1 (3)"); 251 END IF; 252 253 IF XGP1 /= IDENT(GP1) OR XGP1.ALL /= IDENT_INT(3) THEN 254 FAILED ("INCORRECT VALUE OF XGP1 (3)"); 255 END IF; 256 257 IF PACK1."/=" (XGV1, PACK1.IDENT(PACK1.THREE)) THEN 258 FAILED ("INCORRECT VALUE OF XGV1 (3)"); 259 END IF; 260 261 XGT1.VALU(I); 262 IF I /= IDENT_INT(3) THEN 263 FAILED ("INCORRECT RETURN VALUE OF XGT1.VALU (3)"); 264 END IF; 265 266 XGI1 := XGI1 + 1; 267 XGA1 := (XGA1(1)+1, XGA1(2)+1, XGA1(3)+1); 268 XGR1 := (D => 1, FIELD1 => XGR1.FIELD1 + 1); 269 XGP1 := NEW INTEGER'(XGP1.ALL + 1); 270 XGV1 := PACK1.NEXT(XGV1); 271 XGT1.NEXT; 272 273 IF XGI1 /= IDENT_INT(4) THEN 274 FAILED ("INCORRECT VALUE OF XGI1 (4)"); 275 END IF; 276 277 IF XGA1 /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) THEN 278 FAILED ("INCORRECT VALUE OF XGA1 (4)"); 279 END IF; 280 281 IF XGR1 /= (D => 1, FIELD1 => IDENT_INT(4)) THEN 282 FAILED ("INCORRECT VALUE OF XGR1 (4)"); 283 END IF; 284 285 IF XGP1 /= IDENT(GP1) OR XGP1.ALL /= IDENT_INT(4) THEN 286 FAILED ("INCORRECT VALUE OF XGP1 (4)"); 287 END IF; 288 289 IF PACK1."/=" (XGV1, PACK1.IDENT(PACK1.FOUR)) THEN 290 FAILED ("INCORRECT VALUE OF XGV1 (4)"); 291 END IF; 292 293 XGT1.VALU(I); 294 IF I /= IDENT_INT(4) THEN 295 FAILED ("INCORRECT RETURN VALUE OF XGT1.VALU (4)"); 296 END IF; 297 298 GI1 := GI1 + 1; 299 GA1 := (GA1(1)+1, GA1(2)+1, GA1(3)+1); 300 GR1 := (D => 1, FIELD1 => GR1.FIELD1 + 1); 301 GP1 := NEW INTEGER'(GP1.ALL + 1); 302 GV1 := PACK1.NEXT(GV1); 303 GT1.NEXT; 304 305 IF XGI1 /= IDENT_INT(5) THEN 306 FAILED ("INCORRECT VALUE OF XGI1 (5)"); 307 END IF; 308 309 IF XGA1 /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) THEN 310 FAILED ("INCORRECT VALUE OF XGA1 (5)"); 311 END IF; 312 313 IF XGR1 /= (D => 1, FIELD1 => IDENT_INT(5)) THEN 314 FAILED ("INCORRECT VALUE OF XGR1 (5)"); 315 END IF; 316 317 IF XGP1 /= IDENT(GP1) OR XGP1.ALL /= IDENT_INT(5) THEN 318 FAILED ("INCORRECT VALUE OF XGP1 (5)"); 319 END IF; 320 321 IF PACK1."/=" (XGV1, PACK1.IDENT(PACK1.FIVE)) THEN 322 FAILED ("INCORRECT VALUE OF XGV1 (5)"); 323 END IF; 324 325 XGT1.VALU(I); 326 IF I /= IDENT_INT(5) THEN 327 FAILED ("INCORRECT RETURN VALUE OF XGT1.VALU (5)"); 328 END IF; 329 END GENERIC1; 330 331 TASK BODY TASK1 IS 332 TASK_VALUE : INTEGER := 0; 333 ACCEPTING_ENTRIES : BOOLEAN := TRUE; 334 BEGIN 335 WHILE ACCEPTING_ENTRIES LOOP 336 SELECT 337 ACCEPT ASSIGN (J : IN INTEGER) DO 338 TASK_VALUE := J; 339 END ASSIGN; 340 OR 341 ACCEPT VALU (J : OUT INTEGER) DO 342 J := TASK_VALUE; 343 END VALU; 344 OR 345 ACCEPT NEXT DO 346 TASK_VALUE := TASK_VALUE + 1; 347 END NEXT; 348 OR 349 ACCEPT STOP DO 350 ACCEPTING_ENTRIES := FALSE; 351 END STOP; 352 END SELECT; 353 END LOOP; 354 END TASK1; 355 356BEGIN 357 TEST ("C85005D", "CHECK THAT A VARIABLE CREATED BY A GENERIC " & 358 "'IN OUT' FORMAL PARAMETER CAN BE RENAMED " & 359 "AND HAS THE CORRECT VALUE, AND THAT THE NEW " & 360 "NAME CAN BE USED IN AN ASSIGNMENT STATEMENT " & 361 "AND PASSED ON AS AN ACTUAL SUBPROGRAM OR " & 362 "ENTRY 'IN OUT' OR 'OUT' PARAMETER, AND AS AN " & 363 "ACTUAL GENERIC 'IN OUT' PARAMETER, AND THAT " & 364 "WHEN THE VALUE OF THE RENAMED VARIABLE IS " & 365 "CHANGED, THE NEW VALUE IS REFLECTED BY THE " & 366 "VALUE OF THE NEW NAME"); 367 368 DECLARE 369 PACKAGE GENPACK1 IS NEW 370 GENERIC1 (DI1, DA1, DR1, DP1, DV1, DT1); 371 BEGIN 372 NULL; 373 END; 374 375 DT1.STOP; 376 377 RESULT; 378END C85005D; 379