1-- CC3601A.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-- CHECK THAT PREDEFINED OPERATORS MAY BE PASSED AS ACTUAL
26-- GENERIC SUBPROGRAM PARAMETERS (CHECKS FOR "=" AND "/=" ARE IN
27-- CC3601C).
28
29-- R.WILLIAMS 10/9/86
30-- JRL        11/15/95 Added unknown discriminant part to all formal
31--                     private types.
32
33
34WITH REPORT; USE REPORT;
35PROCEDURE CC3601A IS
36
37     GENERIC
38          TYPE T (<>) IS PRIVATE;
39          V, V1 : T;
40          KIND : STRING;
41          WITH FUNCTION F1 (X : IN T) RETURN T;
42     PACKAGE GP1 IS
43          R : BOOLEAN := F1 (V) = V1;
44     END GP1;
45
46     PACKAGE BODY GP1 IS
47     BEGIN
48          IF NOT (IDENT_BOOL(R)) THEN
49               FAILED ( "INCORRECT VALUE FOR UNARY OP - " & KIND);
50          END IF;
51     END GP1;
52
53     GENERIC
54          TYPE T (<>) IS PRIVATE;
55          V, V1, V2 : IN T;
56          KIND : STRING;
57          WITH FUNCTION F1 (P1 : IN T; P2 : IN T) RETURN T;
58     PACKAGE GP2 IS
59          R : BOOLEAN := V /= F1 (V1, V2);
60     END GP2;
61
62     PACKAGE BODY GP2 IS
63     BEGIN
64          IF IDENT_BOOL (R) THEN
65               FAILED ( "INCORRECT VALUE FOR BINARY OP - " & KIND);
66          END IF;
67     END GP2;
68
69
70     GENERIC
71          TYPE T1 (<>) IS PRIVATE;
72          TYPE T2 (<>) IS PRIVATE;
73          V1 : T1;
74          V2 : T2;
75          KIND : STRING;
76          WITH FUNCTION F1 (X : IN T1) RETURN T2;
77     PACKAGE GP3 IS
78          R : BOOLEAN := F1 (V1) = V2;
79     END GP3;
80
81     PACKAGE BODY GP3 IS
82     BEGIN
83          IF NOT (IDENT_BOOL(R)) THEN
84               FAILED ( "INCORRECT VALUE FOR OP - " & KIND);
85          END IF;
86     END GP3;
87
88BEGIN
89     TEST ( "CC3601A", "CHECK THAT PREDEFINED OPERATORS MAY BE " &
90                       "PASSED AS ACTUAL GENERIC SUBPROGRAM " &
91                       "PARAMETERS" );
92
93
94     BEGIN -- CHECKS WITH RELATIONAL OPERATORS AND LOGICAL OPERATORS AS
95           -- ACTUAL PARAMETERS.
96
97          FOR I1 IN BOOLEAN LOOP
98
99               FOR I2 IN BOOLEAN LOOP
100                    COMMENT ( "B1 = " & BOOLEAN'IMAGE (I1) & " AND " &
101                              "B2 = " & BOOLEAN'IMAGE (I2) );
102                    DECLARE
103                         B1 : BOOLEAN := IDENT_BOOL (I1);
104                         B2 : BOOLEAN := IDENT_BOOL (I2);
105
106                         PACKAGE P1 IS
107                              NEW GP1 (BOOLEAN, NOT B2, B2,
108                                       """NOT"" - 1", "NOT");
109                         PACKAGE P2 IS
110                              NEW GP2 (BOOLEAN, B1 OR B2, B1, B2,
111                                       "OR", "OR");
112                         PACKAGE P3 IS
113                              NEW GP2 (BOOLEAN, B1 AND B2, B2, B1,
114                                       "AND", "AND");
115                         PACKAGE P4 IS
116                              NEW GP2 (BOOLEAN, B1 /= B2, B1, B2,
117                                       "XOR", "XOR");
118                         PACKAGE P5 IS
119                              NEW GP2 (BOOLEAN, B1 < B2, B1, B2,
120                                       "<", "<");
121                         PACKAGE P6 IS
122                              NEW GP2 (BOOLEAN, B1 <= B2, B1, B2,
123                                       "<=", "<=");
124                         PACKAGE P7 IS
125                              NEW GP2 (BOOLEAN, B1 > B2, B1, B2,
126                                       ">", ">");
127                         PACKAGE P8 IS
128                              NEW GP2 (BOOLEAN, B1 >= B2, B1, B2,
129                                       ">=", ">=");
130
131                         TYPE AB IS ARRAY (BOOLEAN RANGE <> )
132                              OF BOOLEAN;
133                         AB1 : AB (BOOLEAN) := (B1, B2);
134                         AB2 : AB (BOOLEAN) := (B2, B1);
135                         T : AB (B1 .. B2) := (B1 .. B2 => TRUE);
136                         F : AB (B1 .. B2) := (B1 .. B2 => FALSE);
137                         VB1 : AB (B1 .. B1) := (B1 => B2);
138                         VB2 : AB (B2 .. B2) := (B2 => B1);
139
140                         PACKAGE P9 IS
141                              NEW GP1 (AB, AB1, NOT AB1,
142                                       """NOT"" - 2", "NOT");
143                         PACKAGE P10 IS
144                              NEW GP1 (AB, T, F,
145                                       """NOT"" - 3", "NOT");
146                         PACKAGE P11 IS
147                              NEW GP1 (AB, VB2, (B2 => NOT B1),
148                                       """NOT"" - 4", "NOT");
149                         PACKAGE P12 IS
150                              NEW GP2 (AB, AB1 AND AB2, AB1, AB2,
151                                       "AND", "AND");
152                    BEGIN
153                         NULL;
154                    END;
155               END LOOP;
156          END LOOP;
157     END;
158
159     DECLARE -- CHECKS WITH ADDING AND MULTIPLYING OPERATORS, "**",
160             -- AND "ABS".
161
162          PACKAGE P1 IS NEW GP1 (INTEGER, -4, -4, """+"" - 1", "+");
163
164          PACKAGE P2 IS NEW GP1 (FLOAT, 4.0, 4.0, """+"" - 2", "+");
165
166          PACKAGE P3 IS NEW GP1 (DURATION, -4.0, -4.0, """+"" - 3",
167                                 "+");
168          PACKAGE P4 IS NEW GP1 (INTEGER, -4, 4, """-"" - 1", "-");
169
170          PACKAGE P5 IS NEW GP1 (FLOAT, 0.0, 0.0, """-"" - 2", "-");
171
172          PACKAGE P6 IS NEW GP1 (DURATION, 1.0, -1.0, """-"" - 3",
173                                 "-");
174          PACKAGE P7 IS NEW GP2 (INTEGER, 6, 1, 5, """+"" - 1", "+");
175
176          PACKAGE P8 IS NEW GP2 (FLOAT, 6.0, 1.0, 5.0, """+"" - 2",
177                                 "+");
178          PACKAGE P9 IS NEW GP2 (DURATION, 6.0, 1.0, 5.0, """+"" - 3",
179                                 "+");
180          PACKAGE P10 IS NEW GP2 (INTEGER, 1, 6, 5, """-"" - 1",
181                                  "-" );
182          PACKAGE P11 IS NEW GP2 (DURATION, 11.0, 6.0,-5.0,
183                                  """-"" - 2", "-");
184          PACKAGE P12 IS NEW GP2 (FLOAT, 1.0, 6.0, 5.0, """-"" - 3",
185                                  "-");
186
187          SUBTYPE SUBINT IS INTEGER RANGE 0 .. 2;
188          TYPE STR IS ARRAY (SUBINT RANGE <>) OF CHARACTER;
189          VSTR : STR (0 .. 1) := "AB";
190
191          PACKAGE P13 IS NEW GP2 (STR, VSTR (0 .. 0) &
192                                      VSTR (1 .. 1),
193                                      VSTR (0 .. 0),
194                                      VSTR (1 .. 1), """&"" - 1", "&");
195
196          PACKAGE P14 IS NEW GP2 (STR, VSTR (1 .. 1) &
197                                      VSTR (0 .. 0),
198                                      VSTR (1 .. 1),
199                                      VSTR (0 .. 0), """&"" - 2", "&");
200
201          PACKAGE P15 IS NEW GP2 (INTEGER, 0, -1, 0, """*"" - 1", "*");
202
203          PACKAGE P16 IS NEW GP2 (FLOAT, 6.0, 3.0, 2.0, """*"" - 2",
204                                  "*");
205          PACKAGE P17 IS NEW GP2 (INTEGER, 0, 0, 6, """/"" - 1", "/");
206
207          PACKAGE P18 IS NEW GP2 (FLOAT, 3.0, 6.0, 2.0, """/"" - 2",
208                                  "/");
209          PACKAGE P19 IS NEW GP2 (INTEGER, -1, -11, 5, "REM", "REM");
210
211          PACKAGE P20 IS NEW GP2 (INTEGER, 4, -11, 5, "MOD", "MOD");
212
213          PACKAGE P21 IS NEW GP1 (INTEGER, 5, 5, """ABS"" - 1", "ABS");
214
215          PACKAGE P22 IS NEW GP1 (FLOAT, -5.0, 5.0, """ABS"" - 2",
216                                  "ABS");
217
218          PACKAGE P23 IS NEW GP1 (DURATION, 0.0, 0.0, """ABS"" - 3",
219                                  "ABS");
220
221          PACKAGE P24 IS NEW GP2 (INTEGER, 9, 3, 2, """**"" - 1",
222                                  "**");
223
224          PACKAGE P25 IS NEW GP2 (INTEGER, 1, 5, 0, """**"" - 2",
225                                  "**");
226
227     BEGIN
228          NULL;
229     END;
230
231     DECLARE -- CHECKS WITH ATTRIBUTES.
232
233          TYPE WEEKDAY IS (MON, TUES, WED, THUR, FRI);
234
235          PACKAGE P1 IS NEW GP1 (WEEKDAY, TUES, WED, "WEEKDAY'SUCC",
236                                 WEEKDAY'SUCC);
237
238          PACKAGE P2 IS NEW GP1 (WEEKDAY, TUES, MON, "WEEKDAY'PRED",
239                                 WEEKDAY'PRED);
240
241          PACKAGE P3 IS NEW GP3 (WEEKDAY, STRING, THUR, "THUR",
242                                 "WEEKDAY'IMAGE", WEEKDAY'IMAGE);
243
244          PACKAGE P4 IS NEW GP3 (STRING, WEEKDAY, "FRI", FRI,
245                                 "WEEKDAY'VALUE", WEEKDAY'VALUE);
246     BEGIN
247          NULL;
248     END;
249
250     RESULT;
251END CC3601A;
252