| -- C48008A.ADA |
| |
| -- Grant of Unlimited Rights |
| -- |
| -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, |
| -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained |
| -- unlimited rights in the software and documentation contained herein. |
| -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making |
| -- this public release, the Government intends to confer upon all |
| -- recipients unlimited rights equal to those held by the Government. |
| -- These rights include rights to use, duplicate, release or disclose the |
| -- released technical data and computer software in whole or in part, in |
| -- any manner and for any purpose whatsoever, and to have or permit others |
| -- to do so. |
| -- |
| -- DISCLAIMER |
| -- |
| -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR |
| -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED |
| -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE |
| -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE |
| -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A |
| -- PARTICULAR PURPOSE OF SAID MATERIAL. |
| --* |
| -- FOR ALLOCATORS OF THE FORM "NEW T X", CHECK THAT CONSTRAINT_ERROR IS |
| -- RAISED IF T IS AN UNCONSTRAINED RECORD, PRIVATE, OR LIMITED TYPE, X |
| -- IS A DISCRIMINANT CONSTRAINT, AND |
| -- 1) ONE OF THE VALUES OF X IS OUTSIDE THE RANGE OF THE CORRESPONDING |
| -- DISCRIMINANT; |
| -- 2) ONE OF THE DISCRIMINANT VALUES IS NOT COMPATIBLE WITH A |
| -- CONSTRAINT OF A SUBCOMPONENT IN WHICH IT IS USED; |
| -- 3) ONE OF THE DISCRIMINANT VALUES DOES NOT EQUAL THE CORRESPONDING |
| -- VALUE OF THE ALLOCATOR'S BASE TYPE; |
| -- 4) A DEFAULT INITIALIZATION RAISES AN EXCEPTION. |
| |
| -- RM 01/08/80 |
| -- NL 10/13/81 |
| -- SPS 10/26/82 |
| -- JBG 03/02/83 |
| -- EG 07/05/84 |
| -- PWB 02/05/86 CORRECTED TEST ERROR: |
| -- CHANGED "FAILED" TO "COMMENT" IN PROCEDURE INCR_CHECK, |
| -- SO AS NOT TO PROHIBIT EVAL OF DEFLT EXPR (AI-00397/01) |
| -- ADDED COMMENTS FOR CASES. |
| |
| WITH REPORT; |
| |
| PROCEDURE C48008A IS |
| |
| USE REPORT; |
| |
| BEGIN |
| |
| TEST( "C48008A" , "FOR ALLOCATORS OF THE FORM 'NEW T X', " & |
| "CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN " & |
| "APPROPRIATE - UNCONSTRAINED RECORD AND " & |
| "PRIVATE TYPES"); |
| |
| DECLARE |
| |
| DISC_FLAG : BOOLEAN := FALSE; |
| INCR_VAL : INTEGER; |
| FUNCTION INCR(A : INTEGER) RETURN INTEGER; |
| |
| SUBTYPE I1_7 IS INTEGER RANGE IDENT_INT(1)..IDENT_INT(7); |
| SUBTYPE I1_10 IS INTEGER RANGE IDENT_INT(1)..IDENT_INT(10); |
| SUBTYPE I2_9 IS INTEGER RANGE IDENT_INT(2)..IDENT_INT(9); |
| |
| TYPE REC (A : I2_9) IS |
| RECORD |
| B : INTEGER := INCR(2); |
| END RECORD; |
| |
| TYPE ARR IS ARRAY (I2_9 RANGE <>) OF INTEGER; |
| |
| TYPE T_REC (C : I1_10) IS |
| RECORD |
| D : REC(C); |
| END RECORD; |
| |
| TYPE T_ARR (C : I1_10) IS |
| RECORD |
| D : ARR(2..C); |
| E : ARR(C..9); |
| END RECORD; |
| |
| TYPE T_REC_REC (A : I1_10) IS |
| RECORD |
| B : T_REC(A); |
| END RECORD; |
| |
| TYPE T_REC_ARR (A : I1_10) IS |
| RECORD |
| B : T_ARR(A); |
| END RECORD; |
| |
| TYPE TB ( A : I1_7 ) IS |
| RECORD |
| R : INTEGER := INCR(1); |
| END RECORD; |
| |
| TYPE UR (A : INTEGER) IS |
| RECORD |
| B : I2_9 := INCR(1); |
| END RECORD; |
| |
| TYPE A_T_REC_REC IS ACCESS T_REC_REC; |
| TYPE A_T_REC_ARR IS ACCESS T_REC_ARR; |
| TYPE ATB IS ACCESS TB; |
| TYPE ACTB IS ACCESS TB(3); |
| TYPE A_UR IS ACCESS UR; |
| |
| VA_T_REC_REC : A_T_REC_REC; |
| VA_T_REC_ARR : A_T_REC_ARR; |
| VB : ATB; |
| VCB : ACTB; |
| V_A_UR : A_UR; |
| |
| BOOL : BOOLEAN; |
| |
| FUNCTION DISC (A : INTEGER) RETURN INTEGER; |
| |
| |
| PACKAGE P IS |
| TYPE PRIV( A : I1_10 := DISC(8) ) IS PRIVATE; |
| CONS_PRIV : CONSTANT PRIV; |
| PRIVATE |
| TYPE PRIV( A : I1_10 := DISC(8) ) IS |
| RECORD |
| R : INTEGER := INCR(1); |
| END RECORD; |
| CONS_PRIV : CONSTANT PRIV := (2, 3); |
| END P; |
| |
| TYPE A_PRIV IS ACCESS P.PRIV; |
| TYPE A_CPRIV IS ACCESS P.PRIV (3); |
| |
| VP : A_PRIV; |
| VCP : A_CPRIV; |
| |
| PROCEDURE PREC_REC (X : A_T_REC_REC) IS |
| BEGIN |
| NULL; |
| END PREC_REC; |
| |
| PROCEDURE PREC_ARR (X : A_T_REC_ARR) IS |
| BEGIN |
| NULL; |
| END PREC_ARR; |
| |
| PROCEDURE PB (X : ATB) IS |
| BEGIN |
| NULL; |
| END PB; |
| |
| PROCEDURE PCB (X : ACTB) IS |
| BEGIN |
| NULL; |
| END PCB; |
| |
| PROCEDURE PPRIV (X : A_PRIV) IS |
| BEGIN |
| NULL; |
| END PPRIV; |
| |
| PROCEDURE PCPRIV (X : A_CPRIV) IS |
| BEGIN |
| NULL; |
| END PCPRIV; |
| |
| FUNCTION DISC (A : INTEGER) RETURN INTEGER IS |
| BEGIN |
| DISC_FLAG := TRUE; |
| RETURN A; |
| END DISC; |
| |
| FUNCTION INCR(A : INTEGER) RETURN INTEGER IS |
| BEGIN |
| INCR_VAL := IDENT_INT(INCR_VAL+1); |
| RETURN A; |
| END INCR; |
| |
| PROCEDURE INCR_CHECK(CASE_ID : STRING) IS |
| BEGIN |
| IF INCR_VAL /= IDENT_INT(0) THEN |
| COMMENT ("DEFAULT INITIAL VALUE WAS EVALUATED - " & |
| "CASE " & CASE_ID); |
| END IF; |
| END INCR_CHECK; |
| |
| BEGIN |
| |
| BEGIN -- A1A: 0 ILLEGAL FOR TB.A. |
| INCR_VAL := 0; |
| VB := NEW TB (A => 0); |
| FAILED ("NO EXCEPTION RAISED - CASE A1A"); |
| EXCEPTION |
| WHEN CONSTRAINT_ERROR => |
| INCR_CHECK("A1A"); |
| WHEN OTHERS => |
| FAILED( "WRONG EXCEPTION RAISED - CASE A1A" ); |
| END; -- A1A |
| |
| BEGIN -- A1B: 8 ILLEGAL IN I1_7. |
| INCR_VAL := 0; |
| VB := NEW TB (A => I1_7'(IDENT_INT(8))); |
| FAILED ("NO EXCEPTION RAISED - CASE A1B"); |
| EXCEPTION |
| WHEN CONSTRAINT_ERROR => |
| INCR_CHECK("A1B"); |
| WHEN OTHERS => |
| FAILED( "WRONG EXCEPTION RAISED - CASE A1B"); |
| END; -- A1B |
| |
| BEGIN -- A1C: 8 ILLEGAL FOR TB.A. |
| INCR_VAL := 0; |
| PB(NEW TB (A => 8)); |
| FAILED ("NO EXCEPTION RAISED - CASE A1C"); |
| EXCEPTION |
| WHEN CONSTRAINT_ERROR => |
| INCR_CHECK("A1C"); |
| WHEN OTHERS => |
| FAILED( "WRONG EXCEPTION RAISED - CASE A1C"); |
| END; --A1C |
| |
| BEGIN --A1D: 0 ILLEGAL FOR TB.A. |
| INCR_VAL := 0; |
| BOOL := ATB'(NEW TB(A => 0)) = NULL; |
| FAILED ("NO EXCEPTION RAISED - CASE A1D"); |
| EXCEPTION |
| WHEN CONSTRAINT_ERROR => |
| INCR_CHECK("A1D"); |
| WHEN OTHERS => |
| FAILED( "WRONG EXCEPTION RAISED - CASE A1D"); |
| END; --A1D |
| |
| BEGIN --A1E: 11 ILLEGAL FOR PRIV.A. |
| DISC_FLAG := FALSE; |
| INCR_VAL := 0; |
| VP := NEW P.PRIV(11); |
| FAILED("NO EXCEPTION RAISED - CASE A1E"); |
| EXCEPTION |
| WHEN CONSTRAINT_ERROR => |
| IF DISC_FLAG THEN |
| FAILED ("DISCR DEFAULT EVALUATED WHEN " & |
| "EXPLICIT VALUE WAS PROVIDED - A1E"); |
| END IF; |
| INCR_CHECK("A1E"); |
| WHEN OTHERS => |
| FAILED("WRONG EXCEPTION RAISED - CASE A1E"); |
| END; -- A1E |
| |
| BEGIN -- A2A: 1 ILLEGAL FOR REC.A. |
| INCR_VAL := 0; |
| VA_T_REC_REC := NEW T_REC_REC(A => I1_10'(IDENT_INT(1))); |
| FAILED ("NO EXCEPTION RAISED - CASE A2A"); |
| EXCEPTION |
| WHEN CONSTRAINT_ERROR => |
| INCR_CHECK("A2A"); |
| WHEN OTHERS => |
| FAILED ("WRONG EXCEPTION RAISED - CASE A2A"); |
| END; -- A2A |
| |
| BEGIN --A2B: 10 ILLEGAL FOR REC.A. |
| INCR_VAL := 0; |
| VA_T_REC_REC := NEW T_REC_REC (10); |
| FAILED ("NO EXCEPTION RAISED - CASE A2B"); |
| EXCEPTION |
| WHEN CONSTRAINT_ERROR => |
| INCR_CHECK("A2B"); |
| WHEN OTHERS => |
| FAILED ("WRONG EXCEPTION RAISED - CASE A2B"); |
| END; -- A2B |
| |
| BEGIN -- A2C: 1 ILLEGAL FOR T.ARR.E'FIRST. |
| INCR_VAL := 0; |
| PREC_ARR (NEW T_REC_ARR (1)); |
| FAILED ("NO EXCEPTION RAISED - CASE A2C"); |
| EXCEPTION |
| WHEN CONSTRAINT_ERROR => |
| INCR_CHECK ("A2C"); |
| WHEN OTHERS => |
| FAILED ("WRONG EXCEPTION RAISED - CASE A2C"); |
| END; -- A2C |
| |
| BEGIN -- A2D: 10 ILLEGAL FOR T_ARR.D'LAST. |
| INCR_VAL := 0; |
| BOOL := NEW T_REC_ARR (IDENT_INT(10)) = NULL; |
| FAILED ("NO EXCEPTION RAISED - CASE A2D"); |
| EXCEPTION |
| WHEN CONSTRAINT_ERROR => |
| INCR_CHECK ("A2D"); |
| WHEN OTHERS => |
| FAILED ("WRONG EXCEPTION RAISED - CASE A2D"); |
| END; -- A2D |
| |
| BEGIN -- A3A: ASSIGNMENT VIOLATES CONSTRAINT ON VCB'S SUBTYPE. |
| INCR_VAL := 0; |
| VCB := NEW TB (4); |
| FAILED ("NO EXCEPTION RAISED - CASE A3A"); |
| EXCEPTION |
| WHEN CONSTRAINT_ERROR => |
| INCR_CHECK("A3A"); |
| WHEN OTHERS => |
| FAILED ("WRONG EXCEPTION RAISED - CASE A3A"); |
| END; -- A3A |
| |
| BEGIN -- A3B: PARM ASSOC VIOLATES CONSTRAINT ON PARM SUBTYPE. |
| INCR_VAL := 0; |
| PCB (NEW TB (4)); |
| FAILED ("NO EXCEPTION RAISED - CASE A3B"); |
| EXCEPTION |
| WHEN CONSTRAINT_ERROR => |
| INCR_CHECK("A3B"); |
| WHEN OTHERS => |
| FAILED ("WRONG EXCEPTION RAISED - CASE A3B"); |
| END; -- A3B |
| |
| BEGIN -- A3C: 2 VIOLATES CONSTRAINT ON SUBTYPE ACTB. |
| INCR_VAL := 0; |
| BOOL := ACTB'(NEW TB (IDENT_INT(2))) = NULL; |
| FAILED ("NO EXCEPTION RAISED - CASE A3C"); |
| EXCEPTION |
| WHEN CONSTRAINT_ERROR => |
| INCR_CHECK("A3C"); |
| WHEN OTHERS => |
| FAILED ("WRONG EXCEPTION RAISED - CASE A3C"); |
| END; -- A3C |
| |
| BEGIN -- A4A: EVALUATION OF DEFAULT RAISES EXCEPTION. |
| INCR_VAL := 0; |
| V_A_UR := NEW UR(4); |
| FAILED ("NO EXCEPTION RAISED - CASE A4A"); |
| EXCEPTION |
| WHEN CONSTRAINT_ERROR => |
| NULL; |
| WHEN OTHERS => |
| FAILED ("WRONG EXCEPTION RAISED - CASE A4A"); |
| END; -- A4A |
| |
| END; |
| |
| RESULT; |
| |
| END C48008A; |
