1-- C34005U.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-- FOR DERIVED MULTI-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT TYPE IS 27-- A LIMITED TYPE: 28 29-- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT 30-- FOR THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION 31-- IS CONSTRAINED. 32 33-- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS 34-- ALSO IMPOSED ON THE DERIVED SUBTYPE. 35 36-- HISTORY: 37-- JRK 08/21/87 CREATED ORIGINAL TEST. 38 39WITH REPORT; USE REPORT; 40 41PROCEDURE C34005U IS 42 43 PACKAGE PKG_L IS 44 45 TYPE LP IS LIMITED PRIVATE; 46 47 FUNCTION CREATE (X : INTEGER) RETURN LP; 48 49 FUNCTION VALUE (X : LP) RETURN INTEGER; 50 51 FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN; 52 53 PROCEDURE ASSIGN (X : OUT LP; Y : LP); 54 55 C1 : CONSTANT LP; 56 C2 : CONSTANT LP; 57 C3 : CONSTANT LP; 58 C4 : CONSTANT LP; 59 C5 : CONSTANT LP; 60 C6 : CONSTANT LP; 61 C7 : CONSTANT LP; 62 C8 : CONSTANT LP; 63 64 PRIVATE 65 66 TYPE LP IS NEW INTEGER; 67 68 C1 : CONSTANT LP := 1; 69 C2 : CONSTANT LP := 2; 70 C3 : CONSTANT LP := 3; 71 C4 : CONSTANT LP := 4; 72 C5 : CONSTANT LP := 5; 73 C6 : CONSTANT LP := 6; 74 C7 : CONSTANT LP := 7; 75 C8 : CONSTANT LP := 8; 76 77 END PKG_L; 78 79 USE PKG_L; 80 81 SUBTYPE COMPONENT IS LP; 82 83 PACKAGE PKG_P IS 84 85 FIRST : CONSTANT := 0; 86 LAST : CONSTANT := 10; 87 88 SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST; 89 90 TYPE PARENT IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) OF 91 COMPONENT; 92 93 FUNCTION CREATE ( F1, L1 : INDEX; 94 F2, L2 : INDEX; 95 C : COMPONENT; 96 DUMMY : PARENT -- TO RESOLVE OVERLOADING. 97 ) RETURN PARENT; 98 99 FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN; 100 101 FUNCTION AGGR (A, B, C, D, E, F, G, H : COMPONENT) 102 RETURN PARENT; 103 104 END PKG_P; 105 106 USE PKG_P; 107 108 TYPE T IS NEW PARENT (IDENT_INT (4) .. IDENT_INT (5), 109 IDENT_INT (6) .. IDENT_INT (8)); 110 111 SUBTYPE SUBPARENT IS PARENT (4 .. 5, 6 .. 8); 112 113 TYPE S IS NEW SUBPARENT; 114 115 X : T; 116 Y : S; 117 118 PACKAGE BODY PKG_L IS 119 120 FUNCTION CREATE (X : INTEGER) RETURN LP IS 121 BEGIN 122 RETURN LP (IDENT_INT (X)); 123 END CREATE; 124 125 FUNCTION VALUE (X : LP) RETURN INTEGER IS 126 BEGIN 127 RETURN INTEGER (X); 128 END VALUE; 129 130 FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS 131 BEGIN 132 RETURN X = Y; 133 END EQUAL; 134 135 PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS 136 BEGIN 137 X := Y; 138 END ASSIGN; 139 140 END PKG_L; 141 142 PACKAGE BODY PKG_P IS 143 144 FUNCTION CREATE 145 ( F1, L1 : INDEX; 146 F2, L2 : INDEX; 147 C : COMPONENT; 148 DUMMY : PARENT 149 ) RETURN PARENT 150 IS 151 A : PARENT (F1 .. L1, F2 .. L2); 152 B : COMPONENT; 153 BEGIN 154 ASSIGN (B, C); 155 FOR I IN F1 .. L1 LOOP 156 FOR J IN F2 .. L2 LOOP 157 ASSIGN (A (I, J), B); 158 ASSIGN (B, CREATE (VALUE (B) + 1)); 159 END LOOP; 160 END LOOP; 161 RETURN A; 162 END CREATE; 163 164 FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS 165 BEGIN 166 IF X'LENGTH /= Y'LENGTH OR 167 X'LENGTH(2) /= Y'LENGTH(2) THEN 168 RETURN FALSE; 169 ELSE FOR I IN X'RANGE LOOP 170 FOR J IN X'RANGE(2) LOOP 171 IF NOT EQUAL (X (I, J), 172 Y (I - X'FIRST + Y'FIRST, 173 J - X'FIRST(2) + 174 Y'FIRST(2))) THEN 175 RETURN FALSE; 176 END IF; 177 END LOOP; 178 END LOOP; 179 END IF; 180 RETURN TRUE; 181 END EQUAL; 182 183 FUNCTION AGGR (A, B, C, D, E, F, G, H : COMPONENT) 184 RETURN PARENT IS 185 X : PARENT (INDEX'FIRST .. INDEX'FIRST + 3, 186 INDEX'FIRST .. INDEX'FIRST + 1); 187 BEGIN 188 ASSIGN (X (INDEX'FIRST , INDEX'FIRST ), A); 189 ASSIGN (X (INDEX'FIRST , INDEX'FIRST + 1), B); 190 ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST ), C); 191 ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 1), D); 192 ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST ), E); 193 ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST + 1), F); 194 ASSIGN (X (INDEX'FIRST + 3, INDEX'FIRST ), G); 195 ASSIGN (X (INDEX'FIRST + 3, INDEX'FIRST + 1), H); 196 RETURN X; 197 END AGGR; 198 199 END PKG_P; 200 201 PROCEDURE ASSIGN (X : IN OUT T; Y : T) IS 202 BEGIN 203 FOR I IN X'RANGE LOOP 204 FOR J IN X'RANGE(2) LOOP 205 ASSIGN (X (I, J), Y (I, J)); 206 END LOOP; 207 END LOOP; 208 END ASSIGN; 209 210 PROCEDURE ASSIGN (X : IN OUT S; Y : S) IS 211 BEGIN 212 FOR I IN X'RANGE LOOP 213 FOR J IN X'RANGE(2) LOOP 214 ASSIGN (X (I, J), Y (I, J)); 215 END LOOP; 216 END LOOP; 217 END ASSIGN; 218 219BEGIN 220 TEST ("C34005U", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & 221 "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & 222 "WHEN THE DERIVED TYPE DEFINITION IS " & 223 "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & 224 "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & 225 "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & 226 "MULTI-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " & 227 "TYPE IS A LIMITED TYPE"); 228 229 FOR I IN X'RANGE LOOP 230 FOR J IN X'RANGE(2) LOOP 231 ASSIGN (X (I, J), C2); 232 ASSIGN (Y (I, J), C2); 233 END LOOP; 234 END LOOP; 235 236 -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. 237 BEGIN 238 IF NOT EQUAL (CREATE (6, 9, 2, 3, C1, X), 239 AGGR (C1, C2, C3, C4, C5, C6, C7, C8)) OR 240 NOT EQUAL (CREATE (6, 9, 2, 3, C1, Y), 241 AGGR (C1, C2, C3, C4, C5, C6, C7, C8)) THEN 242 FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE " & 243 "SUBTYPE"); 244 END IF; 245 EXCEPTION 246 WHEN CONSTRAINT_ERROR => 247 FAILED ("CONSTRAINT_ERROR WHEN TRYING TO CREATE BASE " & 248 "TYPE VALUES OUTSIDE THE SUBTYPE"); 249 WHEN OTHERS => 250 FAILED ("EXCEPTION WHEN TRYING TO CREATE BASE TYPE " & 251 "VALUES OUTSIDE THE SUBTYPE"); 252 END; 253 254 IF AGGR (C1, C2, C3, C4, C5, C6, C7, C8) IN T OR 255 AGGR (C1, C2, C3, C4, C5, C6, C7, C8) IN S THEN 256 FAILED ("INCORRECT ""IN"""); 257 END IF; 258 259 -- CHECK THE DERIVED SUBTYPE CONSTRAINT. 260 261 IF T'FIRST /= 4 OR T'LAST /= 5 OR 262 S'FIRST /= 4 OR S'LAST /= 5 OR 263 T'FIRST (2) /= 6 OR T'LAST (2) /= 8 OR 264 S'FIRST (2) /= 6 OR S'LAST (2) /= 8 THEN 265 FAILED ("INCORRECT 'FIRST OR 'LAST"); 266 END IF; 267 268 BEGIN 269 ASSIGN (X, CREATE (4, 5, 6, 8, C1, X)); 270 ASSIGN (Y, CREATE (4, 5, 6, 8, C1, Y)); 271 IF NOT EQUAL (PARENT (X), PARENT (Y)) THEN -- USE X AND Y. 272 FAILED ("INCORRECT CONVERSION TO PARENT"); 273 END IF; 274 EXCEPTION 275 WHEN OTHERS => 276 FAILED ("EXCEPTION RAISED BY OK ASSIGN CALL"); 277 END; 278 279 BEGIN 280 ASSIGN (X, CREATE (4, 4, 6, 8, C1, X)); 281 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 282 "ASSIGN (X, CREATE (4, 4, 6, 8, C1, X))"); 283 IF EQUAL (X, CREATE (4, 4, 6, 8, C1, X)) THEN -- USE X. 284 COMMENT ("X ALTERED -- " & 285 "ASSIGN (X, CREATE (4, 4, 6, 8, C1, X))"); 286 END IF; 287 EXCEPTION 288 WHEN CONSTRAINT_ERROR => 289 NULL; 290 WHEN OTHERS => 291 FAILED ("WRONG EXCEPTION RAISED -- " & 292 "ASSIGN (X, CREATE (4, 4, 6, 8, C1, X))"); 293 END; 294 295 BEGIN 296 ASSIGN (X, CREATE (4, 6, 6, 8, C1, X)); 297 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 298 "ASSIGN (X, CREATE (4, 6, 6, 8, C1, X))"); 299 IF EQUAL (X, CREATE (4, 6, 6, 8, C1, X)) THEN -- USE X. 300 COMMENT ("X ALTERED -- " & 301 "ASSIGN (X, CREATE (4, 6, 6, 8, C1, X))"); 302 END IF; 303 EXCEPTION 304 WHEN CONSTRAINT_ERROR => 305 NULL; 306 WHEN OTHERS => 307 FAILED ("WRONG EXCEPTION RAISED -- " & 308 "ASSIGN (X, CREATE (4, 6, 6, 8, C1, X))"); 309 END; 310 311 BEGIN 312 ASSIGN (X, CREATE (4, 5, 6, 7, C1, X)); 313 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 314 "ASSIGN (X, CREATE (4, 5, 6, 7, C1, X))"); 315 IF EQUAL (X, CREATE (4, 5, 6, 7, C1, X)) THEN -- USE X. 316 COMMENT ("X ALTERED -- " & 317 "ASSIGN (X, CREATE (4, 5, 6, 7, C1, X))"); 318 END IF; 319 EXCEPTION 320 WHEN CONSTRAINT_ERROR => 321 NULL; 322 WHEN OTHERS => 323 FAILED ("WRONG EXCEPTION RAISED -- " & 324 "ASSIGN (X, CREATE (4, 5, 6, 7, C1, X))"); 325 END; 326 327 BEGIN 328 ASSIGN (X, CREATE (4, 5, 6, 9, C1, X)); 329 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 330 "ASSIGN (X, CREATE (4, 5, 6, 9, C1, X))"); 331 IF EQUAL (X, CREATE (4, 5, 6, 9, C1, X)) THEN -- USE X. 332 COMMENT ("X ALTERED -- " & 333 "ASSIGN (X, CREATE (4, 5, 6, 9, C1, X))"); 334 END IF; 335 EXCEPTION 336 WHEN CONSTRAINT_ERROR => 337 NULL; 338 WHEN OTHERS => 339 FAILED ("WRONG EXCEPTION RAISED -- " & 340 "ASSIGN (X, CREATE (4, 5, 6, 9, C1, X))"); 341 END; 342 343 BEGIN 344 ASSIGN (Y, CREATE (4, 4, 6, 8, C1, Y)); 345 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 346 "ASSIGN (Y, CREATE (4, 4, 6, 8, C1, Y))"); 347 IF EQUAL (Y, CREATE (4, 4, 6, 8, C1, Y)) THEN -- USE Y. 348 COMMENT ("Y ALTERED -- " & 349 "ASSIGN (Y, CREATE (4, 4, 6, 8, C1, Y))"); 350 END IF; 351 EXCEPTION 352 WHEN CONSTRAINT_ERROR => 353 NULL; 354 WHEN OTHERS => 355 FAILED ("WRONG EXCEPTION RAISED -- " & 356 "ASSIGN (Y, CREATE (4, 4, 6, 8, C1, Y))"); 357 END; 358 359 BEGIN 360 ASSIGN (Y, CREATE (4, 6, 6, 8, C1, Y)); 361 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 362 "ASSIGN (Y, CREATE (4, 6, 6, 8, C1, Y))"); 363 IF EQUAL (Y, CREATE (4, 6, 6, 8, C1, Y)) THEN -- USE Y. 364 COMMENT ("Y ALTERED -- " & 365 "ASSIGN (Y, CREATE (4, 6, 6, 8, C1, Y))"); 366 END IF; 367 EXCEPTION 368 WHEN CONSTRAINT_ERROR => 369 NULL; 370 WHEN OTHERS => 371 FAILED ("WRONG EXCEPTION RAISED -- " & 372 "ASSIGN (Y, CREATE (4, 6, 6, 8, C1, Y))"); 373 END; 374 375 BEGIN 376 ASSIGN (Y, CREATE (4, 5, 6, 7, C1, Y)); 377 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 378 "ASSIGN (Y, CREATE (4, 5, 6, 7, C1, Y))"); 379 IF EQUAL (Y, CREATE (4, 5, 6, 7, C1, Y)) THEN -- USE Y. 380 COMMENT ("Y ALTERED -- " & 381 "ASSIGN (Y, CREATE (4, 5, 6, 7, C1, Y))"); 382 END IF; 383 EXCEPTION 384 WHEN CONSTRAINT_ERROR => 385 NULL; 386 WHEN OTHERS => 387 FAILED ("WRONG EXCEPTION RAISED -- " & 388 "ASSIGN (Y, CREATE (4, 5, 6, 7, C1, Y))"); 389 END; 390 391 BEGIN 392 ASSIGN (Y, CREATE (4, 5, 6, 9, C1, Y)); 393 FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & 394 "ASSIGN (Y, CREATE (4, 5, 6, 9, C1, Y))"); 395 IF EQUAL (Y, CREATE (4, 5, 6, 9, C1, Y)) THEN -- USE Y. 396 COMMENT ("Y ALTERED -- " & 397 "ASSIGN (Y, CREATE (4, 5, 6, 9, C1, Y))"); 398 END IF; 399 EXCEPTION 400 WHEN CONSTRAINT_ERROR => 401 NULL; 402 WHEN OTHERS => 403 FAILED ("WRONG EXCEPTION RAISED -- " & 404 "ASSIGN (Y, CREATE (4, 5, 6, 9, C1, Y))"); 405 END; 406 407 RESULT; 408END C34005U; 409