WITH REPORT; USE REPORT;
PROCEDURE C34001F IS
SUBTYPE PARENT IS BOOLEAN;
TYPE T IS NEW PARENT RANGE
PARENT'VAL (IDENT_INT (PARENT'POS (FALSE))) ..
PARENT'VAL (IDENT_INT (PARENT'POS (FALSE)));
SUBTYPE SUBPARENT IS PARENT RANGE TRUE .. TRUE;
TYPE S IS NEW SUBPARENT;
X : T;
Y : S;
BEGIN
TEST ("C34001F", "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 " &
"BOOLEAN TYPES");
IF T'BASE'FIRST /= FALSE OR T'BASE'LAST /= TRUE OR
S'BASE'FIRST /= FALSE OR S'BASE'LAST /= TRUE THEN
FAILED ("INCORRECT 'BASE'FIRST OR 'BASE'LAST");
END IF;
IF T'PRED (TRUE) /= FALSE OR T'SUCC (FALSE) /= TRUE OR
S'PRED (TRUE) /= FALSE OR S'SUCC (FALSE) /= TRUE THEN
FAILED ("INCORRECT 'PRED OR 'SUCC");
END IF;
IF T'FIRST /= FALSE OR T'LAST /= FALSE OR
S'FIRST /= TRUE OR S'LAST /= TRUE THEN
FAILED ("INCORRECT 'FIRST OR 'LAST");
END IF;
BEGIN
X := FALSE;
Y := TRUE;
IF NOT PARENT (X) /= PARENT (Y) THEN FAILED ("INCORRECT CONVERSION TO PARENT");
END IF;
EXCEPTION
WHEN OTHERS =>
FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT");
END;
BEGIN
X := TRUE;
FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := TRUE");
IF X = TRUE THEN COMMENT ("X ALTERED -- X := TRUE");
END IF;
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -- X := TRUE");
END;
BEGIN
Y := FALSE;
FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := FALSE");
IF Y = FALSE THEN COMMENT ("Y ALTERED -- Y := FALSE");
END IF;
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -- Y := FALSE");
END;
RESULT;
END C34001F;