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