1-- C37213H.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, WHERE AN INDEX CONSTRAINT DEPENDS ON A RECORD 27-- DISCRIMINANT WITH A DEFAULT VALUE AND THE RECORD TYPE IS NOT 28-- EXPLICITLY CONSTRAINED, THAT THE NON-DISCRIMINANT EXPRESSIONS 29-- IN THE INDEX CONSTRAINT ARE: 30-- 1) EVALUATED WHEN THE RECORD COMPONENT SUBTYPE DEFINITION 31-- IS ELABORATED, 32-- 2) PROPERLY CHECKED FOR COMPATIBILITY ONLY IN AN ALLOCATION 33-- OR OBJECT DECLARATION AND ONLY IF THE DISCRIMINANT- 34-- DEPENDENT COMPONENT IS PRESENT IN THE SUBTYPE. 35 36-- HISTORY: 37-- JBG 10/17/86 CREATED ORIGINAL TEST. 38-- VCL 10/23/87 MODIFIED THIS HEADER; MODIFIED THE CHECK OF 39-- SUBTYPE 'SCONS', IN BOTH SUBPARTS OF THE TEST, 40-- TO INDICATE FAILURE IF CONSTRAINT_ERROR IS RAISED 41-- FOR THE SUBTYPE DECLARATION AND FAILURE IF 42-- CONSTRAINT_ERROR IS NOT RAISED FOR AN OBJECT 43-- DECLARATION OF THIS SUBTYPE; RELOCATED THE CALL TO 44-- REPORT.TEST SO THAT IT COMES BEFORE ANY 45-- DECLARATIONS; ADDED 'SEQUENCE_NUMBER' TO IDENTIFY 46-- THE CURRENT SUBTEST (FOR EXCEPTIONS); CHANGE THE 47-- TYPE OF THE DISCRIMINANT IN THE RECORD 'CONS' 48-- TO AN INTEGER SUBTYPE. 49-- VCL 03/30/88 MODIFIED HEADER AND MESSAGES OUTPUT BY REPORT 50-- PACKAGE. 51 52WITH REPORT; USE REPORT; 53PROCEDURE C37213H IS 54BEGIN 55 TEST ("C37213H", "THE NON-DISCRIMINANT EXPRESSIONS OF AN " & 56 "INDEX CONSTRAINT THAT DEPEND ON A " & 57 "DISCRIMINANT WITH A DEFAULT VALUE ARE " & 58 "PROPERLY EVALUATED AND CHECKED WHEN THE " & 59 "RECORD TYPE IS NOT EXPLICITLY CONSTRAINED AND " & 60 "THE COMPONENT IS AND IS NOT PRESENT IN THE " & 61 "SUBTYPE"); 62 63 DECLARE 64 SEQUENCE_NUMBER : INTEGER; 65 66 SUBTYPE DISCR IS INTEGER RANGE -50..50; 67 SUBTYPE SM IS INTEGER RANGE 1..10; 68 TYPE MY_ARR IS ARRAY (SM RANGE <>) OF INTEGER; 69 70 F1_CONS : INTEGER := 2; 71 72 FUNCTION CHK ( 73 CONS : INTEGER; 74 VALUE : INTEGER; 75 MESSAGE : STRING) RETURN BOOLEAN IS 76 BEGIN 77 IF CONS /= VALUE THEN 78 FAILED (MESSAGE & ": F1_CONS IS " & 79 INTEGER'IMAGE(F1_CONS)); 80 END IF; 81 RETURN TRUE; 82 END CHK; 83 84 FUNCTION F1 RETURN INTEGER IS 85 BEGIN 86 F1_CONS := F1_CONS - IDENT_INT(1); 87 RETURN F1_CONS; 88 END F1; 89 BEGIN 90 91 92-- CASE 1: DISCRIMINANT-DEPENDENT COMPONENT IS PRESENT. 93 94 SEQUENCE_NUMBER :=1; 95 DECLARE 96 TYPE CONS (D3 : DISCR := IDENT_INT(1)) IS 97 RECORD 98 CASE D3 IS 99 WHEN -5..10 => 100 C1 : MY_ARR(F1..D3); -- F1 EVALUATED. 101 WHEN OTHERS => 102 C2 : INTEGER := IDENT_INT(0); 103 END CASE; 104 END RECORD; 105 106 CHK1 : BOOLEAN := CHK (F1_CONS, 1, "F1 NOT EVALUATED"); 107 108 X : CONS; -- F1 NOT EVALUATED AGAIN. 109 Y : CONS; -- F1 NOT EVALUATED AGAIN. 110 111 CHK2 : BOOLEAN := CHK (F1_CONS, 1, "F1 EVALUATED"); 112 BEGIN 113 IF X.C1'FIRST /= 1 OR Y.C1'LAST /= 1 THEN 114 FAILED ("VALUES NOT CORRECT"); 115 END IF; 116 END; 117 118 119 F1_CONS := 12; 120 121 SEQUENCE_NUMBER := 2; 122 DECLARE 123 TYPE CONS (D3 : DISCR := IDENT_INT(1)) IS 124 RECORD 125 CASE D3 IS 126 WHEN -5..10 => 127 C1 : MY_ARR(D3..F1); 128 WHEN OTHERS => 129 C2 : INTEGER := IDENT_INT(0); 130 END CASE; 131 END RECORD; 132 BEGIN 133 BEGIN 134 DECLARE 135 X : CONS; 136 BEGIN 137 FAILED ("INDEX CHECK NOT PERFORMED - 1"); 138 IF X /= (1, (1, 1)) THEN 139 COMMENT ("INCORRECT VALUES FOR X - 1"); 140 END IF; 141 END; 142 EXCEPTION 143 WHEN CONSTRAINT_ERROR => 144 NULL; 145 WHEN OTHERS => 146 FAILED ("UNEXPECTED EXCEPTION RAISED - 1"); 147 END; 148 149 BEGIN 150 DECLARE 151 SUBTYPE SCONS IS CONS; 152 BEGIN 153 DECLARE 154 X : SCONS; 155 BEGIN 156 FAILED ("INDEX CHECK NOT PERFORMED - 2"); 157 IF X /= (1, (1, 1)) THEN 158 COMMENT ("INCORRECT VALUES FOR X " & 159 "- 2"); 160 END IF; 161 END; 162 EXCEPTION 163 WHEN CONSTRAINT_ERROR => 164 NULL; 165 WHEN OTHERS => 166 FAILED ("UNEXPECTED EXCEPTION RAISED " & 167 "- 2A"); 168 END; 169 EXCEPTION 170 WHEN OTHERS => 171 FAILED ("UNEXPECTED EXCEPTION RAISED - 2B"); 172 END; 173 174 BEGIN 175 DECLARE 176 TYPE ARR IS ARRAY (1..5) OF CONS; 177 BEGIN 178 DECLARE 179 X : ARR; 180 BEGIN 181 FAILED ("INDEX CHECK NOT PERFORMED - 3"); 182 IF X /= (1..5 => (1, (1, 1))) THEN 183 COMMENT ("INCORRECT VALUES FOR X " & 184 "- 3"); 185 END IF; 186 END; 187 EXCEPTION 188 WHEN CONSTRAINT_ERROR => 189 NULL; 190 WHEN OTHERS => 191 FAILED ("UNEXPECTED EXCEPTION RAISED " & 192 "- 3A"); 193 END; 194 EXCEPTION 195 WHEN OTHERS => 196 FAILED ("UNEXPECTED EXCEPTION RAISED - 3B"); 197 END; 198 199 BEGIN 200 DECLARE 201 TYPE NREC IS 202 RECORD 203 C1 : CONS; 204 END RECORD; 205 BEGIN 206 DECLARE 207 X : NREC; 208 BEGIN 209 FAILED ("INDEX CHECK NOT PERFORMED - 4"); 210 IF X /= (C1 => (1, (1, 1))) THEN 211 COMMENT ("INCORRECT VALUES FOR X " & 212 "- 4"); 213 END IF; 214 END; 215 EXCEPTION 216 WHEN CONSTRAINT_ERROR => 217 NULL; 218 WHEN OTHERS => 219 FAILED ("UNEXPECTED EXCEPTION RAISED " & 220 "- 4A"); 221 END; 222 EXCEPTION 223 WHEN OTHERS => 224 FAILED ("UNEXPECTED EXCEPTION RAISED - 4B"); 225 END; 226 227 BEGIN 228 DECLARE 229 TYPE NREC IS NEW CONS; 230 BEGIN 231 DECLARE 232 X : NREC; 233 BEGIN 234 FAILED ("INDEX CHECK NOT PERFORMED - 5"); 235 IF X /= (1, (1, 1)) THEN 236 COMMENT ("INCORRECT VALUES FOR X " & 237 "- 5"); 238 END IF; 239 END; 240 EXCEPTION 241 WHEN CONSTRAINT_ERROR => 242 NULL; 243 WHEN OTHERS => 244 FAILED ("UNEXPECTED EXCEPTION RAISED " & 245 "- 5A"); 246 END; 247 EXCEPTION 248 WHEN OTHERS => 249 FAILED ("UNEXPECTED EXCEPTION RAISED - 5B"); 250 END; 251 252 BEGIN 253 DECLARE 254 TYPE ACC_CONS IS ACCESS CONS; 255 BEGIN 256 DECLARE 257 X : ACC_CONS; 258 BEGIN 259 X := NEW CONS; 260 FAILED ("INDEX CHECK NOT PERFORMED - 6"); 261 IF X.ALL /= (1, (1, 1)) THEN 262 COMMENT ("INCORRECT VALUES FOR X " & 263 "- 6"); 264 END IF; 265 EXCEPTION 266 WHEN CONSTRAINT_ERROR => 267 NULL; 268 WHEN OTHERS => 269 COMMENT ("UNEXPECTED EXCEPTION " & 270 "RAISED - 6A"); 271 END; 272 EXCEPTION 273 WHEN OTHERS => 274 COMMENT ("UNEXPECTED EXCEPTION RAISED " & 275 "- 6B"); 276 END; 277 EXCEPTION 278 WHEN OTHERS => 279 FAILED ("UNEXPECTED EXCEPTION RAISED - 6C"); 280 END; 281 END; 282 283 284-- CASE D2: DISCRIMINANT-DEPENDENT COMPONENT IS ABSENT. 285 286 F1_CONS := 2; 287 288 SEQUENCE_NUMBER := 3; 289 DECLARE 290 TYPE CONS (D3 : DISCR := IDENT_INT(-6)) IS 291 RECORD 292 CASE D3 IS 293 WHEN -5..10 => 294 C1 : MY_ARR(D3..F1); -- F1 EVALUATED. 295 WHEN OTHERS => 296 C2 : INTEGER := IDENT_INT(0); 297 END CASE; 298 END RECORD; 299 CHK1 : BOOLEAN := CHK (F1_CONS, 1, "F1 NOT EVALUATED"); 300 301 X : CONS; -- F1 NOT EVALUATED AGAIN. 302 Y : CONS; -- F1 NOT EVALUATED AGAIN. 303 304 CHK2 : BOOLEAN := CHK (F1_CONS, 1, "F1 EVALUATED"); 305 BEGIN 306 IF X /= (-6, 0) OR Y /= (-6, 0) THEN 307 FAILED ("VALUES NOT CORRECT"); 308 END IF; 309 END; 310 311 F1_CONS := 12; 312 313 SEQUENCE_NUMBER := 4; 314 DECLARE 315 TYPE CONS (D3 : DISCR := IDENT_INT(11)) IS 316 RECORD 317 CASE D3 IS 318 WHEN -5..10 => 319 C1 : MY_ARR(D3..F1); 320 WHEN OTHERS => 321 C2 : INTEGER := IDENT_INT(0); 322 END CASE; 323 END RECORD; 324 BEGIN 325 BEGIN 326 DECLARE 327 X : CONS; 328 BEGIN 329 IF X /= (11, 0) THEN 330 FAILED ("X VALUE IS INCORRECT - 11"); 331 END IF; 332 END; 333 EXCEPTION 334 WHEN OTHERS => 335 FAILED ("UNEXPECTED EXCEPTION RAISED - 11"); 336 END; 337 338 BEGIN 339 DECLARE 340 SUBTYPE SCONS IS CONS; 341 BEGIN 342 DECLARE 343 X : SCONS; 344 BEGIN 345 IF X /= (11, 0) THEN 346 FAILED ("X VALUE INCORRECT - 12"); 347 END IF; 348 END; 349 EXCEPTION 350 WHEN OTHERS => 351 FAILED ("UNEXPECTED EXCEPTION RAISED - " & 352 "12A"); 353 END; 354 EXCEPTION 355 WHEN OTHERS => 356 FAILED ("UNEXPECTED EXCEPTION RAISED - 12B"); 357 END; 358 359 BEGIN 360 DECLARE 361 TYPE ARR IS ARRAY (1..5) OF CONS; 362 BEGIN 363 DECLARE 364 X : ARR; 365 BEGIN 366 IF X /= (1..5 => (11, 0)) THEN 367 FAILED ("X VALUE INCORRECT - 13"); 368 END IF; 369 END; 370 EXCEPTION 371 WHEN OTHERS => 372 FAILED ("UNEXPECTED EXCEPTION RAISED - " & 373 "13A"); 374 END; 375 EXCEPTION 376 WHEN OTHERS => 377 FAILED ("UNEXPECTED EXCEPTION RAISED - 13B"); 378 END; 379 380 BEGIN 381 DECLARE 382 TYPE NREC IS 383 RECORD 384 C1 : CONS; 385 END RECORD; 386 BEGIN 387 DECLARE 388 X : NREC; 389 BEGIN 390 IF X /= (C1 => (11, 0)) THEN 391 FAILED ("X VALUE INCORRECT - 14"); 392 END IF; 393 END; 394 EXCEPTION 395 WHEN OTHERS => 396 FAILED ("UNEXPECTED EXCEPTION RAISED - " & 397 "14A"); 398 END; 399 EXCEPTION 400 WHEN OTHERS => 401 FAILED ("UNEXPECTED EXCEPTION RAISED - 14B"); 402 END; 403 404 BEGIN 405 DECLARE 406 TYPE NREC IS NEW CONS; 407 BEGIN 408 DECLARE 409 X : NREC; 410 BEGIN 411 IF X /= (11, 0) THEN 412 FAILED ("X VALUE INCORRECT - 15"); 413 END IF; 414 END; 415 EXCEPTION 416 WHEN CONSTRAINT_ERROR => 417 NULL; 418 WHEN OTHERS => 419 FAILED ("UNEXPECTED EXCEPTION RAISED - " & 420 "15A"); 421 END; 422 EXCEPTION 423 WHEN OTHERS => 424 FAILED ("UNEXPECTED EXCEPTION RAISED - 15B"); 425 END; 426 427 BEGIN 428 DECLARE 429 TYPE ACC_CONS IS ACCESS CONS; 430 X : ACC_CONS; 431 BEGIN 432 X := NEW CONS; 433 IF X.ALL /= (11, 0) THEN 434 FAILED ("X VALUE INCORRECT - 17"); 435 END IF; 436 EXCEPTION 437 WHEN OTHERS => 438 FAILED ("UNEXPECTED EXCEPTION RAISED - " & 439 "17A"); 440 END; 441 EXCEPTION 442 WHEN OTHERS => 443 FAILED ("UNEXPECTED EXCEPTION RAISED - 17B"); 444 END; 445 END; 446 447 EXCEPTION 448 WHEN CONSTRAINT_ERROR => 449 FAILED ("INDEX VALUES IMPROPERLY CHECKED - " & 450 INTEGER'IMAGE (SEQUENCE_NUMBER)); 451 WHEN OTHERS => 452 FAILED ("UNEXPECTED EXCEPTION RAISED " & 453 INTEGER'IMAGE (SEQUENCE_NUMBER)); 454 END; 455 456 RESULT; 457END C37213H; 458