WITH REPORT;
PROCEDURE C48009B IS
USE REPORT;
BEGIN
TEST( "C48009B" , "FOR ALLOCATORS OF THE FORM 'NEW T '(X)', " &
"CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN " &
"APPROPRIATE - UNCONSTRAINED RECORD AND " &
"PRIVATE TYPES");
DECLARE
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
NULL;
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;
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);
VA_T_REC_REC : A_T_REC_REC;
VA_T_REC_ARR : A_T_REC_ARR;
VB : ATB;
VCB : ACTB;
PACKAGE P IS
TYPE PRIV( A : I1_10 ) IS PRIVATE;
CONS_PRIV : CONSTANT PRIV;
PRIVATE
TYPE PRIV( A : I1_10 ) IS
RECORD
R : INTEGER;
END RECORD;
CONS_PRIV : CONSTANT PRIV := (2, 3);
END P;
USE P;
TYPE A_PRIV IS ACCESS P.PRIV;
TYPE A_CPRIV IS ACCESS P.PRIV (3);
VP : A_PRIV;
VCP : A_CPRIV;
FUNCTION ALLOC1(X : P.PRIV) RETURN A_CPRIV IS
BEGIN
IF EQUAL(1, 1) THEN
RETURN NEW P.PRIV'(X);
ELSE
RETURN NULL;
END IF;
END ALLOC1;
FUNCTION ALLOC2(X : TB) RETURN ACTB IS
BEGIN
IF EQUAL(1, 1) THEN
RETURN NEW TB'(X);
ELSE
RETURN NULL;
END IF;
END ALLOC2;
BEGIN
BEGIN VB := NEW TB'(A => IDENT_INT(0), R => 1);
FAILED ("NO EXCEPTION RAISED - CASE 1A");
EXCEPTION
WHEN CONSTRAINT_ERROR => NULL;
WHEN OTHERS =>
FAILED( "WRONG EXCEPTION RAISED - CASE 1A" );
END;
BEGIN
VB := NEW TB'(A => 8, R => 1);
FAILED ("NO EXCEPTION RAISED - CASE 1B");
EXCEPTION
WHEN CONSTRAINT_ERROR => NULL;
WHEN OTHERS =>
FAILED( "WRONG EXCEPTION RAISED - CASE 1B");
END;
BEGIN VCB := NEW TB'(2, 3);
FAILED ("NO EXCEPTION RAISED - CASE 2A");
EXCEPTION
WHEN CONSTRAINT_ERROR => NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - CASE 2A");
END;
BEGIN
IF ALLOC2((IDENT_INT(4), 3)) = NULL THEN
FAILED ("IMPOSSIBLE - CASE 2B");
END IF;
FAILED ("NO EXCEPTION RAISED - CASE 2B");
EXCEPTION
WHEN CONSTRAINT_ERROR => NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - CASE 2B");
END;
BEGIN
IF ALLOC1(CONS_PRIV) = NULL THEN
FAILED ("IMPOSSIBLE - CASE 2C");
END IF;
FAILED ("NO EXCEPTION RAISED - CASE 2C");
EXCEPTION
WHEN CONSTRAINT_ERROR => NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - CASE 2C");
END;
BEGIN
VA_T_REC_REC := NEW T_REC_REC'(1, (1, (A => 1)));
FAILED ("NO EXCEPTION RAISED - CASE 3A");
EXCEPTION
WHEN CONSTRAINT_ERROR => NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - CASE 3A");
END;
BEGIN
VA_T_REC_REC := NEW T_REC_REC'(10,
(10, (A => 10)));
FAILED ("NO EXCEPTION RAISED - CASE 3B");
EXCEPTION
WHEN CONSTRAINT_ERROR => NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - CASE 3B");
END;
BEGIN
VA_T_REC_ARR := NEW T_REC_ARR'(1, (1, (OTHERS => 1),
(OTHERS => 2)));
FAILED ("NO EXCEPTION RAISED - CASE 3C");
EXCEPTION
WHEN CONSTRAINT_ERROR => NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - CASE 3C");
END;
BEGIN
VA_T_REC_ARR := NEW T_REC_ARR'(10, (10, (OTHERS => 1),
(OTHERS => 2)));
FAILED ("NO EXCEPTION RAISED - CASE 3D");
EXCEPTION
WHEN CONSTRAINT_ERROR => NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - CASE 3D");
END;
END;
RESULT;
END C48009B;