1-- C34005V.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 THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED 27-- (IMPLICITLY) FOR DERIVED MULTI-DIMENSIONAL ARRAY TYPES WHOSE 28-- COMPONENT TYPE IS A LIMITED TYPE. THIS TEST IS PART 2 OF 2 29-- TESTS WHICH COVER THE OBJECTIVE. THE FIRST PART IS IN TEST 30-- C34005S. 31 32-- HISTORY: 33-- BCB 04/12/90 CREATED ORIGINAL TEST FROM SPLIT OF C34005S.ADA. 34-- RLB 10/03/02 REMOVED ILLEGAL (BY AI-246) TYPE CONVERSIONS AND 35-- SUPPORTING CODE. 36 37WITH SYSTEM; USE SYSTEM; 38WITH REPORT; USE REPORT; 39 40PROCEDURE C34005V IS 41 42 PACKAGE PKG_L IS 43 44 TYPE LP IS LIMITED PRIVATE; 45 46 FUNCTION CREATE (X : INTEGER) RETURN LP; 47 48 FUNCTION VALUE (X : LP) RETURN INTEGER; 49 50 FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN; 51 52 PROCEDURE ASSIGN (X : OUT LP; Y : LP); 53 54 C1 : CONSTANT LP; 55 C2 : CONSTANT LP; 56 C3 : CONSTANT LP; 57 C4 : CONSTANT LP; 58 C5 : CONSTANT LP; 59 C6 : CONSTANT LP; 60 C7 : CONSTANT LP; 61 C8 : CONSTANT LP; 62 C9 : CONSTANT LP; 63 C10 : CONSTANT LP; 64 C11 : CONSTANT LP; 65 C12 : CONSTANT LP; 66 C13 : CONSTANT LP; 67 C14 : CONSTANT LP; 68 69 PRIVATE 70 71 TYPE LP IS NEW INTEGER; 72 73 C1 : CONSTANT LP := 1; 74 C2 : CONSTANT LP := 2; 75 C3 : CONSTANT LP := 3; 76 C4 : CONSTANT LP := 4; 77 C5 : CONSTANT LP := 5; 78 C6 : CONSTANT LP := 6; 79 C7 : CONSTANT LP := 7; 80 C8 : CONSTANT LP := 8; 81 C9 : CONSTANT LP := 9; 82 C10 : CONSTANT LP := 10; 83 C11 : CONSTANT LP := 11; 84 C12 : CONSTANT LP := 12; 85 C13 : CONSTANT LP := 13; 86 C14 : CONSTANT LP := 14; 87 88 END PKG_L; 89 90 USE PKG_L; 91 92 SUBTYPE COMPONENT IS LP; 93 94 PACKAGE PKG_P IS 95 96 FIRST : CONSTANT := 0; 97 LAST : CONSTANT := 10; 98 99 SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST; 100 101 TYPE PARENT IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) OF 102 COMPONENT; 103 104 FUNCTION CREATE ( F1, L1 : INDEX; 105 F2, L2 : INDEX; 106 C : COMPONENT; 107 DUMMY : PARENT -- TO RESOLVE OVERLOADING. 108 ) RETURN PARENT; 109 110 FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN; 111 112 FUNCTION AGGR (A, B, C, D : COMPONENT) RETURN PARENT; 113 114 FUNCTION AGGR (A, B, C, D, E, F : COMPONENT) RETURN PARENT; 115 116 FUNCTION AGGR (A, B, C, D, E, F, G, H : COMPONENT) 117 RETURN PARENT; 118 119 FUNCTION AGGR (A, B, C, D, E, F, G, H, I : COMPONENT) 120 RETURN PARENT; 121 122 END PKG_P; 123 124 USE PKG_P; 125 126 TYPE T IS NEW PARENT (IDENT_INT (4) .. IDENT_INT (5), 127 IDENT_INT (6) .. IDENT_INT (8)); 128 129 X : T; 130 W : PARENT (4 .. 5, 6 .. 8); 131 C : COMPONENT; 132 B : BOOLEAN := FALSE; 133 N : CONSTANT := 2; 134 135 PROCEDURE A (X : ADDRESS) IS 136 BEGIN 137 B := IDENT_BOOL (TRUE); 138 END A; 139 140 FUNCTION V RETURN T IS 141 RESULT : T; 142 BEGIN 143 FOR I IN RESULT'RANGE LOOP 144 FOR J IN RESULT'RANGE(2) LOOP 145 ASSIGN (RESULT (I, J), C); 146 END LOOP; 147 END LOOP; 148 RETURN RESULT; 149 END V; 150 151 PACKAGE BODY PKG_L IS 152 153 FUNCTION CREATE (X : INTEGER) RETURN LP IS 154 BEGIN 155 RETURN LP (IDENT_INT (X)); 156 END CREATE; 157 158 FUNCTION VALUE (X : LP) RETURN INTEGER IS 159 BEGIN 160 RETURN INTEGER (X); 161 END VALUE; 162 163 FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS 164 BEGIN 165 RETURN X = Y; 166 END EQUAL; 167 168 PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS 169 BEGIN 170 X := Y; 171 END ASSIGN; 172 173 END PKG_L; 174 175 PACKAGE BODY PKG_P IS 176 177 FUNCTION CREATE 178 ( F1, L1 : INDEX; 179 F2, L2 : INDEX; 180 C : COMPONENT; 181 DUMMY : PARENT 182 ) RETURN PARENT 183 IS 184 A : PARENT (F1 .. L1, F2 .. L2); 185 B : COMPONENT; 186 BEGIN 187 ASSIGN (B, C); 188 FOR I IN F1 .. L1 LOOP 189 FOR J IN F2 .. L2 LOOP 190 ASSIGN (A (I, J), B); 191 ASSIGN (B, CREATE (VALUE (B) + 1)); 192 END LOOP; 193 END LOOP; 194 RETURN A; 195 END CREATE; 196 197 FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS 198 BEGIN 199 IF X'LENGTH /= Y'LENGTH OR 200 X'LENGTH(2) /= Y'LENGTH(2) THEN 201 RETURN FALSE; 202 ELSE FOR I IN X'RANGE LOOP 203 FOR J IN X'RANGE(2) LOOP 204 IF NOT EQUAL (X (I, J), 205 Y (I - X'FIRST + Y'FIRST, 206 J - X'FIRST(2) + 207 Y'FIRST(2))) THEN 208 RETURN FALSE; 209 END IF; 210 END LOOP; 211 END LOOP; 212 END IF; 213 RETURN TRUE; 214 END EQUAL; 215 216 FUNCTION AGGR (A, B, C, D : COMPONENT) RETURN PARENT IS 217 X : PARENT (INDEX'FIRST .. INDEX'FIRST + 1, 218 INDEX'FIRST .. INDEX'FIRST + 1); 219 BEGIN 220 ASSIGN (X (INDEX'FIRST , INDEX'FIRST ), A); 221 ASSIGN (X (INDEX'FIRST , INDEX'FIRST + 1), B); 222 ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST ), C); 223 ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 1), D); 224 RETURN X; 225 END AGGR; 226 227 FUNCTION AGGR (A, B, C, D, E, F : COMPONENT) RETURN PARENT IS 228 X : PARENT (INDEX'FIRST .. INDEX'FIRST + 1, 229 INDEX'FIRST .. INDEX'FIRST + 2); 230 BEGIN 231 ASSIGN (X (INDEX'FIRST , INDEX'FIRST ), A); 232 ASSIGN (X (INDEX'FIRST , INDEX'FIRST + 1), B); 233 ASSIGN (X (INDEX'FIRST , INDEX'FIRST + 2), C); 234 ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST ), D); 235 ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 1), E); 236 ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 2), F); 237 RETURN X; 238 END AGGR; 239 240 FUNCTION AGGR (A, B, C, D, E, F, G, H : COMPONENT) 241 RETURN PARENT IS 242 X : PARENT (INDEX'FIRST .. INDEX'FIRST + 3, 243 INDEX'FIRST .. INDEX'FIRST + 1); 244 BEGIN 245 ASSIGN (X (INDEX'FIRST , INDEX'FIRST ), A); 246 ASSIGN (X (INDEX'FIRST , INDEX'FIRST + 1), B); 247 ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST ), C); 248 ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 1), D); 249 ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST ), E); 250 ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST + 1), F); 251 ASSIGN (X (INDEX'FIRST + 3, INDEX'FIRST ), G); 252 ASSIGN (X (INDEX'FIRST + 3, INDEX'FIRST + 1), H); 253 RETURN X; 254 END AGGR; 255 256 FUNCTION AGGR (A, B, C, D, E, F, G, H, I : COMPONENT) 257 RETURN PARENT IS 258 X : PARENT (INDEX'FIRST .. INDEX'FIRST + 2, 259 INDEX'FIRST .. INDEX'FIRST + 2); 260 BEGIN 261 ASSIGN (X (INDEX'FIRST , INDEX'FIRST ), A); 262 ASSIGN (X (INDEX'FIRST , INDEX'FIRST + 1), B); 263 ASSIGN (X (INDEX'FIRST , INDEX'FIRST + 2), C); 264 ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST ), D); 265 ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 1), E); 266 ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 2), F); 267 ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST ), G); 268 ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST + 1), H); 269 ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST + 2), I); 270 RETURN X; 271 END AGGR; 272 273 END PKG_P; 274 275BEGIN 276 TEST ("C34005V", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & 277 "ARE DECLARED (IMPLICITLY) FOR DERIVED " & 278 "MULTI-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " & 279 "TYPE IS A LIMITED TYPE. THIS TEST IS PART 2 " & 280 "OF 2 TESTS WHICH COVER THE OBJECTIVE. THE " & 281 "FIRST PART IS IN TEST C34005S"); 282 283 ASSIGN (X (IDENT_INT (4), IDENT_INT (6)), CREATE (1)); 284 ASSIGN (X (IDENT_INT (4), IDENT_INT (7)), CREATE (2)); 285 ASSIGN (X (IDENT_INT (4), IDENT_INT (8)), CREATE (3)); 286 ASSIGN (X (IDENT_INT (5), IDENT_INT (6)), CREATE (4)); 287 ASSIGN (X (IDENT_INT (5), IDENT_INT (7)), CREATE (5)); 288 ASSIGN (X (IDENT_INT (5), IDENT_INT (8)), CREATE (6)); 289 290 ASSIGN (W (4, 6), CREATE (1)); 291 ASSIGN (W (4, 7), CREATE (2)); 292 ASSIGN (W (4, 8), CREATE (3)); 293 ASSIGN (W (5, 6), CREATE (4)); 294 ASSIGN (W (5, 7), CREATE (5)); 295 ASSIGN (W (5, 8), CREATE (6)); 296 297 ASSIGN (C, CREATE (2)); 298 299 IF NOT EQUAL (T'(X), AGGR (C1, C2, C3, C4, C5, C6)) THEN 300 FAILED ("INCORRECT QUALIFICATION"); 301 END IF; 302 303 IF NOT EQUAL (T (X), AGGR (C1, C2, C3, C4, C5, C6)) THEN 304 FAILED ("INCORRECT SELF CONVERSION"); 305 END IF; 306 307 IF NOT EQUAL (T (W), AGGR (C1, C2, C3, C4, C5, C6)) THEN 308 FAILED ("INCORRECT CONVERSION FROM PARENT"); 309 END IF; 310 311 BEGIN 312 IF NOT EQUAL (PARENT (X), AGGR (C1, C2, C3, C4, C5, C6)) OR 313 NOT EQUAL (PARENT (CREATE (6, 9, 2, 3, C4, X)), 314 AGGR (C4, C5, C6, C7, C8, C9, C10, C11)) THEN 315 FAILED ("INCORRECT CONVERSION TO PARENT"); 316 END IF; 317 EXCEPTION 318 WHEN CONSTRAINT_ERROR => 319 FAILED ("CONSTRAINT_ERROR WHEN PREPARING TO CONVERT " & 320 "TO PARENT"); 321 WHEN OTHERS => 322 FAILED ("EXCEPTION WHEN PREPARING TO CONVERT " & 323 "TO PARENT"); 324 END; 325 326 IF NOT (X IN T) OR AGGR (C1, C2, C3, C4) IN T THEN 327 FAILED ("INCORRECT ""IN"""); 328 END IF; 329 330 IF X NOT IN T OR 331 NOT (AGGR (C1, C2, C3, C4, C5, C6, C7, C8, C9) NOT IN T) THEN 332 FAILED ("INCORRECT ""NOT IN"""); 333 END IF; 334 335 RESULT; 336END C34005V; 337