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 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;
BEGIN 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;
BEGIN 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;
BEGIN 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;
BEGIN 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;
BEGIN 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;
BEGIN 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;
BEGIN 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;
BEGIN 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;
BEGIN 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;
BEGIN 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;
BEGIN 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;
BEGIN 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;
END;
RESULT;
END C48008A;