1-- CC1221C.ADA
2
3--                             Grant of Unlimited Rights
4--
5--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
6--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
7--     unlimited rights in the software and documentation contained herein.
8--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
9--     this public release, the Government intends to confer upon all
10--     recipients unlimited rights  equal to those held by the Government.
11--     These rights include rights to use, duplicate, release or disclose the
12--     released technical data and computer software in whole or in part, in
13--     any manner and for any purpose whatsoever, and to have or permit others
14--     to do so.
15--
16--                                    DISCLAIMER
17--
18--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
19--     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
20--     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
21--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
22--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
23--     PARTICULAR PURPOSE OF SAID MATERIAL.
24--*
25-- OBJECTIVE:
26--     FOR A FORMAL INTEGER TYPE, CHECK THAT THE FOLLOWING BASIC
27--     OPERATIONS ARE IMPLICITLY DECLARED AND ARE THEREFORE AVAILABLE
28--     WITHIN THE GENERIC UNIT:  ATTRIBUTES 'POS, 'VAL, 'PRED, 'SUCC,
29--     'IMAGE, AND 'VALUE.
30
31-- HISTORY:
32--     BCB 11/12/87  CREATED ORIGINAL TEST FROM SPLIT OF CC1221A.ADA
33
34WITH SYSTEM; USE SYSTEM;
35WITH REPORT; USE REPORT;
36PROCEDURE CC1221C IS
37
38     SUBTYPE SUBINT IS INTEGER RANGE -100 .. 100;
39     TYPE NEWINT IS NEW INTEGER;
40     TYPE INT IS RANGE -300 .. 300;
41     SUBTYPE SINT1 IS INT
42          RANGE INT (IDENT_INT (-4)) .. INT (IDENT_INT (4));
43     TYPE INT1 IS RANGE -6 .. 6;
44
45BEGIN
46     TEST ( "CC1221C", "FOR A FORMAL INTEGER TYPE, CHECK THAT THE " &
47                       "FOLLOWING BASIC OPERATIONS ARE IMPLICITLY " &
48                       "DECLARED AND ARE THEREFORE AVAILABLE " &
49                       "WITHIN THE GENERIC UNIT:  ATTRIBUTES 'POS, " &
50                       "'VAL, 'PRED, 'SUCC, 'IMAGE, AND 'VALUE");
51
52     DECLARE -- (C1) CHECKS FOR BASIC OPERATIONS OF A DISCRETE TYPE.
53             --      PART III.
54
55          GENERIC
56               TYPE T IS RANGE <>;
57               F : INTEGER;
58          PROCEDURE P (STR : STRING);
59
60          PROCEDURE P (STR : STRING) IS
61               I : INTEGER;
62               Y : T;
63
64               FUNCTION IDENT (X : T) RETURN T IS
65               BEGIN
66                    IF EQUAL (3, 3) THEN
67                         RETURN X;
68                    ELSE
69                         RETURN T'SUCC (T'FIRST);
70                    END IF;
71               END IDENT;
72
73          BEGIN
74               I := F;
75               FOR X IN T LOOP
76                    IF T'VAL (I) /= X THEN
77                         FAILED ( "WRONG VALUE FOR " & STR &
78                                  "'VAL OF " & INTEGER'IMAGE (I));
79                    END IF;
80
81                    IF T'POS (X) /= I THEN
82                         FAILED ( "WRONG VALUE FOR " & STR &
83                                  "'POS OF " & T'IMAGE (X));
84                    END IF;
85
86                    I := I + 1;
87               END LOOP;
88
89               FOR X IN T LOOP
90                    IF T'SUCC (X) /= T'VAL (T'POS (X) + 1) THEN
91                         FAILED ( "WRONG VALUE FOR " & STR &
92                                  "'SUCC OF " & T'IMAGE (X));
93                    END IF;
94
95                    IF T'PRED (X) /= T'VAL (T'POS (X) - 1) THEN
96                         FAILED ( "WRONG VALUE FOR " & STR &
97                                  "'PRED OF " & T'IMAGE (X));
98                    END IF;
99               END LOOP;
100
101               BEGIN
102                    Y := T'SUCC (IDENT (T'BASE'LAST));
103                    FAILED ( "NO EXCEPTION RAISED FOR " &
104                              STR & "'SUCC (IDENT (" & STR &
105                             "'BASE'LAST))" );
106               EXCEPTION
107                    WHEN CONSTRAINT_ERROR =>
108                         NULL;
109                    WHEN OTHERS =>
110                         FAILED ( "WRONG EXCEPTION RAISED FOR " &
111                                   STR & "'SUCC (IDENT (" & STR &
112                                  "'BASE'LAST))" );
113               END;
114
115               BEGIN
116                    Y := T'PRED (IDENT (T'BASE'FIRST));
117                    FAILED ( "NO EXCEPTION RAISED FOR " &
118                              STR & "'PRED (IDENT (" & STR &
119                             "'BASE'FIRST))" );
120               EXCEPTION
121                    WHEN CONSTRAINT_ERROR =>
122                         NULL;
123                    WHEN OTHERS =>
124                         FAILED ( "WRONG EXCEPTION RAISED FOR " &
125                                   STR & "'PRED (IDENT (" & STR &
126                                  "'BASE'FIRST))" );
127               END;
128
129          END P;
130
131          PROCEDURE P1 IS NEW P (SUBINT, -100);
132          PROCEDURE P2 IS NEW P (SINT1, -4);
133          PROCEDURE P3 IS NEW P (INT1, -6);
134
135     BEGIN
136           P1 ( "SUBINT" );
137           P2 ( "SINT" );
138           P3 ( "INT1" );
139     END; -- (C1).
140
141     DECLARE -- (C2) CHECKS FOR BASIC OPERATIONS OF A DISCRETE TYPE.
142             --      PART IV.
143
144          GENERIC
145               TYPE T IS RANGE <>;
146               STR : STRING;
147          PACKAGE PKG IS END PKG;
148
149          PACKAGE BODY PKG IS
150               PROCEDURE P (IM : STRING; VA : T) IS
151               BEGIN
152                    IF T'IMAGE (VA) /= IM THEN
153                         FAILED ( "INCORRECT RESULTS FOR " & STR &
154                                  "'IMAGE OF " &
155                                   INTEGER'IMAGE (INTEGER (VA)));
156                    END IF;
157               END P;
158
159               PROCEDURE Q (IM : STRING; VA : T) IS
160               BEGIN
161                    IF T'VALUE (IM) /= VA THEN
162                         FAILED ( "INCORRECT RESULTS FOR " & STR &
163                                  "'VALUE OF " & IM);
164                    END IF;
165               EXCEPTION
166                    WHEN CONSTRAINT_ERROR =>
167                         FAILED ( "CONSTRAINT_ERROR RAISED FOR " &
168                                   STR &"'VALUE OF " & IM);
169                    WHEN OTHERS =>
170                         FAILED ( "OTHER EXCEPTION RAISED FOR " &
171                                   STR &"'VALUE OF " & IM);
172
173               END Q;
174
175          BEGIN
176               P (" 2", 2);
177               P ("-1", -1);
178
179               Q (" 2", 2);
180               Q ("-1", -1);
181               Q ("        2", 2);
182               Q ("-1     ", -1);
183          END PKG;
184
185          PACKAGE PKG1 IS NEW PKG (SUBINT, "SUBINT");
186          PACKAGE PKG2 IS NEW PKG (SINT1, "SINT1");
187          PACKAGE PKG3 IS NEW PKG (INT1, "INT1");
188          PACKAGE PKG4 IS NEW PKG (NEWINT, "NEWINT");
189
190     BEGIN
191          NULL;
192     END; -- (C2).
193
194     RESULT;
195END CC1221C;
196