1-- C34007M.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 WITHOUT 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 C34007M IS 44 45 SUBTYPE COMPONENT IS INTEGER; 46 47 TYPE DESIGNATED IS 48 RECORD 49 C : COMPONENT; 50 B : BOOLEAN := TRUE; 51 END RECORD; 52 53 TYPE PARENT IS ACCESS DESIGNATED; 54 55 TYPE T IS NEW PARENT; 56 57 X : T := NEW DESIGNATED'(2, FALSE); 58 K : INTEGER := X'SIZE; 59 Y : T := NEW DESIGNATED'(1, TRUE); 60 W : PARENT := NEW DESIGNATED'(2, FALSE); 61 C : COMPONENT := 1; 62 63 PROCEDURE A (X : ADDRESS) IS 64 BEGIN 65 NULL; 66 END A; 67 68 FUNCTION IDENT (X : T) RETURN T IS 69 BEGIN 70 IF X = NULL OR ELSE EQUAL (X.C, X.C) THEN 71 RETURN X; -- ALWAYS EXECUTED. 72 END IF; 73 RETURN NEW DESIGNATED'(-1, FALSE); 74 END IDENT; 75 76BEGIN 77 TEST ("C34007M", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & 78 "ARE DECLARED (IMPLICITLY) FOR DERIVED " & 79 "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " & 80 "RECORD TYPE WITHOUT DISCRIMINANTS"); 81 82 IF Y = NULL OR ELSE Y.ALL /= (1, TRUE) THEN 83 FAILED ("INCORRECT INITIALIZATION"); 84 END IF; 85 86 X := IDENT (Y); 87 IF X /= Y THEN 88 FAILED ("INCORRECT :="); 89 END IF; 90 91 IF T'(X) /= Y THEN 92 FAILED ("INCORRECT QUALIFICATION"); 93 END IF; 94 95 IF T (X) /= Y THEN 96 FAILED ("INCORRECT SELF CONVERSION"); 97 END IF; 98 99 IF EQUAL (3, 3) THEN 100 W := NEW DESIGNATED'(1, TRUE); 101 END IF; 102 X := T (W); 103 IF X = NULL OR ELSE X = Y OR ELSE X.ALL /= (1, TRUE) THEN 104 FAILED ("INCORRECT CONVERSION FROM PARENT"); 105 END IF; 106 107 X := IDENT (Y); 108 W := PARENT (X); 109 IF W = NULL OR ELSE W.ALL /= (1, TRUE) OR ELSE T (W) /= Y THEN 110 FAILED ("INCORRECT CONVERSION TO PARENT"); 111 END IF; 112 113 IF IDENT (NULL) /= NULL OR X = NULL THEN 114 FAILED ("INCORRECT NULL"); 115 END IF; 116 117 X := IDENT (NEW DESIGNATED'(1, TRUE)); 118 IF X = NULL OR ELSE X = Y OR ELSE X.ALL /= (1, TRUE) THEN 119 FAILED ("INCORRECT ALLOCATOR"); 120 END IF; 121 122 X := IDENT (Y); 123 IF X.C /= 1 OR X.B /= TRUE THEN 124 FAILED ("INCORRECT SELECTION (VALUE)"); 125 END IF; 126 127 X.C := IDENT_INT (3); 128 X.B := IDENT_BOOL (FALSE); 129 IF X /= Y OR Y.ALL /= (3, FALSE) THEN 130 FAILED ("INCORRECT SELECTION (ASSIGNMENT)"); 131 END IF; 132 133 Y.ALL := (1, TRUE); 134 X := IDENT (Y); 135 IF X.ALL /= (1, TRUE) THEN 136 FAILED ("INCORRECT .ALL (VALUE)"); 137 END IF; 138 139 X.ALL := (10, FALSE); 140 IF X /= Y OR Y.ALL /= (10, FALSE) THEN 141 FAILED ("INCORRECT .ALL (ASSIGNMENT)"); 142 END IF; 143 144 Y.ALL := (1, TRUE); 145 X := IDENT (NULL); 146 BEGIN 147 IF X.ALL = (0, FALSE) THEN 148 FAILED ("NO EXCEPTION FOR NULL.ALL - 1"); 149 ELSE FAILED ("NO EXCEPTION FOR NULL.ALL - 2"); 150 END IF; 151 EXCEPTION 152 WHEN CONSTRAINT_ERROR => 153 NULL; 154 WHEN OTHERS => 155 FAILED ("WRONG EXCEPTION FOR NULL.ALL"); 156 END; 157 158 X := IDENT (Y); 159 IF X = NULL OR X = NEW DESIGNATED OR NOT (X = Y) THEN 160 FAILED ("INCORRECT ="); 161 END IF; 162 163 IF X /= Y OR NOT (X /= NULL) THEN 164 FAILED ("INCORRECT /="); 165 END IF; 166 167 IF NOT (X IN T) THEN 168 FAILED ("INCORRECT ""IN"""); 169 END IF; 170 171 IF X NOT IN T THEN 172 FAILED ("INCORRECT ""NOT IN"""); 173 END IF; 174 175 A (X'ADDRESS); 176 177 BEGIN 178 IF T'STORAGE_SIZE /= PARENT'STORAGE_SIZE THEN 179 FAILED ("COLLECTION SIZE OF DERIVED TYPE IS NOT " & 180 "EQUAL TO COLLECTION SIZE OF PARENT TYPE"); 181 END IF; 182 EXCEPTION 183 WHEN PROGRAM_ERROR => 184 COMMENT ("PROGRAM_ERROR RAISED FOR " & 185 "UNDEFINED STORAGE_SIZE (AI-00608)"); 186 WHEN OTHERS => 187 FAILED ("UNEXPECTED EXCEPTION RAISED"); 188 END; 189 190 RESULT; 191END C34007M; 192