1-- C48008A.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-- FOR ALLOCATORS OF THE FORM "NEW T X", CHECK THAT CONSTRAINT_ERROR IS 26-- RAISED IF T IS AN UNCONSTRAINED RECORD, PRIVATE, OR LIMITED TYPE, X 27-- IS A DISCRIMINANT CONSTRAINT, AND 28-- 1) ONE OF THE VALUES OF X IS OUTSIDE THE RANGE OF THE CORRESPONDING 29-- DISCRIMINANT; 30-- 2) ONE OF THE DISCRIMINANT VALUES IS NOT COMPATIBLE WITH A 31-- CONSTRAINT OF A SUBCOMPONENT IN WHICH IT IS USED; 32-- 3) ONE OF THE DISCRIMINANT VALUES DOES NOT EQUAL THE CORRESPONDING 33-- VALUE OF THE ALLOCATOR'S BASE TYPE; 34-- 4) A DEFAULT INITIALIZATION RAISES AN EXCEPTION. 35 36-- RM 01/08/80 37-- NL 10/13/81 38-- SPS 10/26/82 39-- JBG 03/02/83 40-- EG 07/05/84 41-- PWB 02/05/86 CORRECTED TEST ERROR: 42-- CHANGED "FAILED" TO "COMMENT" IN PROCEDURE INCR_CHECK, 43-- SO AS NOT TO PROHIBIT EVAL OF DEFLT EXPR (AI-00397/01) 44-- ADDED COMMENTS FOR CASES. 45 46WITH REPORT; 47 48PROCEDURE C48008A IS 49 50 USE REPORT; 51 52BEGIN 53 54 TEST( "C48008A" , "FOR ALLOCATORS OF THE FORM 'NEW T X', " & 55 "CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN " & 56 "APPROPRIATE - UNCONSTRAINED RECORD AND " & 57 "PRIVATE TYPES"); 58 59 DECLARE 60 61 DISC_FLAG : BOOLEAN := FALSE; 62 INCR_VAL : INTEGER; 63 FUNCTION INCR(A : INTEGER) RETURN INTEGER; 64 65 SUBTYPE I1_7 IS INTEGER RANGE IDENT_INT(1)..IDENT_INT(7); 66 SUBTYPE I1_10 IS INTEGER RANGE IDENT_INT(1)..IDENT_INT(10); 67 SUBTYPE I2_9 IS INTEGER RANGE IDENT_INT(2)..IDENT_INT(9); 68 69 TYPE REC (A : I2_9) IS 70 RECORD 71 B : INTEGER := INCR(2); 72 END RECORD; 73 74 TYPE ARR IS ARRAY (I2_9 RANGE <>) OF INTEGER; 75 76 TYPE T_REC (C : I1_10) IS 77 RECORD 78 D : REC(C); 79 END RECORD; 80 81 TYPE T_ARR (C : I1_10) IS 82 RECORD 83 D : ARR(2..C); 84 E : ARR(C..9); 85 END RECORD; 86 87 TYPE T_REC_REC (A : I1_10) IS 88 RECORD 89 B : T_REC(A); 90 END RECORD; 91 92 TYPE T_REC_ARR (A : I1_10) IS 93 RECORD 94 B : T_ARR(A); 95 END RECORD; 96 97 TYPE TB ( A : I1_7 ) IS 98 RECORD 99 R : INTEGER := INCR(1); 100 END RECORD; 101 102 TYPE UR (A : INTEGER) IS 103 RECORD 104 B : I2_9 := INCR(1); 105 END RECORD; 106 107 TYPE A_T_REC_REC IS ACCESS T_REC_REC; 108 TYPE A_T_REC_ARR IS ACCESS T_REC_ARR; 109 TYPE ATB IS ACCESS TB; 110 TYPE ACTB IS ACCESS TB(3); 111 TYPE A_UR IS ACCESS UR; 112 113 VA_T_REC_REC : A_T_REC_REC; 114 VA_T_REC_ARR : A_T_REC_ARR; 115 VB : ATB; 116 VCB : ACTB; 117 V_A_UR : A_UR; 118 119 BOOL : BOOLEAN; 120 121 FUNCTION DISC (A : INTEGER) RETURN INTEGER; 122 123 124 PACKAGE P IS 125 TYPE PRIV( A : I1_10 := DISC(8) ) IS PRIVATE; 126 CONS_PRIV : CONSTANT PRIV; 127 PRIVATE 128 TYPE PRIV( A : I1_10 := DISC(8) ) IS 129 RECORD 130 R : INTEGER := INCR(1); 131 END RECORD; 132 CONS_PRIV : CONSTANT PRIV := (2, 3); 133 END P; 134 135 TYPE A_PRIV IS ACCESS P.PRIV; 136 TYPE A_CPRIV IS ACCESS P.PRIV (3); 137 138 VP : A_PRIV; 139 VCP : A_CPRIV; 140 141 PROCEDURE PREC_REC (X : A_T_REC_REC) IS 142 BEGIN 143 NULL; 144 END PREC_REC; 145 146 PROCEDURE PREC_ARR (X : A_T_REC_ARR) IS 147 BEGIN 148 NULL; 149 END PREC_ARR; 150 151 PROCEDURE PB (X : ATB) IS 152 BEGIN 153 NULL; 154 END PB; 155 156 PROCEDURE PCB (X : ACTB) IS 157 BEGIN 158 NULL; 159 END PCB; 160 161 PROCEDURE PPRIV (X : A_PRIV) IS 162 BEGIN 163 NULL; 164 END PPRIV; 165 166 PROCEDURE PCPRIV (X : A_CPRIV) IS 167 BEGIN 168 NULL; 169 END PCPRIV; 170 171 FUNCTION DISC (A : INTEGER) RETURN INTEGER IS 172 BEGIN 173 DISC_FLAG := TRUE; 174 RETURN A; 175 END DISC; 176 177 FUNCTION INCR(A : INTEGER) RETURN INTEGER IS 178 BEGIN 179 INCR_VAL := IDENT_INT(INCR_VAL+1); 180 RETURN A; 181 END INCR; 182 183 PROCEDURE INCR_CHECK(CASE_ID : STRING) IS 184 BEGIN 185 IF INCR_VAL /= IDENT_INT(0) THEN 186 COMMENT ("DEFAULT INITIAL VALUE WAS EVALUATED - " & 187 "CASE " & CASE_ID); 188 END IF; 189 END INCR_CHECK; 190 191 BEGIN 192 193 BEGIN -- A1A: 0 ILLEGAL FOR TB.A. 194 INCR_VAL := 0; 195 VB := NEW TB (A => 0); 196 FAILED ("NO EXCEPTION RAISED - CASE A1A"); 197 EXCEPTION 198 WHEN CONSTRAINT_ERROR => 199 INCR_CHECK("A1A"); 200 WHEN OTHERS => 201 FAILED( "WRONG EXCEPTION RAISED - CASE A1A" ); 202 END; -- A1A 203 204 BEGIN -- A1B: 8 ILLEGAL IN I1_7. 205 INCR_VAL := 0; 206 VB := NEW TB (A => I1_7'(IDENT_INT(8))); 207 FAILED ("NO EXCEPTION RAISED - CASE A1B"); 208 EXCEPTION 209 WHEN CONSTRAINT_ERROR => 210 INCR_CHECK("A1B"); 211 WHEN OTHERS => 212 FAILED( "WRONG EXCEPTION RAISED - CASE A1B"); 213 END; -- A1B 214 215 BEGIN -- A1C: 8 ILLEGAL FOR TB.A. 216 INCR_VAL := 0; 217 PB(NEW TB (A => 8)); 218 FAILED ("NO EXCEPTION RAISED - CASE A1C"); 219 EXCEPTION 220 WHEN CONSTRAINT_ERROR => 221 INCR_CHECK("A1C"); 222 WHEN OTHERS => 223 FAILED( "WRONG EXCEPTION RAISED - CASE A1C"); 224 END; --A1C 225 226 BEGIN --A1D: 0 ILLEGAL FOR TB.A. 227 INCR_VAL := 0; 228 BOOL := ATB'(NEW TB(A => 0)) = NULL; 229 FAILED ("NO EXCEPTION RAISED - CASE A1D"); 230 EXCEPTION 231 WHEN CONSTRAINT_ERROR => 232 INCR_CHECK("A1D"); 233 WHEN OTHERS => 234 FAILED( "WRONG EXCEPTION RAISED - CASE A1D"); 235 END; --A1D 236 237 BEGIN --A1E: 11 ILLEGAL FOR PRIV.A. 238 DISC_FLAG := FALSE; 239 INCR_VAL := 0; 240 VP := NEW P.PRIV(11); 241 FAILED("NO EXCEPTION RAISED - CASE A1E"); 242 EXCEPTION 243 WHEN CONSTRAINT_ERROR => 244 IF DISC_FLAG THEN 245 FAILED ("DISCR DEFAULT EVALUATED WHEN " & 246 "EXPLICIT VALUE WAS PROVIDED - A1E"); 247 END IF; 248 INCR_CHECK("A1E"); 249 WHEN OTHERS => 250 FAILED("WRONG EXCEPTION RAISED - CASE A1E"); 251 END; -- A1E 252 253 BEGIN -- A2A: 1 ILLEGAL FOR REC.A. 254 INCR_VAL := 0; 255 VA_T_REC_REC := NEW T_REC_REC(A => I1_10'(IDENT_INT(1))); 256 FAILED ("NO EXCEPTION RAISED - CASE A2A"); 257 EXCEPTION 258 WHEN CONSTRAINT_ERROR => 259 INCR_CHECK("A2A"); 260 WHEN OTHERS => 261 FAILED ("WRONG EXCEPTION RAISED - CASE A2A"); 262 END; -- A2A 263 264 BEGIN --A2B: 10 ILLEGAL FOR REC.A. 265 INCR_VAL := 0; 266 VA_T_REC_REC := NEW T_REC_REC (10); 267 FAILED ("NO EXCEPTION RAISED - CASE A2B"); 268 EXCEPTION 269 WHEN CONSTRAINT_ERROR => 270 INCR_CHECK("A2B"); 271 WHEN OTHERS => 272 FAILED ("WRONG EXCEPTION RAISED - CASE A2B"); 273 END; -- A2B 274 275 BEGIN -- A2C: 1 ILLEGAL FOR T.ARR.E'FIRST. 276 INCR_VAL := 0; 277 PREC_ARR (NEW T_REC_ARR (1)); 278 FAILED ("NO EXCEPTION RAISED - CASE A2C"); 279 EXCEPTION 280 WHEN CONSTRAINT_ERROR => 281 INCR_CHECK ("A2C"); 282 WHEN OTHERS => 283 FAILED ("WRONG EXCEPTION RAISED - CASE A2C"); 284 END; -- A2C 285 286 BEGIN -- A2D: 10 ILLEGAL FOR T_ARR.D'LAST. 287 INCR_VAL := 0; 288 BOOL := NEW T_REC_ARR (IDENT_INT(10)) = NULL; 289 FAILED ("NO EXCEPTION RAISED - CASE A2D"); 290 EXCEPTION 291 WHEN CONSTRAINT_ERROR => 292 INCR_CHECK ("A2D"); 293 WHEN OTHERS => 294 FAILED ("WRONG EXCEPTION RAISED - CASE A2D"); 295 END; -- A2D 296 297 BEGIN -- A3A: ASSIGNMENT VIOLATES CONSTRAINT ON VCB'S SUBTYPE. 298 INCR_VAL := 0; 299 VCB := NEW TB (4); 300 FAILED ("NO EXCEPTION RAISED - CASE A3A"); 301 EXCEPTION 302 WHEN CONSTRAINT_ERROR => 303 INCR_CHECK("A3A"); 304 WHEN OTHERS => 305 FAILED ("WRONG EXCEPTION RAISED - CASE A3A"); 306 END; -- A3A 307 308 BEGIN -- A3B: PARM ASSOC VIOLATES CONSTRAINT ON PARM SUBTYPE. 309 INCR_VAL := 0; 310 PCB (NEW TB (4)); 311 FAILED ("NO EXCEPTION RAISED - CASE A3B"); 312 EXCEPTION 313 WHEN CONSTRAINT_ERROR => 314 INCR_CHECK("A3B"); 315 WHEN OTHERS => 316 FAILED ("WRONG EXCEPTION RAISED - CASE A3B"); 317 END; -- A3B 318 319 BEGIN -- A3C: 2 VIOLATES CONSTRAINT ON SUBTYPE ACTB. 320 INCR_VAL := 0; 321 BOOL := ACTB'(NEW TB (IDENT_INT(2))) = NULL; 322 FAILED ("NO EXCEPTION RAISED - CASE A3C"); 323 EXCEPTION 324 WHEN CONSTRAINT_ERROR => 325 INCR_CHECK("A3C"); 326 WHEN OTHERS => 327 FAILED ("WRONG EXCEPTION RAISED - CASE A3C"); 328 END; -- A3C 329 330 BEGIN -- A4A: EVALUATION OF DEFAULT RAISES EXCEPTION. 331 INCR_VAL := 0; 332 V_A_UR := NEW UR(4); 333 FAILED ("NO EXCEPTION RAISED - CASE A4A"); 334 EXCEPTION 335 WHEN CONSTRAINT_ERROR => 336 NULL; 337 WHEN OTHERS => 338 FAILED ("WRONG EXCEPTION RAISED - CASE A4A"); 339 END; -- A4A 340 341 END; 342 343 RESULT; 344 345END C48008A; 346