WITH REPORT; USE REPORT;
PROCEDURE C34001C IS
TYPE PARENT IS (E1, E2, E3, 'A', E4, E5, E6);
TYPE T IS NEW PARENT RANGE
PARENT'VAL (IDENT_INT (PARENT'POS (E3))) ..
PARENT'VAL (IDENT_INT (PARENT'POS (E4)));
SUBTYPE SUBPARENT IS PARENT RANGE E3 .. E4;
TYPE S IS NEW SUBPARENT;
X : T;
Y : S;
BEGIN
TEST ("C34001C", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
"TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
"WHEN THE DERIVED TYPE DEFINITION IS " &
"CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " &
"IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
"ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " &
"ENUMERATION TYPES, EXCLUDING BOOLEAN TYPES");
IF T'BASE'FIRST /= E1 OR T'BASE'LAST /= E6 OR
S'BASE'FIRST /= E1 OR S'BASE'LAST /= E6 THEN
FAILED ("INCORRECT 'BASE'FIRST OR 'BASE'LAST");
END IF;
IF T'PRED (E2) /= E1 OR T'SUCC (E1) /= E2 OR
S'PRED (E2) /= E1 OR S'SUCC (E1) /= E2 THEN
FAILED ("INCORRECT 'PRED OR 'SUCC");
END IF;
IF T'FIRST /= E3 OR T'LAST /= E4 OR
S'FIRST /= E3 OR S'LAST /= E4 THEN
FAILED ("INCORRECT 'FIRST OR 'LAST");
END IF;
BEGIN
X := E3;
Y := E3;
IF PARENT (X) /= PARENT (Y) THEN FAILED ("INCORRECT CONVERSION TO PARENT - 1");
END IF;
X := E4;
Y := E4;
IF PARENT (X) /= PARENT (Y) THEN FAILED ("INCORRECT CONVERSION TO PARENT - 2");
END IF;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT");
END;
BEGIN
X := E2;
FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := E2");
IF X = E2 THEN COMMENT ("X ALTERED -- X := E2");
END IF;
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -- X := E2");
END;
BEGIN
X := E5;
FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := E5");
IF X = E5 THEN COMMENT ("X ALTERED -- X := E5");
END IF;
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -- X := E5");
END;
BEGIN
Y := E2;
FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := E2");
IF Y = E2 THEN COMMENT ("Y ALTERED -- Y := E2");
END IF;
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -- Y := E2");
END;
BEGIN
Y := E5;
FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := E5");
IF Y = E5 THEN COMMENT ("Y ALTERED -- Y := E5");
END IF;
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -- Y := E5");
END;
RESULT;
END C34001C;