WITH REPORT; USE REPORT;
PROCEDURE C37207A IS
BEGIN
TEST ("C37207A","DISCRIMINANT CONSTRAINT CAN BE SUPPLIED TO " &
"DECLARATIONS AND DEFINITIONS USING TYPES WITH OR WITHOUT " &
"DEFAULT DISCRIMINANT VALUES");
DECLARE
TYPE REC1 (DISC : INTEGER := 5) IS
RECORD
NULL;
END RECORD;
TYPE REC2 (DISC : INTEGER) IS
RECORD
NULL;
END RECORD;
OBJ1 : REC1(6); OBJ2 : REC2(6); BADOBJ1 : REC1(7); BADOBJ2 : REC2(7);
TYPE REC3 IS
RECORD
COMP1 : REC1(6); COMP2 : REC2(6); END RECORD;
OBJ3 : REC3;
TYPE ARR1 IS ARRAY (1..10) OF REC1(6); TYPE ARR2 IS ARRAY (1..10) OF REC2(6);
A1 : ARR1;
A2 : ARR2;
TYPE REC1_NAME IS ACCESS REC1(6); TYPE REC2_NAME IS ACCESS REC2(6);
ACC1 : REC1_NAME;
ACC2 : REC2_NAME;
SUBTYPE REC16 IS REC1(6);
SUBTYPE REC26 IS REC2(6);
PROCEDURE PROC (P1 : IN OUT REC16; P2 : IN OUT REC26) IS BEGIN
IF NOT (P1'CONSTRAINED AND P2'CONSTRAINED) THEN FAILED ("'CONSTRAINED ATTRIBUTE INCORRECT FOR " &
"CONSTRAINED FORMAL PARAMETERS");
END IF;
BEGIN
P1 := (DISC => 7); FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
"ATTEMPT TO CHANGE DISCRIMINANT OF " &
"CONSTRAINED FORMAL PARAMETER " &
INTEGER'IMAGE(P1.DISC));
EXCEPTION
WHEN CONSTRAINT_ERROR => NULL;
WHEN OTHERS => FAILED ("WRONG EXCEPTION (1)");
END;
BEGIN
P2 := (DISC => 7); FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
"ATTEMPT TO CHANGE DISCRIMINANT OF " &
"CONSTRAINED FORMAL PARAMETER " &
INTEGER'IMAGE(P2.DISC));
EXCEPTION
WHEN CONSTRAINT_ERROR => NULL;
WHEN OTHERS => FAILED ("WRONG EXCEPTION (2)");
END;
END PROC;
BEGIN
BEGIN
OBJ1 := (DISC => IDENT_INT(7)); FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
"ATTEMPT TO CHANGE DISCRIMINANT OF " &
"CONSTRAINED OBJECT");
IF OBJ1 = (DISC => 7) THEN
COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
END IF;
EXCEPTION
WHEN CONSTRAINT_ERROR => NULL;
WHEN OTHERS => FAILED ("WRONG EXCEPTION (3)");
END;
BEGIN
OBJ3 := ((DISC => IDENT_INT(7)), (DISC => IDENT_INT(7))); FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
"ATTEMPT TO CHANGE DISCRIMINANT OF " &
"CONSTRAINED RECORD COMPONENT");
IF OBJ3 = ((DISC => 7), (DISC => 7)) THEN
COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
END IF;
EXCEPTION
WHEN CONSTRAINT_ERROR => NULL;
WHEN OTHERS => FAILED ("WRONG EXCEPTION (4)");
END;
BEGIN
A2(2) := (DISC => IDENT_INT(7)); FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
"ATTEMPT TO CHANGE DISCRIMINANT OF " &
"CONSTRAINED ARRAY COMPONENT");
IF A2(2) = (DISC => 7) THEN
COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
END IF;
EXCEPTION
WHEN CONSTRAINT_ERROR => NULL;
WHEN OTHERS => FAILED ("WRONG EXCEPTION (5)");
END;
BEGIN
ACC1 := NEW REC1(DISC => IDENT_INT(7)); FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
"ATTEMPT TO ASSIGN INCOMPATIBLE OBJECT " &
"TO ACCESS VARIABLE");
IF ACC1 = NEW REC1(DISC => 7) THEN
COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION");
END IF;
EXCEPTION
WHEN CONSTRAINT_ERROR => NULL;
WHEN OTHERS => FAILED ("WRONG EXCEPTION (6)");
END;
ACC1 := NEW REC1(DISC => IDENT_INT(6));
BEGIN
ACC1.ALL := BADOBJ1; FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
"ATTEMPT TO ASSIGN INCOMPATIBLE OBJECT " &
"TO ACCESSED OBJECT");
IF ACC1.ALL = BADOBJ1 THEN
COMMENT ("PREVENT DEAD VARIABLE OPTIMIZATION");
END IF;
EXCEPTION
WHEN CONSTRAINT_ERROR => NULL;
WHEN OTHERS => FAILED ("WRONG EXCEPTION (7)");
END;
PROC (OBJ1,OBJ2);
BEGIN
PROC (BADOBJ1,BADOBJ2); FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " &
"PASSING OF CONSTRAINED ACTUAL " &
"PARAMETERS TO DIFFERENTLY CONSTRAINED " &
"FORMAL PARAMETERS");
EXCEPTION
WHEN CONSTRAINT_ERROR => NULL;
WHEN OTHERS => FAILED ("WRONG EXCEPTION (8)");
END;
END;
RESULT;
END C37207A;