1-- C85005B.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 SUBPROGRAM 'IN OUT' FORMAL 27-- PARAMETER CAN BE RENAMED AND HAS THE CORRECT VALUE, AND THAT 28-- THE NEW NAME CAN BE USED IN AN ASSIGNMENT STATEMENT AND PASSED 29-- ON AS AN ACTUAL SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' PARAMETER, 30-- AND AS AN ACTUAL GENERIC 'IN OUT' PARAMETER, AND THAT WHEN THE 31-- VALUE OF THE RENAMED VARIABLE IS CHANGED, THE NEW VALUE IS 32-- 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 C85005B 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 BEGIN 120 GI1 := GI1 + 1; 121 GA1 := (GA1(1)+1, GA1(2)+1, GA1(3)+1); 122 GR1 := (D => 1, FIELD1 => GR1.FIELD1 + 1); 123 GP1 := NEW INTEGER'(GP1.ALL + 1); 124 GV1 := PACK1.NEXT(GV1); 125 GT1.NEXT; 126 END GENERIC1; 127 128 TASK BODY TASK1 IS 129 TASK_VALUE : INTEGER := 0; 130 ACCEPTING_ENTRIES : BOOLEAN := TRUE; 131 BEGIN 132 WHILE ACCEPTING_ENTRIES LOOP 133 SELECT 134 ACCEPT ASSIGN (J : IN INTEGER) DO 135 TASK_VALUE := J; 136 END ASSIGN; 137 OR 138 ACCEPT VALU (J : OUT INTEGER) DO 139 J := TASK_VALUE; 140 END VALU; 141 OR 142 ACCEPT NEXT DO 143 TASK_VALUE := TASK_VALUE + 1; 144 END NEXT; 145 OR 146 ACCEPT STOP DO 147 ACCEPTING_ENTRIES := FALSE; 148 END STOP; 149 END SELECT; 150 END LOOP; 151 END TASK1; 152 153 PROCEDURE PROC (PI1 : IN OUT INTEGER; PA1 : IN OUT ARRAY1; 154 PR1 : IN OUT RECORD1; PP1 : IN OUT POINTER1; 155 PV1 : IN OUT PACK1.PRIVY; PT1 : IN OUT TASK1) IS 156 XPI1 : INTEGER RENAMES PI1; 157 XPA1 : ARRAY1 RENAMES PA1; 158 XPR1 : RECORD1 RENAMES PR1; 159 XPP1 : POINTER1 RENAMES PP1; 160 XPV1 : PACK1.PRIVY RENAMES PV1; 161 XPT1 : TASK1 RENAMES PT1; 162 163 TASK TYPE TASK2 IS 164 ENTRY ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1; 165 TR1 : OUT RECORD1; TP1 : IN OUT POINTER1; 166 TV1 : IN OUT PACK1.PRIVY; 167 TT1 : IN OUT TASK1); 168 END TASK2; 169 170 CHK_TASK : TASK2; 171 172 PROCEDURE PROC1 (PPI1 : IN OUT INTEGER; PPA1 : IN OUT ARRAY1; 173 PPR1 : IN OUT RECORD1; PPP1 : OUT POINTER1; 174 PPV1 : OUT PACK1.PRIVY; 175 PPT1 : IN OUT TASK1) IS 176 BEGIN 177 PPI1 := PPI1 + 1; 178 PPA1 := (PPA1(1)+1, PPA1(2)+1, PPA1(3)+1); 179 PPR1 := (D => 1, FIELD1 => PPR1.FIELD1 + 1); 180 PPP1 := NEW INTEGER'(PP1.ALL + 1); 181 PPV1 := PACK1.NEXT(PV1); 182 PPT1.NEXT; 183 END PROC1; 184 185 TASK BODY TASK2 IS 186 BEGIN 187 ACCEPT ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1; 188 TR1 : OUT RECORD1; TP1 : IN OUT POINTER1; 189 TV1 : IN OUT PACK1.PRIVY; 190 TT1 : IN OUT TASK1) 191 DO 192 TI1 := PI1 + 1; 193 TA1 := (PA1(1)+1, PA1(2)+1, PA1(3)+1); 194 TR1 := (D => 1, FIELD1 => PR1.FIELD1 + 1); 195 TP1 := NEW INTEGER'(TP1.ALL + 1); 196 TV1 := PACK1.NEXT(TV1); 197 TT1.NEXT; 198 END ENTRY1; 199 END TASK2; 200 201 PACKAGE GENPACK1 IS NEW GENERIC1 202 (XPI1, XPA1, XPR1, XPP1, XPV1, XPT1); 203 204 BEGIN 205 IF XPI1 /= IDENT_INT(1) THEN 206 FAILED ("INCORRECT VALUE OF XPI1 (1)"); 207 END IF; 208 209 IF XPA1 /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) THEN 210 FAILED ("INCORRECT VALUE OF XPA1 (1)"); 211 END IF; 212 213 IF XPR1 /= (D => 1, FIELD1 => IDENT_INT(1)) THEN 214 FAILED ("INCORRECT VALUE OF XPR1 (1)"); 215 END IF; 216 217 IF XPP1 /= IDENT(PP1) OR XPP1.ALL /= IDENT_INT(1) THEN 218 FAILED ("INCORRECT VALUE OF XPP1 (1)"); 219 END IF; 220 221 IF PACK1."/=" (XPV1, PACK1.IDENT(PACK1.ONE)) THEN 222 FAILED ("INCORRECT VALUE OF XPV1 (1)"); 223 END IF; 224 225 XPT1.VALU(I); 226 IF I /= IDENT_INT(1) THEN 227 FAILED ("INCORRECT RETURN VALUE OF XPT1.VALU (1)"); 228 END IF; 229 230 PROC1(XPI1, XPA1, XPR1, XPP1, XPV1, XPT1); 231 232 IF XPI1 /= IDENT_INT(2) THEN 233 FAILED ("INCORRECT VALUE OF XPI1 (2)"); 234 END IF; 235 236 IF XPA1 /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) THEN 237 FAILED ("INCORRECT VALUE OF XPA1 (2)"); 238 END IF; 239 240 IF XPR1 /= (D => 1, FIELD1 => IDENT_INT(2)) THEN 241 FAILED ("INCORRECT VALUE OF XPR1 (2)"); 242 END IF; 243 244 IF XPP1 /= IDENT(PP1) OR XPP1.ALL /= IDENT_INT(2) THEN 245 FAILED ("INCORRECT VALUE OF XPP1 (2)"); 246 END IF; 247 248 IF PACK1."/=" (XPV1, PACK1.IDENT(PACK1.TWO)) THEN 249 FAILED ("INCORRECT VALUE OF XPV1 (2)"); 250 END IF; 251 252 XPT1.VALU(I); 253 IF I /= IDENT_INT(2) THEN 254 FAILED ("INCORRECT RETURN VALUE FROM XPT1.VALU (2)"); 255 END IF; 256 257 CHK_TASK.ENTRY1 (XPI1, XPA1, XPR1, XPP1, XPV1, XPT1); 258 259 IF XPI1 /= IDENT_INT(3) THEN 260 FAILED ("INCORRECT VALUE OF XPI1 (3)"); 261 END IF; 262 263 IF XPA1 /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) THEN 264 FAILED ("INCORRECT VALUE OF XPA1 (3)"); 265 END IF; 266 267 IF XPR1 /= (D => 1, FIELD1 => IDENT_INT(3)) THEN 268 FAILED ("INCORRECT VALUE OF XPR1 (3)"); 269 END IF; 270 271 IF XPP1 /= IDENT(PP1) OR XPP1.ALL /= IDENT_INT(3) THEN 272 FAILED ("INCORRECT VALUE OF XPP1 (3)"); 273 END IF; 274 275 IF PACK1."/=" (XPV1, PACK1.IDENT(PACK1.THREE)) THEN 276 FAILED ("INCORRECT VALUE OF XPV1 (3)"); 277 END IF; 278 279 XPT1.VALU(I); 280 IF I /= IDENT_INT(3) THEN 281 FAILED ("INCORRECT RETURN VALUE OF XPT1.VALU (3)"); 282 END IF; 283 284 XPI1 := XPI1 + 1; 285 XPA1 := (XPA1(1)+1, XPA1(2)+1, XPA1(3)+1); 286 XPR1 := (D => 1, FIELD1 => XPR1.FIELD1 + 1); 287 XPP1 := NEW INTEGER'(XPP1.ALL + 1); 288 XPV1 := PACK1.NEXT(XPV1); 289 XPT1.NEXT; 290 291 IF XPI1 /= IDENT_INT(4) THEN 292 FAILED ("INCORRECT VALUE OF XPI1 (4)"); 293 END IF; 294 295 IF XPA1 /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) THEN 296 FAILED ("INCORRECT VALUE OF XPA1 (4)"); 297 END IF; 298 299 IF XPR1 /= (D => 1, FIELD1 => IDENT_INT(4)) THEN 300 FAILED ("INCORRECT VALUE OF XPR1 (4)"); 301 END IF; 302 303 IF XPP1 /= IDENT(PP1) OR XPP1.ALL /= IDENT_INT(4) THEN 304 FAILED ("INCORRECT VALUE OF XPP1 (4)"); 305 END IF; 306 307 IF PACK1."/=" (XPV1, PACK1.IDENT(PACK1.FOUR)) THEN 308 FAILED ("INCORRECT VALUE OF XPV1 (4)"); 309 END IF; 310 311 XPT1.VALU(I); 312 IF I /= IDENT_INT(4) THEN 313 FAILED ("INCORRECT RETURN VALUE OF XPT1.VALU (4)"); 314 END IF; 315 316 PI1 := PI1 + 1; 317 PA1 := (PA1(1)+1, PA1(2)+1, PA1(3)+1); 318 PR1 := (D => 1, FIELD1 => PR1.FIELD1 + 1); 319 PP1 := NEW INTEGER'(PP1.ALL + 1); 320 PV1 := PACK1.NEXT(PV1); 321 PT1.NEXT; 322 323 IF XPI1 /= IDENT_INT(5) THEN 324 FAILED ("INCORRECT VALUE OF XPI1 (5)"); 325 END IF; 326 327 IF XPA1 /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) THEN 328 FAILED ("INCORRECT VALUE OF XPA1 (5)"); 329 END IF; 330 331 IF XPR1 /= (D => 1, FIELD1 => IDENT_INT(5)) THEN 332 FAILED ("INCORRECT VALUE OF XPR1 (5)"); 333 END IF; 334 335 IF XPP1 /= IDENT(PP1) OR XPP1.ALL /= IDENT_INT(5) THEN 336 FAILED ("INCORRECT VALUE OF XPP1 (5)"); 337 END IF; 338 339 IF PACK1."/=" (XPV1, PACK1.IDENT(PACK1.FIVE)) THEN 340 FAILED ("INCORRECT VALUE OF XPV1 (5)"); 341 END IF; 342 343 XPT1.VALU(I); 344 IF I /= IDENT_INT(5) THEN 345 FAILED ("INCORRECT RETURN VALUE OF XPT1.VALU (5)"); 346 END IF; 347 END PROC; 348 349BEGIN 350 TEST ("C85005B", "CHECK THAT A VARIABLE CREATED BY A SUBPROGRAM " & 351 "'IN OUT' FORMAL PARAMETER CAN BE RENAMED " & 352 "AND HAS THE CORRECT VALUE, AND THAT THE NEW " & 353 "NAME CAN BE USED IN AN ASSIGNMENT STATEMENT " & 354 "AND PASSED ON AS AN ACTUAL SUBPROGRAM OR " & 355 "ENTRY 'IN OUT' OR 'OUT' PARAMETER, AND AS AN " & 356 "ACTUAL GENERIC 'IN OUT' PARAMETER, AND THAT " & 357 "WHEN THE VALUE OF THE RENAMED VARIABLE IS " & 358 "CHANGED, THE NEW VALUE IS REFLECTED BY THE " & 359 "VALUE OF THE NEW NAME"); 360 361 PROC (DI1, DA1, DR1, DP1, DV1, DT1); 362 363 DT1.STOP; 364 365 RESULT; 366END C85005B; 367