1-- C34007P.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 ACCESS TYPES WHOSE DESIGNATED TYPE IS A 28-- RECORD TYPE WITH DISCRIMINANTS. 29 30-- HISTORY: 31-- JRK 09/29/86 CREATED ORIGINAL TEST. 32-- BCB 10/21/87 CHANGED HEADER TO STANDARD FORMAT. REVISED TEST SO 33-- T'STORAGE_SIZE IS NOT REQUIRED TO BE > 1. 34-- BCB 09/26/88 REMOVED COMPARISON INVOLVING OBJECT SIZE. 35-- BCB 03/07/90 PUT CHECK FOR 'STORAGE_SIZE IN EXCEPTION HANDLER. 36-- THS 09/18/90 REMOVED DECLARATION OF B, MADE THE BODY OF 37-- PROCEDURE A NULL, AND DELETED ALL REFERENCES TO B. 38-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. 39 40WITH SYSTEM; USE SYSTEM; 41WITH REPORT; USE REPORT; 42 43PROCEDURE C34007P IS 44 45 SUBTYPE COMPONENT IS INTEGER; 46 47 SUBTYPE LENGTH IS NATURAL RANGE 0 .. 10; 48 49 TYPE DESIGNATED (B : BOOLEAN := TRUE; L : LENGTH := 1) IS 50 RECORD 51 I : INTEGER; 52 CASE B IS 53 WHEN TRUE => 54 S : STRING (1 .. L); 55 C : COMPONENT; 56 WHEN FALSE => 57 F : FLOAT := 5.0; 58 END CASE; 59 END RECORD; 60 61 SUBTYPE SUBDESIGNATED IS DESIGNATED (IDENT_BOOL (TRUE), 62 IDENT_INT (3)); 63 64 PACKAGE PKG IS 65 66 TYPE PARENT IS ACCESS DESIGNATED; 67 68 FUNCTION CREATE ( B : BOOLEAN; 69 L : LENGTH; 70 I : INTEGER; 71 S : STRING; 72 C : COMPONENT; 73 F : FLOAT; 74 X : PARENT -- TO RESOLVE OVERLOADING. 75 ) RETURN PARENT; 76 77 END PKG; 78 79 USE PKG; 80 81 TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3)); 82 83 X : T := NEW DESIGNATED'(TRUE, 3, 2, "AAA", 2); 84 K : INTEGER := X'SIZE; 85 Y : T := NEW DESIGNATED'(TRUE, 3, 1, "ABC", 4); 86 W : PARENT := NEW DESIGNATED'(TRUE, 3, 2, "AAA", 2); 87 C : COMPONENT := 1; 88 89 PROCEDURE A (X : ADDRESS) IS 90 BEGIN 91 NULL; 92 END A; 93 94 PACKAGE BODY PKG IS 95 96 FUNCTION CREATE 97 ( B : BOOLEAN; 98 L : LENGTH; 99 I : INTEGER; 100 S : STRING; 101 C : COMPONENT; 102 F : FLOAT; 103 X : PARENT 104 ) RETURN PARENT 105 IS 106 BEGIN 107 CASE B IS 108 WHEN TRUE => 109 RETURN NEW DESIGNATED'(TRUE, L, I, S, C); 110 WHEN FALSE => 111 RETURN NEW DESIGNATED'(FALSE, L, I, F); 112 END CASE; 113 END CREATE; 114 115 END PKG; 116 117 FUNCTION IDENT (X : T) RETURN T IS 118 BEGIN 119 IF X = NULL OR ELSE EQUAL (X.I, X.I) THEN 120 RETURN X; -- ALWAYS EXECUTED. 121 END IF; 122 RETURN NEW DESIGNATED'(TRUE, 3, -1, "---", -1); 123 END IDENT; 124 125BEGIN 126 TEST ("C34007P", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & 127 "ARE DECLARED (IMPLICITLY) FOR DERIVED " & 128 "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " & 129 "RECORD TYPE WITH DISCRIMINANTS"); 130 131 IF Y = NULL OR ELSE Y.ALL /= (TRUE, 3, 1, "ABC", 4) THEN 132 FAILED ("INCORRECT INITIALIZATION"); 133 END IF; 134 135 X := IDENT (Y); 136 IF X /= Y THEN 137 FAILED ("INCORRECT :="); 138 END IF; 139 140 IF T'(X) /= Y THEN 141 FAILED ("INCORRECT QUALIFICATION"); 142 END IF; 143 144 IF T (X) /= Y THEN 145 FAILED ("INCORRECT SELF CONVERSION"); 146 END IF; 147 148 IF EQUAL (3, 3) THEN 149 W := NEW DESIGNATED'(TRUE, 3, 1, "ABC", 4); 150 END IF; 151 X := T (W); 152 IF X = NULL OR ELSE X = Y OR ELSE 153 X.ALL /= (TRUE, 3, 1, "ABC", 4) THEN 154 FAILED ("INCORRECT CONVERSION FROM PARENT"); 155 END IF; 156 157 X := IDENT (Y); 158 W := PARENT (X); 159 IF W = NULL OR ELSE W.ALL /= (TRUE, 3, 1, "ABC", 4) OR ELSE 160 T (W) /= Y THEN 161 FAILED ("INCORRECT CONVERSION TO PARENT - 1"); 162 END IF; 163 164 W := PARENT (CREATE (FALSE, 2, 3, "XX", 5, 6.0, X)); 165 IF W = NULL OR ELSE W.ALL /= (FALSE, 2, 3, 6.0) THEN 166 FAILED ("INCORRECT CONVERSION TO PARENT - 2"); 167 END IF; 168 169 IF IDENT (NULL) /= NULL OR X = NULL THEN 170 FAILED ("INCORRECT NULL"); 171 END IF; 172 173 X := IDENT (NEW DESIGNATED'(TRUE, 3, 1, "ABC", 4)); 174 IF (X = NULL OR ELSE X = Y OR ELSE 175 X.ALL /= (TRUE, 3, 1, "ABC", 4)) OR 176 X = NEW DESIGNATED'(FALSE, 3, 1, 4.0) THEN 177 FAILED ("INCORRECT ALLOCATOR"); 178 END IF; 179 180 X := IDENT (Y); 181 IF X.B /= TRUE OR X.L /= 3 OR 182 CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . B /= FALSE OR 183 CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . L /= 2 THEN 184 FAILED ("INCORRECT SELECTION (DISCRIMINANT)"); 185 END IF; 186 187 IF X.I /= 1 OR X.S /= "ABC" OR X.C /= 4 OR 188 CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . I /= 3 OR 189 CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . F /= 6.0 THEN 190 FAILED ("INCORRECT SELECTION (VALUE)"); 191 END IF; 192 193 X.I := IDENT_INT (7); 194 X.S := IDENT_STR ("XYZ"); 195 X.C := IDENT_INT (9); 196 IF X /= Y OR Y.ALL /= (TRUE, 3, 7, "XYZ", 9) THEN 197 FAILED ("INCORRECT SELECTION (ASSIGNMENT)"); 198 END IF; 199 200 Y.ALL := (TRUE, 3, 1, "ABC", 4); 201 X := IDENT (Y); 202 BEGIN 203 CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . I := 10; 204 CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . F := 10.0; 205 EXCEPTION 206 WHEN OTHERS => 207 FAILED ("EXCEPTION FOR SELECTION (ASSIGNMENT)"); 208 END; 209 210 IF X.ALL /= (TRUE, 3, 1, "ABC", 4) OR 211 CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . ALL /= 212 (FALSE, 2, 3, 6.0) THEN 213 FAILED ("INCORRECT .ALL (VALUE)"); 214 END IF; 215 216 X.ALL := (TRUE, 3, 10, "ZZZ", 15); 217 IF X /= Y OR Y.ALL /= (TRUE, 3, 10, "ZZZ", 15) THEN 218 FAILED ("INCORRECT .ALL (ASSIGNMENT)"); 219 END IF; 220 221 Y.ALL := (TRUE, 3, 1, "ABC", 4); 222 BEGIN 223 CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . ALL := 224 (FALSE, 2, 10, 15.0); 225 EXCEPTION 226 WHEN OTHERS => 227 FAILED ("EXCEPTION FOR .ALL (ASSIGNMENT)"); 228 END; 229 230 X := IDENT (NULL); 231 BEGIN 232 IF X.ALL = (FALSE, 0, 0, 0.0) THEN 233 FAILED ("NO EXCEPTION FOR NULL.ALL - 1"); 234 ELSE FAILED ("NO EXCEPTION FOR NULL.ALL - 2"); 235 END IF; 236 EXCEPTION 237 WHEN CONSTRAINT_ERROR => 238 NULL; 239 WHEN OTHERS => 240 FAILED ("WRONG EXCEPTION FOR NULL.ALL"); 241 END; 242 243 X := IDENT (Y); 244 IF X = NULL OR X = NEW SUBDESIGNATED OR NOT (X = Y) OR 245 X = CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) THEN 246 FAILED ("INCORRECT ="); 247 END IF; 248 249 IF X /= Y OR NOT (X /= NULL) OR 250 NOT (X /= CREATE (FALSE, 2, 3, "XX", 5, 6.0, X)) THEN 251 FAILED ("INCORRECT /="); 252 END IF; 253 254 IF NOT (X IN T) OR CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) IN T THEN 255 FAILED ("INCORRECT ""IN"""); 256 END IF; 257 258 IF X NOT IN T OR 259 NOT (CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) NOT IN T) THEN 260 FAILED ("INCORRECT ""NOT IN"""); 261 END IF; 262 263 A (X'ADDRESS); 264 265 IF T'SIZE < 1 THEN 266 FAILED ("INCORRECT TYPE'SIZE"); 267 END IF; 268 269 BEGIN 270 IF T'STORAGE_SIZE /= PARENT'STORAGE_SIZE THEN 271 FAILED ("COLLECTION SIZE OF DERIVED TYPE IS NOT " & 272 "EQUAL TO COLLECTION SIZE OF PARENT TYPE"); 273 END IF; 274 EXCEPTION 275 WHEN PROGRAM_ERROR => 276 COMMENT ("PROGRAM_ERROR RAISED FOR " & 277 "UNDEFINED STORAGE_SIZE (AI-00608)"); 278 WHEN OTHERS => 279 FAILED ("UNEXPECTED EXCEPTION RAISED"); 280 END; 281 282 RESULT; 283END C34007P; 284