WITH SYSTEM; USE SYSTEM;
WITH REPORT; USE REPORT;
PROCEDURE CC1221C IS
SUBTYPE SUBINT IS INTEGER RANGE -100 .. 100;
TYPE NEWINT IS NEW INTEGER;
TYPE INT IS RANGE -300 .. 300;
SUBTYPE SINT1 IS INT
RANGE INT (IDENT_INT (-4)) .. INT (IDENT_INT (4));
TYPE INT1 IS RANGE -6 .. 6;
BEGIN
TEST ( "CC1221C", "FOR A FORMAL INTEGER TYPE, CHECK THAT THE " &
"FOLLOWING BASIC OPERATIONS ARE IMPLICITLY " &
"DECLARED AND ARE THEREFORE AVAILABLE " &
"WITHIN THE GENERIC UNIT: ATTRIBUTES 'POS, " &
"'VAL, 'PRED, 'SUCC, 'IMAGE, AND 'VALUE");
DECLARE
GENERIC
TYPE T IS RANGE <>;
F : INTEGER;
PROCEDURE P (STR : STRING);
PROCEDURE P (STR : STRING) IS
I : INTEGER;
Y : T;
FUNCTION IDENT (X : T) RETURN T IS
BEGIN
IF EQUAL (3, 3) THEN
RETURN X;
ELSE
RETURN T'SUCC (T'FIRST);
END IF;
END IDENT;
BEGIN
I := F;
FOR X IN T LOOP
IF T'VAL (I) /= X THEN
FAILED ( "WRONG VALUE FOR " & STR &
"'VAL OF " & INTEGER'IMAGE (I));
END IF;
IF T'POS (X) /= I THEN
FAILED ( "WRONG VALUE FOR " & STR &
"'POS OF " & T'IMAGE (X));
END IF;
I := I + 1;
END LOOP;
FOR X IN T LOOP
IF T'SUCC (X) /= T'VAL (T'POS (X) + 1) THEN
FAILED ( "WRONG VALUE FOR " & STR &
"'SUCC OF " & T'IMAGE (X));
END IF;
IF T'PRED (X) /= T'VAL (T'POS (X) - 1) THEN
FAILED ( "WRONG VALUE FOR " & STR &
"'PRED OF " & T'IMAGE (X));
END IF;
END LOOP;
BEGIN
Y := T'SUCC (IDENT (T'BASE'LAST));
FAILED ( "NO EXCEPTION RAISED FOR " &
STR & "'SUCC (IDENT (" & STR &
"'BASE'LAST))" );
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ( "WRONG EXCEPTION RAISED FOR " &
STR & "'SUCC (IDENT (" & STR &
"'BASE'LAST))" );
END;
BEGIN
Y := T'PRED (IDENT (T'BASE'FIRST));
FAILED ( "NO EXCEPTION RAISED FOR " &
STR & "'PRED (IDENT (" & STR &
"'BASE'FIRST))" );
EXCEPTION
WHEN CONSTRAINT_ERROR =>
NULL;
WHEN OTHERS =>
FAILED ( "WRONG EXCEPTION RAISED FOR " &
STR & "'PRED (IDENT (" & STR &
"'BASE'FIRST))" );
END;
END P;
PROCEDURE P1 IS NEW P (SUBINT, -100);
PROCEDURE P2 IS NEW P (SINT1, -4);
PROCEDURE P3 IS NEW P (INT1, -6);
BEGIN
P1 ( "SUBINT" );
P2 ( "SINT" );
P3 ( "INT1" );
END;
DECLARE
GENERIC
TYPE T IS RANGE <>;
STR : STRING;
PACKAGE PKG IS END PKG;
PACKAGE BODY PKG IS
PROCEDURE P (IM : STRING; VA : T) IS
BEGIN
IF T'IMAGE (VA) /= IM THEN
FAILED ( "INCORRECT RESULTS FOR " & STR &
"'IMAGE OF " &
INTEGER'IMAGE (INTEGER (VA)));
END IF;
END P;
PROCEDURE Q (IM : STRING; VA : T) IS
BEGIN
IF T'VALUE (IM) /= VA THEN
FAILED ( "INCORRECT RESULTS FOR " & STR &
"'VALUE OF " & IM);
END IF;
EXCEPTION
WHEN CONSTRAINT_ERROR =>
FAILED ( "CONSTRAINT_ERROR RAISED FOR " &
STR &"'VALUE OF " & IM);
WHEN OTHERS =>
FAILED ( "OTHER EXCEPTION RAISED FOR " &
STR &"'VALUE OF " & IM);
END Q;
BEGIN
P (" 2", 2);
P ("-1", -1);
Q (" 2", 2);
Q ("-1", -1);
Q (" 2", 2);
Q ("-1 ", -1);
END PKG;
PACKAGE PKG1 IS NEW PKG (SUBINT, "SUBINT");
PACKAGE PKG2 IS NEW PKG (SINT1, "SINT1");
PACKAGE PKG3 IS NEW PKG (INT1, "INT1");
PACKAGE PKG4 IS NEW PKG (NEWINT, "NEWINT");
BEGIN
NULL;
END;
RESULT;
END CC1221C;