1-- C43004C.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 CONSTRAINT_ERROR IS RAISED IF THE VALUE OF A 27-- DISCRIMINANT OF A CONSTRAINED COMPONENT OF AN AGGREGATE DOES 28-- NOT EQUAL THE CORRESPONDING DISCRIMINANT VALUE FOR THE 29-- COMPONENT'S SUBTYPE. 30 31-- HISTORY: 32-- BCB 07/19/88 CREATED ORIGINAL TEST. 33 34WITH REPORT; USE REPORT; 35 36PROCEDURE C43004C IS 37 38 ZERO : INTEGER := 0; 39 40 TYPE REC (D : INTEGER := 0) IS RECORD 41 COMP1 : INTEGER; 42 END RECORD; 43 44 TYPE DREC (DD : INTEGER := ZERO) IS RECORD 45 DCOMP1 : INTEGER; 46 END RECORD; 47 48 TYPE REC1 IS RECORD 49 A : REC(0); 50 END RECORD; 51 52 TYPE REC2 IS RECORD 53 B : DREC(ZERO); 54 END RECORD; 55 56 TYPE REC3 (D3 : INTEGER := 0) IS RECORD 57 C : REC(D3); 58 END RECORD; 59 60 V : REC1; 61 W : REC2; 62 X : REC3; 63 64 PACKAGE P IS 65 TYPE PRIV1 (D : INTEGER := 0) IS PRIVATE; 66 TYPE PRIV2 (DD : INTEGER := ZERO) IS PRIVATE; 67 FUNCTION INIT (I : INTEGER) RETURN PRIV1; 68 PRIVATE 69 TYPE PRIV1 (D : INTEGER := 0) IS RECORD 70 NULL; 71 END RECORD; 72 73 TYPE PRIV2 (DD : INTEGER := ZERO) IS RECORD 74 NULL; 75 END RECORD; 76 END P; 77 78 TYPE REC7 IS RECORD 79 H : P.PRIV1 (0); 80 END RECORD; 81 82 Y : REC7; 83 84 GENERIC 85 TYPE GP IS PRIVATE; 86 FUNCTION GEN_EQUAL (X, Y : GP) RETURN BOOLEAN; 87 88 FUNCTION GEN_EQUAL (X, Y : GP) RETURN BOOLEAN IS 89 BEGIN 90 RETURN X = Y; 91 END GEN_EQUAL; 92 93 PACKAGE BODY P IS 94 TYPE REC4 IS RECORD 95 E : PRIV1(0); 96 END RECORD; 97 98 TYPE REC5 IS RECORD 99 F : PRIV2(ZERO); 100 END RECORD; 101 102 TYPE REC6 (D6 : INTEGER := 0) IS RECORD 103 G : PRIV1(D6); 104 END RECORD; 105 106 VV : REC4; 107 WW : REC5; 108 XX : REC6; 109 110 FUNCTION REC4_EQUAL IS NEW GEN_EQUAL (REC4); 111 FUNCTION REC5_EQUAL IS NEW GEN_EQUAL (REC5); 112 FUNCTION REC6_EQUAL IS NEW GEN_EQUAL (REC6); 113 114 FUNCTION INIT (I : INTEGER) RETURN PRIV1 IS 115 VAR : PRIV1; 116 BEGIN 117 VAR := (D => I); 118 RETURN VAR; 119 END INIT; 120 BEGIN 121 TEST ("C43004C", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & 122 "IF THE VALUE OF A DISCRIMINANT OF A " & 123 "CONSTRAINED COMPONENT OF AN AGGREGATE " & 124 "DOES NOT EQUAL THE CORRESPONDING " & 125 "DISCRIMINANT VALUE FOR THECOMPONENT'S " & 126 "SUBTYPE"); 127 128 BEGIN 129 VV := (E => (D => 1)); 130 FAILED ("CONSTRAINT_ERROR NOT RAISED - 1"); 131 IF REC4_EQUAL (VV,VV) THEN 132 COMMENT ("DON'T OPTIMIZE VV"); 133 END IF; 134 EXCEPTION 135 WHEN CONSTRAINT_ERROR => 136 NULL; 137 WHEN OTHERS => 138 FAILED ("OTHER EXCEPTION RAISED - 1"); 139 END; 140 141 BEGIN 142 WW := (F => (DD => 1)); 143 FAILED ("CONSTRAINT_ERROR NOT RAISED - 2"); 144 IF REC5_EQUAL (WW,WW) THEN 145 COMMENT ("DON'T OPTIMIZE WW"); 146 END IF; 147 EXCEPTION 148 WHEN CONSTRAINT_ERROR => 149 NULL; 150 WHEN OTHERS => 151 FAILED ("OTHER EXCEPTION RAISED - 2"); 152 END; 153 154 BEGIN 155 XX := (D6 => 1, G => (D => 5)); 156 FAILED ("CONSTRAINT_ERROR NOT RAISED - 3"); 157 IF REC6_EQUAL (XX,XX) THEN 158 COMMENT ("DON'T OPTIMIZE XX"); 159 END IF; 160 EXCEPTION 161 WHEN CONSTRAINT_ERROR => 162 NULL; 163 WHEN OTHERS => 164 FAILED ("OTHER EXCEPTION RAISED - 3"); 165 END; 166 END P; 167 168 USE P; 169 170 FUNCTION REC1_EQUAL IS NEW GEN_EQUAL (REC1); 171 FUNCTION REC2_EQUAL IS NEW GEN_EQUAL (REC2); 172 FUNCTION REC3_EQUAL IS NEW GEN_EQUAL (REC3); 173 FUNCTION REC7_EQUAL IS NEW GEN_EQUAL (REC7); 174 175BEGIN 176 177 BEGIN 178 V := (A => (D => 1, COMP1 => 2)); 179 FAILED ("CONSTRAINT_ERROR NOT RAISED - 4"); 180 IF REC1_EQUAL (V,V) THEN 181 COMMENT ("DON'T OPTIMIZE V"); 182 END IF; 183 EXCEPTION 184 WHEN CONSTRAINT_ERROR => 185 NULL; 186 WHEN OTHERS => 187 FAILED ("OTHER EXCEPTION RAISED - 4"); 188 END; 189 190 BEGIN 191 W := (B => (DD => 1, DCOMP1 => 2)); 192 FAILED ("CONSTRAINT_ERROR NOT RAISED - 5"); 193 IF REC2_EQUAL (W,W) THEN 194 COMMENT ("DON'T OPTIMIZE W"); 195 END IF; 196 EXCEPTION 197 WHEN CONSTRAINT_ERROR => 198 NULL; 199 WHEN OTHERS => 200 FAILED ("OTHER EXCEPTION RAISED - 5"); 201 END; 202 203 BEGIN 204 X := (D3 => 1, C => (D => 5, COMP1 => 2)); 205 FAILED ("CONSTRAINT_ERROR NOT RAISED - 6"); 206 IF REC3_EQUAL (X,X) THEN 207 COMMENT ("DON'T OPTIMIZE X"); 208 END IF; 209 EXCEPTION 210 WHEN CONSTRAINT_ERROR => 211 NULL; 212 WHEN OTHERS => 213 FAILED ("OTHER EXCEPTION RAISED - 6"); 214 END; 215 216 BEGIN 217 Y := (H => INIT (1)); 218 FAILED ("CONSTRAINT_ERROR NOT RAISED - 7"); 219 IF REC7_EQUAL (Y,Y) THEN 220 COMMENT ("DON'T OPTIMIZE Y"); 221 END IF; 222 EXCEPTION 223 WHEN CONSTRAINT_ERROR => 224 NULL; 225 WHEN OTHERS => 226 FAILED ("OTHER EXCEPTION RAISED - 7"); 227 END; 228 229 RESULT; 230END C43004C; 231