1-- C34005G.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 ONE-DIMENSIONAL ARRAY TYPES 28-- WHOSE COMPONENT TYPE IS A CHARACTER TYPE. 29 30-- HISTORY: 31-- JRK 9/15/86 CREATED ORIGINAL TEST. 32-- RJW 8/21/89 MODIFIED CHECKS FOR OBJECT AND TYPE SIZES. 33-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. 34 35WITH SYSTEM; USE SYSTEM; 36WITH REPORT; USE REPORT; 37 38PROCEDURE C34005G IS 39 40 TYPE COMPONENT IS NEW CHARACTER; 41 42 PACKAGE PKG IS 43 44 FIRST : CONSTANT := 0; 45 LAST : CONSTANT := 100; 46 47 SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST; 48 49 TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT; 50 51 FUNCTION CREATE ( F, L : INDEX; 52 C : COMPONENT; 53 DUMMY : PARENT -- TO RESOLVE OVERLOADING. 54 ) RETURN PARENT; 55 56 END PKG; 57 58 USE PKG; 59 60 TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7)); 61 62 TYPE ARRT IS ARRAY (INTEGER RANGE <>) OF COMPONENT; 63 SUBTYPE ARR IS ARRT (2 .. 4); 64 65 X : T := (OTHERS => 'B'); 66 W : PARENT (5 .. 7) := (OTHERS => 'B'); 67 C : COMPONENT := 'A'; 68 B : BOOLEAN := FALSE; 69 U : ARR := (OTHERS => C); 70 N : CONSTANT := 1; 71 72 PROCEDURE A (X : ADDRESS) IS 73 BEGIN 74 B := IDENT_BOOL (TRUE); 75 END A; 76 77 FUNCTION V RETURN T IS 78 BEGIN 79 RETURN (OTHERS => C); 80 END V; 81 82 PACKAGE BODY PKG IS 83 84 FUNCTION CREATE 85 ( F, L : INDEX; 86 C : COMPONENT; 87 DUMMY : PARENT 88 ) RETURN PARENT 89 IS 90 A : PARENT (F .. L); 91 B : COMPONENT := C; 92 BEGIN 93 FOR I IN F .. L LOOP 94 A (I) := B; 95 B := COMPONENT'SUCC (B); 96 END LOOP; 97 RETURN A; 98 END CREATE; 99 100 END PKG; 101 102 FUNCTION IDENT (X : T) RETURN T IS 103 BEGIN 104 IF EQUAL (X'LENGTH, X'LENGTH) THEN 105 RETURN X; -- ALWAYS EXECUTED. 106 END IF; 107 RETURN (OTHERS => '-'); 108 END IDENT; 109 110BEGIN 111 TEST ("C34005G", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & 112 "ARE DECLARED (IMPLICITLY) FOR DERIVED " & 113 "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " & 114 "TYPE IS A CHARACTER TYPE"); 115 116 X := IDENT ("ABC"); 117 IF X /= "ABC" THEN 118 FAILED ("INCORRECT :="); 119 END IF; 120 121 IF T'(X) /= "ABC" THEN 122 FAILED ("INCORRECT QUALIFICATION"); 123 END IF; 124 125 IF T (X) /= "ABC" THEN 126 FAILED ("INCORRECT SELF CONVERSION"); 127 END IF; 128 129 IF EQUAL (3, 3) THEN 130 W := "ABC"; 131 END IF; 132 IF T (W) /= "ABC" THEN 133 FAILED ("INCORRECT CONVERSION FROM PARENT"); 134 END IF; 135 136 BEGIN 137 IF PARENT (X) /= "ABC" OR 138 PARENT (CREATE (2, 3, 'D', X)) /= "DE" THEN 139 FAILED ("INCORRECT CONVERSION TO PARENT"); 140 END IF; 141 EXCEPTION 142 WHEN CONSTRAINT_ERROR => 143 FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 1"); 144 WHEN OTHERS => 145 FAILED ("CALL TO CREATE RAISED EXCEPTION - 1"); 146 END; 147 148 IF EQUAL (3, 3) THEN 149 U := "ABC"; 150 END IF; 151 IF T (U) /= "ABC" THEN 152 FAILED ("INCORRECT CONVERSION FROM ARRAY"); 153 END IF; 154 155 BEGIN 156 IF ARR (X) /= "ABC" OR 157 ARRT (CREATE (1, 2, 'C', X)) /= "CD" THEN 158 FAILED ("INCORRECT CONVERSION TO ARRAY"); 159 END IF; 160 EXCEPTION 161 WHEN CONSTRAINT_ERROR => 162 FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 2"); 163 WHEN OTHERS => 164 FAILED ("CALL TO CREATE RAISED EXCEPTION - 2"); 165 END; 166 167 IF IDENT ("ABC") /= ('A', 'B', 'C') OR 168 X = "AB" THEN 169 FAILED ("INCORRECT STRING LITERAL"); 170 END IF; 171 172 IF IDENT (('A', 'B', 'C')) /= "ABC" OR 173 X = ('A', 'B') THEN 174 FAILED ("INCORRECT AGGREGATE"); 175 END IF; 176 177 BEGIN 178 IF X (IDENT_INT (5)) /= 'A' OR 179 CREATE (2, 3, 'D', X) (3) /= 'E' THEN 180 FAILED ("INCORRECT INDEX (VALUE)"); 181 END IF; 182 EXCEPTION 183 WHEN CONSTRAINT_ERROR => 184 FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 3"); 185 WHEN OTHERS => 186 FAILED ("CALL TO CREATE RAISED EXCEPTION - 3"); 187 END; 188 189 X (IDENT_INT (7)) := 'D'; 190 IF X /= "ABD" THEN 191 FAILED ("INCORRECT INDEX (ASSIGNMENT)"); 192 END IF; 193 194 BEGIN 195 X := IDENT ("ABC"); 196 IF X (IDENT_INT (6) .. IDENT_INT (7)) /= "BC" OR 197 CREATE (1, 4, 'D', X) (1 .. 3) /= "DEF" THEN 198 FAILED ("INCORRECT SLICE (VALUE)"); 199 END IF; 200 EXCEPTION 201 WHEN CONSTRAINT_ERROR => 202 FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 4"); 203 WHEN OTHERS => 204 FAILED ("CALL TO CREATE RAISED EXCEPTION - 4"); 205 END; 206 207 X (IDENT_INT (5) .. IDENT_INT (6)) := "DE"; 208 IF X /= "DEC" THEN 209 FAILED ("INCORRECT SLICE (ASSIGNMENT)"); 210 END IF; 211 212 X := IDENT ("ABC"); 213 IF X = IDENT ("ABD") OR X = "AB" THEN 214 FAILED ("INCORRECT ="); 215 END IF; 216 217 IF X /= IDENT ("ABC") OR NOT (X /= "BC") THEN 218 FAILED ("INCORRECT /="); 219 END IF; 220 221 IF X < IDENT ("ABC") OR X < "AB" THEN 222 FAILED ("INCORRECT <"); 223 END IF; 224 225 IF X > IDENT ("ABC") OR X > "AC" THEN 226 FAILED ("INCORRECT >"); 227 END IF; 228 229 IF X <= IDENT ("ABB") OR X <= "ABBD" THEN 230 FAILED ("INCORRECT <="); 231 END IF; 232 233 IF X >= IDENT ("ABD") OR X >= "ABCA" THEN 234 FAILED ("INCORRECT >="); 235 END IF; 236 237 IF NOT (X IN T) OR "AB" IN T THEN 238 FAILED ("INCORRECT ""IN"""); 239 END IF; 240 241 IF X NOT IN T OR NOT ("AB" NOT IN T) THEN 242 FAILED ("INCORRECT ""NOT IN"""); 243 END IF; 244 245 BEGIN 246 IF X & "DEF" /= "ABCDEF" OR 247 CREATE (2, 3, 'B', X) & "DE" /= "BCDE" THEN 248 FAILED ("INCORRECT & (ARRAY, ARRAY)"); 249 END IF; 250 EXCEPTION 251 WHEN CONSTRAINT_ERROR => 252 FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 5"); 253 WHEN OTHERS => 254 FAILED ("CALL TO CREATE RAISED EXCEPTION - 5"); 255 END; 256 257 BEGIN 258 IF X & 'D' /= "ABCD" OR 259 CREATE (2, 3, 'B', X) & 'D' /= "BCD" THEN 260 FAILED ("INCORRECT & (ARRAY, COMPONENT)"); 261 END IF; 262 EXCEPTION 263 WHEN CONSTRAINT_ERROR => 264 FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 6"); 265 WHEN OTHERS => 266 FAILED ("CALL TO CREATE RAISED EXCEPTION - 6"); 267 END; 268 269 BEGIN 270 IF 'D' & X /= "DABC" OR 271 'B' & CREATE (2, 3, 'C', X) /= "BCD" THEN 272 FAILED ("INCORRECT & (COMPONENT, ARRAY)"); 273 END IF; 274 EXCEPTION 275 WHEN CONSTRAINT_ERROR => 276 FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 7"); 277 WHEN OTHERS => 278 FAILED ("CALL TO CREATE RAISED EXCEPTION - 7"); 279 END; 280 281 IF EQUAL (3, 3) THEN 282 C := 'B'; 283 END IF; 284 285 BEGIN 286 IF C & 'C' /= CREATE (2, 3, 'B', X) THEN 287 FAILED ("INCORRECT & (COMPONENT, COMPONENT)"); 288 END IF; 289 EXCEPTION 290 WHEN CONSTRAINT_ERROR => 291 FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 8"); 292 WHEN OTHERS => 293 FAILED ("CALL TO CREATE RAISED EXCEPTION - 8"); 294 END; 295 296 B := FALSE; 297 A (X'ADDRESS); 298 IF NOT B THEN 299 FAILED ("INCORRECT 'ADDRESS"); 300 END IF; 301 302 IF T'FIRST /= 5 THEN 303 FAILED ("INCORRECT TYPE'FIRST"); 304 END IF; 305 306 IF X'FIRST /= 5 THEN 307 FAILED ("INCORRECT OBJECT'FIRST"); 308 END IF; 309 310 IF V'FIRST /= 5 THEN 311 FAILED ("INCORRECT VALUE'FIRST"); 312 END IF; 313 314 IF T'FIRST (N) /= 5 THEN 315 FAILED ("INCORRECT TYPE'FIRST (N)"); 316 END IF; 317 318 IF X'FIRST (N) /= 5 THEN 319 FAILED ("INCORRECT OBJECT'FIRST (N)"); 320 END IF; 321 322 IF V'FIRST (N) /= 5 THEN 323 FAILED ("INCORRECT VALUE'FIRST (N)"); 324 END IF; 325 326 IF T'LAST /= 7 THEN 327 FAILED ("INCORRECT TYPE'LAST"); 328 END IF; 329 330 IF X'LAST /= 7 THEN 331 FAILED ("INCORRECT OBJECT'LAST"); 332 END IF; 333 334 IF V'LAST /= 7 THEN 335 FAILED ("INCORRECT VALUE'LAST"); 336 END IF; 337 338 IF T'LAST (N) /= 7 THEN 339 FAILED ("INCORRECT TYPE'LAST (N)"); 340 END IF; 341 342 IF X'LAST (N) /= 7 THEN 343 FAILED ("INCORRECT OBJECT'LAST (N)"); 344 END IF; 345 346 IF V'LAST (N) /= 7 THEN 347 FAILED ("INCORRECT VALUE'LAST (N)"); 348 END IF; 349 350 IF T'LENGTH /= 3 THEN 351 FAILED ("INCORRECT TYPE'LENGTH"); 352 END IF; 353 354 IF X'LENGTH /= 3 THEN 355 FAILED ("INCORRECT OBJECT'LENGTH"); 356 END IF; 357 358 IF V'LENGTH /= 3 THEN 359 FAILED ("INCORRECT VALUE'LENGTH"); 360 END IF; 361 362 IF T'LENGTH (N) /= 3 THEN 363 FAILED ("INCORRECT TYPE'LENGTH (N)"); 364 END IF; 365 366 IF X'LENGTH (N) /= 3 THEN 367 FAILED ("INCORRECT OBJECT'LENGTH (N)"); 368 END IF; 369 370 IF V'LENGTH (N) /= 3 THEN 371 FAILED ("INCORRECT VALUE'LENGTH (N)"); 372 END IF; 373 374 DECLARE 375 Y : PARENT (T'RANGE); 376 BEGIN 377 IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN 378 FAILED ("INCORRECT TYPE'RANGE"); 379 END IF; 380 END; 381 382 DECLARE 383 Y : PARENT (X'RANGE); 384 BEGIN 385 IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN 386 FAILED ("INCORRECT OBJECT'RANGE"); 387 END IF; 388 END; 389 390 DECLARE 391 Y : PARENT (V'RANGE); 392 BEGIN 393 IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN 394 FAILED ("INCORRECT VALUE'RANGE"); 395 END IF; 396 END; 397 398 DECLARE 399 Y : PARENT (T'RANGE (N)); 400 BEGIN 401 IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN 402 FAILED ("INCORRECT TYPE'RANGE (N)"); 403 END IF; 404 END; 405 406 DECLARE 407 Y : PARENT (X'RANGE (N)); 408 BEGIN 409 IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN 410 FAILED ("INCORRECT OBJECT'RANGE (N)"); 411 END IF; 412 END; 413 414 DECLARE 415 Y : PARENT (V'RANGE (N)); 416 BEGIN 417 IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN 418 FAILED ("INCORRECT VALUE'RANGE (N)"); 419 END IF; 420 END; 421 422 RESULT; 423END C34005G; 424