1-- C43004A.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 A VALUE FOR A 27-- NON-DISCRIMINANT SCALAR COMPONENT OF AN AGGREGATE IS NOT 28-- WITHIN THE RANGE OF THE COMPONENT'S SUBTYPE. 29 30-- HISTORY: 31-- BCB 01/22/88 CREATED ORIGINAL TEST. 32-- RJW 06/27/90 CORRECTED CONSTRAINTS OF TYPE DFIX. 33-- LDC 09/25/90 ADDED A BLOCK IN THE EXCEPTION HANDLER SO IT CAN 34-- NOT OPTIMIZE IT AWAY, ALSO INITIALIZED EACH 35-- OBJECT TO VALID DATA BEFORE DOING THE INVALID, 36-- MADE 'IDENT_XXX' FUNCTIONS SO THE COMPILER CAN 37-- NOT JUST EVALUATE THE ASSIGNMENT AND PUT IN CODE 38-- FOR A CONSTRAINT ERROR IN IS PLACE. 39-- JRL 06/07/96 Changed value in aggregate in subtest 4 to value 40-- guaranteed to be in the base range of the type FIX. 41-- Corrected typo. 42 43WITH REPORT; USE REPORT; 44 45PROCEDURE C43004A IS 46 47 TYPE INT IS RANGE 1 .. 8; 48 SUBTYPE SINT IS INT RANGE 2 .. 7; 49 50 TYPE ENUM IS (VINCE, JOHN, TOM, PHIL, ROSA, JODIE, BRIAN, DAVE); 51 SUBTYPE SENUM IS ENUM RANGE JOHN .. BRIAN; 52 53 TYPE FL IS DIGITS 5 RANGE 0.0 .. 10.0; 54 SUBTYPE SFL IS FL RANGE 1.0 .. 9.0; 55 56 TYPE FIX IS DELTA 0.25 RANGE 0.0 .. 8.0; 57 SUBTYPE SFIX IS FIX RANGE 1.0 .. 7.0; 58 59 TYPE DINT IS NEW INTEGER RANGE 1 .. 8; 60 SUBTYPE SDINT IS DINT RANGE 2 .. 7; 61 62 TYPE DENUM IS NEW ENUM RANGE VINCE .. DAVE; 63 SUBTYPE SDENUM IS DENUM RANGE JOHN .. BRIAN; 64 65 TYPE DFL IS NEW FLOAT RANGE 0.0 .. 10.0; 66 SUBTYPE SDFL IS DFL RANGE 1.0 .. 9.0; 67 68 TYPE DFIX IS NEW FIX RANGE 0.5 .. 7.5; 69 SUBTYPE SDFIX IS DFIX RANGE 1.0 .. 7.0; 70 71 TYPE REC1 IS RECORD 72 E1, E2, E3, E4, E5 : SENUM; 73 END RECORD; 74 75 TYPE REC2 IS RECORD 76 E1, E2, E3, E4, E5 : SFIX; 77 END RECORD; 78 79 TYPE REC3 IS RECORD 80 E1, E2, E3, E4, E5 : SDENUM; 81 END RECORD; 82 83 TYPE REC4 IS RECORD 84 E1, E2, E3, E4, E5 : SDFIX; 85 END RECORD; 86 87 ARRAY_OBJ : ARRAY(1..2) OF INTEGER; 88 89 A : ARRAY(1..5) OF SINT; 90 B : REC1; 91 C : ARRAY(1..5) OF SFL; 92 D : REC2; 93 E : ARRAY(1..5) OF SDINT; 94 F : REC3; 95 G : ARRAY(1..5) OF SDFL; 96 H : REC4; 97 98 GENERIC 99 TYPE GENERAL_PURPOSE IS PRIVATE; 100 FUNCTION GENEQUAL(ONE, TWO : GENERAL_PURPOSE) RETURN BOOLEAN; 101 102 FUNCTION GENEQUAL(ONE, TWO : GENERAL_PURPOSE) RETURN BOOLEAN IS 103 BEGIN 104 IF EQUAL(3,3) THEN 105 RETURN ONE = TWO; 106 ELSE 107 RETURN ONE /= TWO; 108 END IF; 109 END GENEQUAL; 110 111 FUNCTION EQUAL IS NEW GENEQUAL(SENUM); 112 FUNCTION EQUAL IS NEW GENEQUAL(SFL); 113 FUNCTION EQUAL IS NEW GENEQUAL(SFIX); 114 FUNCTION EQUAL IS NEW GENEQUAL(SDENUM); 115 FUNCTION EQUAL IS NEW GENEQUAL(SDFL); 116 FUNCTION EQUAL IS NEW GENEQUAL(SDFIX); 117 118 GENERIC 119 TYPE GENERAL_PURPOSE IS PRIVATE; 120 WITH FUNCTION EQUAL_GENERAL(ONE, TWO : GENERAL_PURPOSE) 121 RETURN BOOLEAN; 122 FUNCTION GEN_IDENT (X : GENERAL_PURPOSE) RETURN GENERAL_PURPOSE; 123 FUNCTION GEN_IDENT (X : GENERAL_PURPOSE) RETURN GENERAL_PURPOSE IS 124 BEGIN 125 IF EQUAL_GENERAL (X, X) THEN -- ALWAYS EQUAL. 126 RETURN X; -- ALWAYS EXECUTED. 127 END IF; 128 -- NEVER EXECUTED. 129 RETURN X; 130 END GEN_IDENT; 131 132 FUNCTION IDENT_FL IS NEW GEN_IDENT(FL, EQUAL); 133 FUNCTION IDENT_FIX IS NEW GEN_IDENT(FIX, EQUAL); 134 FUNCTION IDENT_DFL IS NEW GEN_IDENT(DFL, EQUAL); 135 FUNCTION IDENT_DFIX IS NEW GEN_IDENT(DFIX, EQUAL); 136 137BEGIN 138 TEST ("C43004A", "CHECK THAT CONSTRAINT_ERROR IS RAISED IF A " & 139 "VALUE FOR A NON-DISCRIMINANT SCALAR COMPONENT " & 140 "OF AN AGGREGATE IS NOT WITHIN THE RANGE OF " & 141 "THE COMPONENT'S SUBTYPE"); 142 143 ARRAY_OBJ := (1, 2); 144 145 BEGIN 146 A := (2,3,4,5,6); -- OK 147 148 IF EQUAL (INTEGER (A(IDENT_INT(1))), 149 INTEGER (A(IDENT_INT(2)))) THEN 150 COMMENT ("DON'T OPTIMIZE A"); 151 END IF; 152 153 A := (SINT(IDENT_INT(1)),2,3,4,7); 154 -- CONSTRAINT_ERROR BY AGGREGATE 155 -- WITH INTEGER COMPONENTS. 156 FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 1"); 157 IF EQUAL (INTEGER (A(IDENT_INT(1))), 158 INTEGER (A(IDENT_INT(1)))) THEN 159 COMMENT ("DON'T OPTIMIZE A"); 160 END IF; 161 EXCEPTION 162 WHEN CONSTRAINT_ERROR => 163 IF EQUAL (ARRAY_OBJ(IDENT_INT(1)), 164 ARRAY_OBJ(IDENT_INT(2))) THEN 165 COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER"); 166 END IF; 167 WHEN OTHERS => 168 FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & 169 "WAS RAISED - 1"); 170 END; 171 172 BEGIN 173 B := (JOHN,TOM,PHIL,ROSA,JOHN); -- OK 174 175 IF EQUAL (B.E1, B.E2) THEN 176 COMMENT ("DON'T OPTIMIZE B"); 177 END IF; 178 179 B := (ENUM'VAL(IDENT_INT(ENUM'POS(DAVE))), TOM, PHIL, 180 ROSA, JODIE); 181 -- CONSTRAINT_ERROR BY AGGREGATE 182 -- WITH COMPONENTS OF AN 183 -- ENUMERATION TYPE. 184 FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 2"); 185 IF NOT EQUAL (B.E1, B.E1) THEN 186 COMMENT ("DON'T OPTIMIZE B"); 187 END IF; 188 EXCEPTION 189 WHEN CONSTRAINT_ERROR => 190 IF EQUAL (ARRAY_OBJ(IDENT_INT(1)), 191 ARRAY_OBJ(IDENT_INT(2))) THEN 192 COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER"); 193 END IF; 194 WHEN OTHERS => 195 FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & 196 "WAS RAISED - 2"); 197 END; 198 BEGIN 199 C := (2.0,3.0,4.0,5.0,6.0); -- OK 200 IF EQUAL (C(IDENT_INT(1)), C(IDENT_INT(2))) THEN 201 COMMENT ("DON'T OPTIMIZE C"); 202 END IF; 203 204 C := (IDENT_FL(1.0),2.0,3.0,4.0,IDENT_FL(10.0)); 205 -- CONSTRAINT_ERROR BY AGGREGATE 206 -- WITH FLOATING POINT COMPONENTS. 207 FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 3"); 208 IF NOT EQUAL (C(IDENT_INT(1)), C(IDENT_INT(1))) THEN 209 COMMENT ("DON'T OPTIMIZE C"); 210 END IF; 211 EXCEPTION 212 WHEN CONSTRAINT_ERROR => 213 IF EQUAL (ARRAY_OBJ(IDENT_INT(1)), 214 ARRAY_OBJ(IDENT_INT(2))) THEN 215 COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER"); 216 END IF; 217 WHEN OTHERS => 218 FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & 219 "WAS RAISED - 3"); 220 END; 221 222 BEGIN 223 D := (2.2,3.3,4.4,5.5,6.6); -- OK 224 IF EQUAL (D.E1, D.E5) THEN 225 COMMENT ("DON'T OPTIMIZE D"); 226 END IF; 227 228 D := (IDENT_FIX(1.0),2.1,3.3,4.4,IDENT_FIX(7.75)); 229 -- CONSTRAINT_ERROR BY AGGREGATE 230 -- WITH FIXED POINT COMPONENTS. 231 FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 4"); 232 IF NOT EQUAL (D.E5, D.E5) THEN 233 COMMENT ("DON'T OPTIMIZE D"); 234 END IF; 235 EXCEPTION 236 WHEN CONSTRAINT_ERROR => 237 IF EQUAL (ARRAY_OBJ(IDENT_INT(1)), 238 ARRAY_OBJ(IDENT_INT(2))) THEN 239 COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER"); 240 END IF; 241 WHEN OTHERS => 242 FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & 243 "WAS RAISED - 4"); 244 END; 245 246 BEGIN 247 E := (2,3,4,5,6); -- OK 248 IF EQUAL (INTEGER (E(IDENT_INT(1))), 249 INTEGER (E(IDENT_INT(2)))) THEN 250 COMMENT ("DON'T OPTIMIZE E"); 251 END IF; 252 253 E := (SDINT(IDENT_INT(1)),2,3,4,7); 254 -- CONSTRAINT_ERROR BY AGGREGATE 255 -- WITH DERIVED INTEGER COMPONENTS. 256 FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 5"); 257 IF NOT EQUAL (INTEGER (E(IDENT_INT(1))), 258 INTEGER (E(IDENT_INT(1)))) THEN 259 COMMENT ("DON'T OPTIMIZE E"); 260 END IF; 261 EXCEPTION 262 WHEN CONSTRAINT_ERROR => 263 IF EQUAL (ARRAY_OBJ(IDENT_INT(1)), 264 ARRAY_OBJ(IDENT_INT(2))) THEN 265 COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER"); 266 END IF; 267 WHEN OTHERS => 268 FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & 269 "WAS RAISED - 5"); 270 END; 271 272 BEGIN 273 F := (JOHN,TOM,PHIL,ROSA,JOHN); -- OK 274 IF EQUAL (F.E1, F.E2) THEN 275 COMMENT ("DON'T OPTIMIZE F"); 276 END IF; 277 278 F := (DENUM'VAL(IDENT_INT(DENUM'POS(VINCE))), TOM, PHIL, 279 ROSA, JODIE); 280 -- CONSTRAINT_ERROR BY AGGREGATE 281 -- WITH COMPONENTS OF A DERIVED 282 -- ENUMERATION TYPE. 283 FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 6"); 284 IF NOT EQUAL (F.E1, F.E1) THEN 285 COMMENT ("DON'T OPTIMIZE F"); 286 END IF; 287 EXCEPTION 288 WHEN CONSTRAINT_ERROR => 289 IF EQUAL (ARRAY_OBJ(IDENT_INT(1)), 290 ARRAY_OBJ(IDENT_INT(2))) THEN 291 COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER"); 292 END IF; 293 WHEN OTHERS => 294 FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & 295 "WAS RAISED - 6"); 296 END; 297 298 BEGIN 299 G := (2.0,3.0,4.0,5.0,6.0); -- OK 300 IF EQUAL (G(IDENT_INT(1)), G(IDENT_INT(2))) THEN 301 COMMENT ("DON'T OPTIMIZE G"); 302 END IF; 303 304 G := (IDENT_DFL(1.0),2.0,3.0,4.0,IDENT_DFL(10.0)); 305 -- CONSTRAINT_ERROR BY AGGREGATE 306 -- WITH DERIVED FLOATING POINT 307 -- COMPONENTS. 308 FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 7"); 309 IF NOT EQUAL (G(IDENT_INT(1)), G(IDENT_INT(1))) THEN 310 COMMENT ("DON'T OPTIMIZE G"); 311 END IF; 312 EXCEPTION 313 WHEN CONSTRAINT_ERROR => 314 IF EQUAL (ARRAY_OBJ(IDENT_INT(1)), 315 ARRAY_OBJ(IDENT_INT(2))) THEN 316 COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER"); 317 END IF; 318 WHEN OTHERS => 319 FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & 320 "WAS RAISED - 7"); 321 END; 322 323 BEGIN 324 H := (2.2,3.3,4.4,5.5,6.6); -- OK 325 IF EQUAL (H.E1, H.E2) THEN 326 COMMENT ("DON'T OPTIMIZE H"); 327 END IF; 328 329 H := (IDENT_DFIX(2.0),2.5,3.5,4.3,IDENT_DFIX(7.4)); 330 -- CONSTRAINT_ERROR BY AGGREGATE 331 -- WITH DERIVED FIXED POINT 332 -- COMPONENTS. 333 FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 8"); 334 IF EQUAL (H.E1, H.E5) THEN 335 COMMENT ("DON'T OPTIMIZE H"); 336 END IF; 337 EXCEPTION 338 WHEN CONSTRAINT_ERROR => 339 IF EQUAL (ARRAY_OBJ(IDENT_INT(1)), 340 ARRAY_OBJ(IDENT_INT(2))) THEN 341 COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER"); 342 END IF; 343 WHEN OTHERS => 344 FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & 345 "WAS RAISED - 8"); 346 END; 347 348 349 RESULT; 350END C43004A; 351