1-- C34007A.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 28-- NOT AN ARRAY TYPE, A TASK TYPE, A RECORD TYPE, OR A TYPE WITH 29-- DISCRIMINANTS. 30 31-- HISTORY: 32-- JRK 09/24/86 CREATED ORIGINAL TEST. 33-- BCB 10/21/87 CHANGED HEADER TO STANDARD FORMAT. REVISED TEST SO 34-- T'STORAGE_SIZE IS NOT REQUIRED TO BE > 1. 35-- BCB 09/26/88 REMOVED COMPARISON INVOLVING OBJECT SIZE. 36-- BCB 03/07/90 PUT CHECK FOR 'STORAGE_SIZE IN EXCEPTION HANDLER. 37-- THS 09/18/90 REMOVED DECLARATION OF B, MADE THE BODY OF 38-- PROCEDURE A NULL, AND DELETED ALL REFERENCES TO B. 39-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. 40 41WITH SYSTEM; USE SYSTEM; 42WITH REPORT; USE REPORT; 43 44PROCEDURE C34007A IS 45 46 TYPE DESIGNATED IS RANGE -100 .. 100; 47 48 SUBTYPE SUBDESIGNATED IS DESIGNATED RANGE 49 DESIGNATED'VAL (IDENT_INT (-50)) .. 50 DESIGNATED'VAL (IDENT_INT ( 50)); 51 52 TYPE PARENT IS ACCESS SUBDESIGNATED RANGE 53 DESIGNATED'VAL (IDENT_INT (-30)) .. 54 DESIGNATED'VAL (IDENT_INT ( 30)); 55 56 TYPE T IS NEW PARENT; 57 58 X : T := NEW DESIGNATED'(-30); 59 K : INTEGER := X'SIZE; 60 Y : T := NEW DESIGNATED'( 30); 61 W : PARENT := NEW DESIGNATED'( 30); 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 71 EQUAL (DESIGNATED'POS (X.ALL), DESIGNATED'POS (X.ALL)) THEN 72 RETURN X; -- ALWAYS EXECUTED. 73 END IF; 74 RETURN NEW DESIGNATED; 75 END IDENT; 76 77BEGIN 78 TEST ("C34007A", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & 79 "ARE DECLARED (IMPLICITLY) FOR DERIVED " & 80 "ACCESS TYPES WHOSE DESIGNATED TYPE IS NOT AN " & 81 "ARRAY TYPE, A TASK TYPE, A RECORD TYPE, OR A " & 82 "TYPE WITH DISCRIMINANTS"); 83 84 IF Y = NULL OR ELSE Y.ALL /= 30 THEN 85 FAILED ("INCORRECT INITIALIZATION"); 86 END IF; 87 88 X := IDENT (Y); 89 IF X /= Y THEN 90 FAILED ("INCORRECT :="); 91 END IF; 92 93 IF T'(X) /= Y THEN 94 FAILED ("INCORRECT QUALIFICATION"); 95 END IF; 96 97 IF T (X) /= Y THEN 98 FAILED ("INCORRECT SELF CONVERSION"); 99 END IF; 100 101 IF EQUAL (3, 3) THEN 102 W := NEW DESIGNATED'(-30); 103 END IF; 104 X := T (W); 105 IF X = NULL OR ELSE X = Y OR ELSE X.ALL /= -30 THEN 106 FAILED ("INCORRECT CONVERSION FROM PARENT"); 107 END IF; 108 109 X := IDENT (Y); 110 W := PARENT (X); 111 IF W = NULL OR ELSE W.ALL /= 30 OR ELSE T (W) /= Y THEN 112 FAILED ("INCORRECT CONVERSION TO PARENT"); 113 END IF; 114 115 IF IDENT (NULL) /= NULL OR X = NULL THEN 116 FAILED ("INCORRECT NULL"); 117 END IF; 118 119 X := IDENT (NEW DESIGNATED'(30)); 120 IF X = NULL OR ELSE X = Y OR ELSE X.ALL /= 30 THEN 121 FAILED ("INCORRECT ALLOCATOR"); 122 END IF; 123 124 X := IDENT (Y); 125 IF X.ALL /= 30 THEN 126 FAILED ("INCORRECT .ALL (VALUE)"); 127 END IF; 128 129 X.ALL := DESIGNATED'VAL (IDENT_INT (10)); 130 IF X /= Y OR Y.ALL /= 10 THEN 131 FAILED ("INCORRECT .ALL (ASSIGNMENT)"); 132 END IF; 133 134 Y.ALL := 30; 135 X := IDENT (NULL); 136 BEGIN 137 IF X.ALL = 0 THEN 138 FAILED ("NO EXCEPTION FOR NULL.ALL - 1"); 139 ELSE FAILED ("NO EXCEPTION FOR NULL.ALL - 2"); 140 END IF; 141 EXCEPTION 142 WHEN CONSTRAINT_ERROR => 143 NULL; 144 WHEN OTHERS => 145 FAILED ("WRONG EXCEPTION FOR NULL.ALL"); 146 END; 147 148 X := IDENT (Y); 149 IF X = NULL OR X = NEW DESIGNATED OR NOT (X = Y) THEN 150 FAILED ("INCORRECT ="); 151 END IF; 152 153 IF X /= Y OR NOT (X /= NULL) THEN 154 FAILED ("INCORRECT /="); 155 END IF; 156 157 IF NOT (X IN T) THEN 158 FAILED ("INCORRECT ""IN"""); 159 END IF; 160 161 IF X NOT IN T THEN 162 FAILED ("INCORRECT ""NOT IN"""); 163 END IF; 164 165 A (X'ADDRESS); 166 167 BEGIN 168 IF T'STORAGE_SIZE /= PARENT'STORAGE_SIZE THEN 169 FAILED ("COLLECTION SIZE OF DERIVED TYPE IS NOT " & 170 "EQUAL OF COLLECTION SIZE OF PARENT TYPE"); 171 END IF; 172 EXCEPTION 173 WHEN PROGRAM_ERROR => 174 COMMENT ("PROGRAM_ERROR RAISED FOR " & 175 "UNDEFINED STORAGE_SIZE (AI-00608)"); 176 WHEN OTHERS => 177 FAILED ("UNEXPECTED EXCEPTION RAISED"); 178 END; 179 180 RESULT; 181END C34007A; 182