WITH SYSTEM; USE SYSTEM;
WITH REPORT; USE REPORT;
PROCEDURE C34004C IS
TYPE PARENT IS DELTA 0.01 RANGE -100.0 .. 100.0;
TYPE T IS NEW PARENT DELTA 0.1 RANGE
IDENT_INT (1) * (-30.0) ..
IDENT_INT (1) * ( 30.0);
SUBTYPE SUBPARENT IS PARENT DELTA 0.1 RANGE -30.0 .. 30.0;
TYPE S IS NEW SUBPARENT;
X,XA : T;
Y,YA : S;
FUNCTION OUT_OF_BOUNDS ( VAR1 , VAR2 : T ) RETURN BOOLEAN IS
BEGIN
IF ( VAR1 + VAR2 ) IN T THEN
RETURN FALSE ;
ELSE
RETURN TRUE ;
END IF ;
EXCEPTION
WHEN CONSTRAINT_ERROR =>
RETURN TRUE ;
END OUT_OF_BOUNDS ;
FUNCTION OUT_OF_BOUNDS ( VAR1 , VAR2 : S ) RETURN BOOLEAN IS
BEGIN
IF ( VAR1 + VAR2 ) IN S THEN
RETURN FALSE ;
ELSE
RETURN TRUE ;
END IF ;
EXCEPTION
WHEN CONSTRAINT_ERROR =>
RETURN TRUE ;
END OUT_OF_BOUNDS ;
BEGIN
TEST ("C34004C", "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 " &
"FIXED POINT TYPES");
DECLARE
TBD : CONSTANT := BOOLEAN'POS (T'BASE'DELTA <= 0.01);
SBD : CONSTANT := BOOLEAN'POS (S'BASE'DELTA <= 0.01);
BEGIN
IF TBD = 0 OR SBD = 0 THEN
FAILED ("INCORRECT 'BASE'DELTA");
END IF;
END;
DECLARE
N : INTEGER := IDENT_INT (8);
BEGIN
IF 98.0 + T'(1.0) + N * 0.0078125 /= 99.0625 OR
98.0 + S'(1.0) + 8 * 0.0078125 /= 99.0625 OR
-98.0 - T'(1.0) - N * 0.0078125 /= -99.0625 OR
-98.0 - S'(1.0) - 8 * 0.0078125 /= -99.0625 THEN
FAILED ("INCORRECT + OR -");
END IF;
END;
IF T'FIRST /= -30.0 OR T'LAST /= 30.0 OR
S'FIRST /= -30.0 OR S'LAST /= 30.0 THEN
FAILED ("INCORRECT 'FIRST OR 'LAST");
END IF;
BEGIN
X := -30.0;
Y := -30.0;
IF PARENT (X) /= PARENT (Y) THEN FAILED ("INCORRECT CONVERSION TO PARENT - 1");
END IF;
X := 30.0;
Y := 30.0;
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 := -30.0 ;
XA := -0.0625 ;
IF NOT OUT_OF_BOUNDS ( X , XA ) THEN
FAILED ( "CONSTRAINT_ERROR NOT RAISED -- X := -30.0625" ) ;
END IF ;
EXCEPTION
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -- X := -30.0625");
END;
BEGIN
X := 30.0 ;
XA := 0.0625 ;
IF NOT OUT_OF_BOUNDS ( X , XA ) THEN
FAILED ( "CONSTRAINT_ERROR NOT RAISED -- X := 30.0625" ) ;
END IF ;
EXCEPTION
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -- X := 30.0625");
END;
BEGIN
Y := -30.0 ;
YA := -0.0625 ;
IF NOT OUT_OF_BOUNDS ( Y , YA ) THEN
FAILED ( "CONSTRAINT_ERROR NOT RAISED -- Y := -30.0625" ) ;
END IF ;
EXCEPTION
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -- Y := -30.0625");
END;
BEGIN
Y := 30.0 ;
YA := 0.0625 ;
IF NOT OUT_OF_BOUNDS ( Y , YA ) THEN
FAILED ( "CONSTRAINT_ERROR NOT RAISED -- Y := 30.0625" ) ;
END IF ;
EXCEPTION
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED -- Y := 30.0625");
END;
RESULT;
END C34004C;