1-- C37211B.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-- CHECK THAT CONSTRAINT_ERROR IS RAISED BY A DISCRIMINANT CONSTRAINT 26-- IF A VALUE SPECIFIED FOR A DISCRIMINANT DOES NOT LIE IN THE RANGE 27-- OF THE DISCRIMINANT. THIS TEST CONTAINS CHECKS FOR SUBTYPE 28-- INDICATIONS WHERE THE TYPE MARK DENOTES A PRIVATE OR LIMITED 29-- PRIVATE TYPE, AND THE DISCRIMINANT CONSTRAINT OCCURS AFTER THE FULL 30-- DECLARATION OF THE TYPE. 31 32-- R.WILLIAMS 8/28/86 33-- EDS 7/14/98 AVOID OPTIMIZATION 34 35WITH REPORT; USE REPORT; 36PROCEDURE C37211B IS 37 38 SUBTYPE LIES IS BOOLEAN RANGE FALSE .. FALSE; 39 40 PACKAGE PKG IS 41 TYPE PRIV (L : LIES) IS PRIVATE; 42 TYPE LIM (L : LIES) IS LIMITED PRIVATE; 43 44 PRIVATE 45 TYPE PRIV (L : LIES) IS 46 RECORD 47 NULL; 48 END RECORD; 49 50 TYPE LIM (L : LIES) IS 51 RECORD 52 NULL; 53 END RECORD; 54 END PKG; 55 56 USE PKG; 57 58BEGIN 59 TEST ( "C37211B", "CHECK THAT CONSTRAINT_ERROR IS RAISED BY " & 60 "A DISCRIMINANT CONSTRAINT IF A VALUE " & 61 "SPECIFIED FOR A DISCRIMINANT DOES NOT LIE " & 62 "IN THE RANGE OF THE DISCRIMINANT WHERE THE " & 63 "TYPE MARK DENOTES A PRIVATE OR LIMITED " & 64 "PRIVATE TYPE, AND THE DISCRIMINANT " & 65 "CONSTRAINT OCCURS AFTER THE FULL " & 66 "DECLARATION OF THE TYPE" ); 67 68 BEGIN 69 DECLARE 70 SUBTYPE SUBPRIV IS PRIV (IDENT_BOOL (TRUE)); 71 BEGIN 72 DECLARE 73 SP : SUBPRIV; 74 BEGIN 75 FAILED ( "NO EXCEPTION RAISED AT THE " & 76 "ELABORATION OF SUBTYPE SUBPRIV " & 77 BOOLEAN'IMAGE(SP.L)); 78 END; 79 EXCEPTION 80 WHEN OTHERS => 81 FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & 82 "OBJECT SP" ); 83 END; 84 85 EXCEPTION 86 WHEN CONSTRAINT_ERROR => 87 NULL; 88 WHEN OTHERS => 89 FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & 90 "SUBTYPE SUBPRIV" ); 91 END; 92 93 BEGIN 94 DECLARE 95 SUBTYPE SUBLIM IS LIM (IDENT_BOOL (TRUE)); 96 BEGIN 97 DECLARE 98 SL : SUBLIM; 99 BEGIN 100 FAILED ( "NO EXCEPTION RAISED AT THE " & 101 "ELABORATION OF SUBTYPE SUBLIM" & 102 BOOLEAN'IMAGE(SL.L)); 103 END; 104 EXCEPTION 105 WHEN OTHERS => 106 FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & 107 "OBJECT SL " ); 108 END; 109 110 EXCEPTION 111 WHEN CONSTRAINT_ERROR => 112 NULL; 113 WHEN OTHERS => 114 FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & 115 "SUBTYPE SUBLIM" ); 116 END; 117 118 BEGIN 119 DECLARE 120 TYPE PARR IS ARRAY (1 .. 5) OF PRIV (IDENT_BOOL (TRUE)); 121 BEGIN 122 DECLARE 123 PAR : PARR; 124 BEGIN 125 FAILED ( "NO EXCEPTION RAISED AT THE " & 126 "ELABORATION OF TYPE PARR " & 127 BOOLEAN'IMAGE(PAR(1).L)); 128 END; 129 EXCEPTION 130 WHEN OTHERS => 131 FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & 132 "OBJECT PAR" ); 133 END; 134 135 EXCEPTION 136 WHEN CONSTRAINT_ERROR => 137 NULL; 138 WHEN OTHERS => 139 FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & 140 "TYPE PARR" ); 141 END; 142 143 BEGIN 144 DECLARE 145 TYPE LARR IS ARRAY (1 .. 10) OF LIM (IDENT_BOOL (TRUE)); 146 BEGIN 147 DECLARE 148 LAR : LARR; 149 BEGIN 150 FAILED ( "NO EXCEPTION RAISED AT THE " & 151 "ELABORATION OF TYPE LARR " & 152 BOOLEAN'IMAGE(LAR(1).L)); 153 END; 154 EXCEPTION 155 WHEN OTHERS => 156 FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & 157 "OBJECT LAR" ); 158 END; 159 160 EXCEPTION 161 WHEN CONSTRAINT_ERROR => 162 NULL; 163 WHEN OTHERS => 164 FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & 165 "TYPE LARR" ); 166 END; 167 168 BEGIN 169 DECLARE 170 TYPE PRIV1 IS 171 RECORD 172 X : PRIV (IDENT_BOOL (TRUE)); 173 END RECORD; 174 175 BEGIN 176 DECLARE 177 P1 : PRIV1; 178 BEGIN 179 FAILED ( "NO EXCEPTION RAISED AT THE " & 180 "ELABORATION OF TYPE PRIV1 " & 181 BOOLEAN'IMAGE(P1.X.L)); 182 END; 183 EXCEPTION 184 WHEN OTHERS => 185 FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & 186 "OBJECT P1" ); 187 END; 188 189 EXCEPTION 190 WHEN CONSTRAINT_ERROR => 191 NULL; 192 WHEN OTHERS => 193 FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & 194 "TYPE PRIV1" ); 195 END; 196 197 BEGIN 198 DECLARE 199 TYPE LIM1 IS 200 RECORD 201 X : LIM (IDENT_BOOL (TRUE)); 202 END RECORD; 203 204 BEGIN 205 DECLARE 206 L1 : LIM1; 207 BEGIN 208 FAILED ( "NO EXCEPTION RAISED AT THE " & 209 "ELABORATION OF TYPE LIM1 " & 210 BOOLEAN'IMAGE(L1.X.L)); 211 END; 212 EXCEPTION 213 WHEN OTHERS => 214 FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & 215 "OBJECT L1" ); 216 END; 217 218 EXCEPTION 219 WHEN CONSTRAINT_ERROR => 220 NULL; 221 WHEN OTHERS => 222 FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & 223 "TYPE LIM1" ); 224 END; 225 226 BEGIN 227 DECLARE 228 TYPE ACCPRIV IS ACCESS PRIV (IDENT_BOOL (TRUE)); 229 BEGIN 230 DECLARE 231 ACP : ACCPRIV; 232 BEGIN 233 FAILED ( "NO EXCEPTION RAISED AT THE " & 234 "ELABORATION OF TYPE ACCPRIV " & 235 BOOLEAN'IMAGE(ACP.L)); 236 END; 237 EXCEPTION 238 WHEN OTHERS => 239 FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & 240 "OBJECT ACP" ); 241 END; 242 243 EXCEPTION 244 WHEN CONSTRAINT_ERROR => 245 NULL; 246 WHEN OTHERS => 247 FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & 248 "TYPE ACCPRIV" ); 249 END; 250 251 BEGIN 252 DECLARE 253 TYPE ACCLIM IS ACCESS LIM (IDENT_BOOL (TRUE)); 254 BEGIN 255 DECLARE 256 ACL : ACCLIM; 257 BEGIN 258 FAILED ( "NO EXCEPTION RAISED AT THE " & 259 "ELABORATION OF TYPE ACCLIM " & 260 BOOLEAN'IMAGE(ACL.L)); 261 END; 262 EXCEPTION 263 WHEN OTHERS => 264 FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & 265 "OBJECT ACL" ); 266 END; 267 268 EXCEPTION 269 WHEN CONSTRAINT_ERROR => 270 NULL; 271 WHEN OTHERS => 272 FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & 273 "TYPE ACCLIM" ); 274 END; 275 276 BEGIN 277 DECLARE 278 TYPE NEWPRIV IS NEW PRIV (IDENT_BOOL (TRUE)); 279 BEGIN 280 DECLARE 281 NP : NEWPRIV; 282 BEGIN 283 FAILED ( "NO EXCEPTION RAISED AT THE " & 284 "ELABORATION OF TYPE NEWPRIV " & 285 BOOLEAN'IMAGE(NP.L)); 286 END; 287 EXCEPTION 288 WHEN OTHERS => 289 FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & 290 "OBJECT NP" ); 291 END; 292 293 EXCEPTION 294 WHEN CONSTRAINT_ERROR => 295 NULL; 296 WHEN OTHERS => 297 FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & 298 "TYPE NEWPRIV" ); 299 END; 300 301 BEGIN 302 DECLARE 303 TYPE NEWLIM IS NEW LIM (IDENT_BOOL (TRUE)); 304 BEGIN 305 DECLARE 306 NL : NEWLIM; 307 BEGIN 308 FAILED ( "NO EXCEPTION RAISED AT THE " & 309 "ELABORATION OF TYPE NEWLIM " & 310 BOOLEAN'IMAGE(NL.L)); 311 END; 312 EXCEPTION 313 WHEN OTHERS => 314 FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & 315 "OBJECT NL" ); 316 END; 317 318 EXCEPTION 319 WHEN CONSTRAINT_ERROR => 320 NULL; 321 WHEN OTHERS => 322 FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & 323 "TYPE NEWLIM" ); 324 END; 325 326 BEGIN 327 DECLARE 328 P : PRIV (IDENT_BOOL (TRUE)); 329 BEGIN 330 FAILED ( "NO EXCEPTION RAISED AT THE DECLARATION OF " & 331 "P " & BOOLEAN'IMAGE(P.L)); 332 EXCEPTION 333 WHEN OTHERS => 334 FAILED ( "EXCEPTION RAISED INSIDE BLOCK " & 335 "CONTAINING P" ); 336 END; 337 338 EXCEPTION 339 WHEN CONSTRAINT_ERROR => 340 NULL; 341 WHEN OTHERS => 342 FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION OF " & 343 "P" ); 344 END; 345 346 BEGIN 347 DECLARE 348 L : LIM (IDENT_BOOL (TRUE)); 349 BEGIN 350 FAILED ( "NO EXCEPTION RAISED AT THE DECLARATION OF " & 351 "L " & BOOLEAN'IMAGE(L.L)); 352 EXCEPTION 353 WHEN OTHERS => 354 FAILED ( "EXCEPTION RAISED INSIDE BLOCK " & 355 "CONTAINING L" ); 356 END; 357 358 EXCEPTION 359 WHEN CONSTRAINT_ERROR => 360 NULL; 361 WHEN OTHERS => 362 FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION OF " & 363 "L" ); 364 END; 365 366 BEGIN 367 DECLARE 368 TYPE PRIV_NAME IS ACCESS PRIV; 369 BEGIN 370 DECLARE 371 PN : PRIV_NAME := NEW PRIV (IDENT_BOOL (TRUE)); 372 BEGIN 373 FAILED ( "NO EXCEPTION RAISED AT THE " & 374 "DECLARATION OF OBJECT PN " & 375 BOOLEAN'IMAGE(PN.L)); 376 EXCEPTION 377 WHEN OTHERS => 378 FAILED ( "EXCEPTION ATTEMPTING TO USE OBJECT" ); 379 END; 380 EXCEPTION 381 WHEN CONSTRAINT_ERROR => 382 NULL; 383 WHEN OTHERS => 384 FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " & 385 "OF OBJECT PN" ); 386 END; 387 EXCEPTION 388 WHEN OTHERS => 389 FAILED ( "EXCEPTION RAISED AT ELABORATION OF TYPE " & 390 "PRIV_NAME" ); 391 END; 392 393 BEGIN 394 DECLARE 395 TYPE LIM_NAME IS ACCESS LIM; 396 BEGIN 397 DECLARE 398 LN : LIM_NAME := NEW LIM (IDENT_BOOL (TRUE)); 399 BEGIN 400 FAILED ( "NO EXCEPTION RAISED AT THE " & 401 "DECLARATION OF OBJECT LN " & 402 BOOLEAN'IMAGE(LN.L)); 403 EXCEPTION 404 WHEN OTHERS => 405 FAILED ( "EXCEPTION ATTEMPTING TO USE OBJECT" ); 406 END; 407 EXCEPTION 408 WHEN CONSTRAINT_ERROR => 409 NULL; 410 WHEN OTHERS => 411 FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " & 412 "OF OBJECT LN" ); 413 END; 414 EXCEPTION 415 WHEN OTHERS => 416 FAILED ( "EXCEPTION RAISED AT ELABORATION OF TYPE " & 417 "LIM_NAME" ); 418 END; 419 420 BEGIN 421 DECLARE 422 PACKAGE PP IS 423 TYPE BAD_PRIV (D : LIES := IDENT_BOOL (TRUE)) IS 424 PRIVATE; 425 PRIVATE 426 TYPE BAD_PRIV (D : LIES := IDENT_BOOL (TRUE)) IS 427 RECORD 428 NULL; 429 END RECORD; 430 END PP; 431 432 USE PP; 433 BEGIN 434 DECLARE 435 BP : BAD_PRIV; 436 BEGIN 437 FAILED ( "NO EXCEPTION RAISED AT THE " & 438 "DECLARATION OF OBJECT BP " & 439 BOOLEAN'IMAGE(BP.D)); 440 EXCEPTION 441 WHEN OTHERS => 442 FAILED ( "EXCEPTION ATTEMPTING TO USE OBJECT" ); 443 END; 444 EXCEPTION 445 WHEN CONSTRAINT_ERROR => 446 NULL; 447 WHEN OTHERS => 448 FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " & 449 "OF OBJECT BP" ); 450 END; 451 EXCEPTION 452 WHEN OTHERS => 453 FAILED ( "EXCEPTION RAISED AT ELABORATION OF TYPE " & 454 "BAD_PRIV" ); 455 END; 456 457 BEGIN 458 DECLARE 459 PACKAGE PL IS 460 TYPE BAD_LIM (D : LIES := IDENT_BOOL (TRUE)) IS 461 LIMITED PRIVATE; 462 PRIVATE 463 TYPE BAD_LIM (D : LIES := IDENT_BOOL (TRUE)) IS 464 RECORD 465 NULL; 466 END RECORD; 467 END PL; 468 469 USE PL; 470 BEGIN 471 DECLARE 472 BL : BAD_LIM; 473 BEGIN 474 FAILED ( "NO EXCEPTION RAISED AT THE " & 475 "DECLARATION OF OBJECT BL " & 476 BOOLEAN'IMAGE(BL.D)); 477 EXCEPTION 478 WHEN OTHERS => 479 FAILED ( "EXCEPTION ATTEMPTING TO USE OBJECT" ); 480 END; 481 EXCEPTION 482 WHEN CONSTRAINT_ERROR => 483 NULL; 484 WHEN OTHERS => 485 FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " & 486 "OF OBJECT BL" ); 487 END; 488 EXCEPTION 489 WHEN OTHERS => 490 FAILED ( "EXCEPTION RAISED AT ELABORATION OF TYPE " & 491 "BAD_LIM" ); 492 END; 493 494 RESULT; 495END C37211B; 496