1-- CC1311B.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--     CHECK THAT IF PARAMETERS OF DEFAULT AND FORMAL SUBPROGRAMS HAVE
27--     THE SAME TYPE BUT NOT THE SAME SUBTYPE, THE PARAMETER SUBTYPES OF
28--     THE SUBPROGRAM DENOTED BY THE DEFAULT ARE USED INSTEAD OF
29--     SUBTYPES SPECIFIED IN THE FORMAL SUBPROGRAM DECLARATION.
30
31-- HISTORY:
32--     RJW 06/11/86 CREATED ORIGINAL TEST.
33--     DHH 10/20/86 CORRECTED RANGE ERRORS.
34--     PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
35--     PWN 10/27/95 REMOVED CHECKS AGAINST ARRAY SLIDING RULES THAT
36--                  HAVE BEEN RELAXED.
37--     PWN 10/25/96 RESTORED CHECKS WITH NEW ADA 95 EXPECTED RESULTS.
38
39WITH REPORT; USE REPORT;
40
41PROCEDURE CC1311B IS
42
43BEGIN
44     TEST ("CC1311B", "CHECK THAT IF PARAMETERS OF DEFAULT AND " &
45                      "FORMAL SUBPROGRAMS HAVE THE SAME TYPE BUT " &
46                      "NOT THE SAME SUBTYPE, THE PARAMETER SUBTYPES " &
47                      "OF THE SUBPROGRAM DENOTED BY THE DEFAULT ARE " &
48                      "USED INSTEAD OF SUBTYPES SPECIFIED IN THE " &
49                      "FORMAL SUBPROGRAM DECLARATION" );
50
51     DECLARE
52          TYPE NUMBERS IS (ZERO, ONE ,TWO);
53          SUBTYPE ZERO_TWO IS NUMBERS;
54          SUBTYPE ZERO_ONE IS NUMBERS RANGE ZERO .. ONE;
55
56          FUNCTION FSUB (X : ZERO_ONE) RETURN ZERO_ONE IS
57          BEGIN
58               RETURN NUMBERS'VAL (IDENT_INT (NUMBERS'POS (ONE)));
59          END FSUB;
60
61          GENERIC
62               WITH FUNCTION F (X : ZERO_TWO := TWO) RETURN ZERO_TWO
63                    IS FSUB;
64          FUNCTION FUNC  RETURN ZERO_TWO;
65
66          FUNCTION FUNC RETURN ZERO_TWO IS
67          BEGIN
68               RETURN F;
69          EXCEPTION
70               WHEN CONSTRAINT_ERROR =>
71                    RETURN ZERO;
72               WHEN OTHERS =>
73                    FAILED ( "WRONG EXCEPTION RAISED WITH " &
74                             "NFUNC1" );
75                    RETURN ZERO;
76          END FUNC;
77
78          FUNCTION NFUNC1 IS NEW FUNC;
79
80     BEGIN
81          IF NFUNC1 = ONE THEN
82               FAILED ( "NO EXCEPTION RAISED WITH NFUNC1" );
83          END IF;
84     END;
85
86     DECLARE
87          TYPE GENDER IS (MALE, FEMALE);
88
89          TYPE PERSON (SEX : GENDER) IS
90               RECORD
91                   CASE SEX IS
92                         WHEN MALE =>
93                              BEARDED : BOOLEAN;
94                         WHEN FEMALE =>
95                              CHILDREN : INTEGER;
96                    END CASE;
97               END RECORD;
98
99          SUBTYPE MAN IS PERSON (SEX => MALE);
100          SUBTYPE TESTWRITER IS PERSON (FEMALE);
101
102          ROSA : TESTWRITER := (FEMALE, 4);
103
104          FUNCTION F (X : MAN) RETURN PERSON IS
105               TOM : PERSON (MALE) := (MALE, FALSE);
106          BEGIN
107               IF EQUAL (3, 3) THEN
108                    RETURN X;
109               ELSE
110                    RETURN TOM;
111               END IF;
112          END F;
113
114          GENERIC
115               TYPE T IS PRIVATE;
116               X1 : T;
117               WITH FUNCTION F (X : T) RETURN T IS <> ;
118          PACKAGE PKG IS END PKG;
119
120          PACKAGE BODY PKG IS
121          BEGIN
122               IF F(X1) = X1 THEN
123                    FAILED ( "NO EXCEPTION RAISED WITH " &
124                             "FUNCTION 'F' AND PACKAGE " &
125                             "'PKG' - 1" );
126               ELSE
127                    FAILED ( "NO EXCEPTION RAISED WITH " &
128                             "FUNCTION 'F' AND PACKAGE " &
129                             "'PKG' - 2" );
130               END IF;
131          EXCEPTION
132               WHEN CONSTRAINT_ERROR =>
133                    NULL;
134               WHEN OTHERS =>
135                    FAILED ( "WRONG EXCEPTION RAISED WITH " &
136                             "FUNCTION 'F' AND PACKAGE 'PKG'" );
137          END PKG;
138
139          PACKAGE NPKG IS NEW PKG (TESTWRITER, ROSA);
140
141     BEGIN
142          COMMENT ( "PACKAGE BODY ELABORATED - 1" );
143     END;
144
145     DECLARE
146          TYPE VECTOR IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
147          SUBTYPE SUBV1 IS VECTOR (1 .. 5);
148          SUBTYPE SUBV2 IS VECTOR (2 .. 6);
149
150          V1 : SUBV1 := (1, 2, 3, 4, 5);
151
152          FUNCTION FSUB (Y : SUBV2) RETURN VECTOR IS
153               Z : SUBV2;
154          BEGIN
155               FOR I IN Y'RANGE LOOP
156                    Z (I) := IDENT_INT (Y (I));
157               END LOOP;
158               RETURN Z;
159          END;
160
161          GENERIC
162           WITH FUNCTION F (X : SUBV1 := V1) RETURN SUBV1 IS FSUB;
163          PROCEDURE PROC;
164
165          PROCEDURE PROC IS
166          BEGIN
167               IF F = V1 THEN
168                    COMMENT ( "NO EXCEPTION RAISED WITH " &
169                              "FUNCTION 'F' AND PROCEDURE " &
170                              "'PROC' - 1" );
171               ELSE
172                    COMMENT ( "NO EXCEPTION RAISED WITH " &
173                              "FUNCTION 'F' AND PROCEDURE " &
174                              "'PROC' - 2" );
175               END IF;
176          EXCEPTION
177               WHEN CONSTRAINT_ERROR =>
178                    FAILED ( "CONSTRAINT_ERROR RAISED WITH " &
179                             "FUNCTION 'F' AND PROCEDURE " &
180                             "'PROC'" );
181               WHEN OTHERS =>
182                    FAILED ( "WRONG EXCEPTION RAISED WITH " &
183                             "FUNCTION 'F' AND PROCEDURE " &
184                             "'PROC'" );
185          END PROC;
186
187          PROCEDURE NPROC IS NEW PROC;
188     BEGIN
189          NPROC;
190     END;
191
192     DECLARE
193
194          TYPE ACC IS ACCESS STRING;
195
196          SUBTYPE INDEX1 IS INTEGER RANGE 1 .. 5;
197          SUBTYPE INDEX2 IS INTEGER RANGE 2 .. 6;
198
199          SUBTYPE ACC1 IS ACC (INDEX1);
200          SUBTYPE ACC2 IS ACC (INDEX2);
201
202          AC2 : ACC2 := NEW STRING'(2 .. 6 => 'A');
203          AC  : ACC;
204
205          PROCEDURE P (RESULTS : OUT ACC1; X : ACC1) IS
206          BEGIN
207               RESULTS := NULL;
208          END P;
209
210          GENERIC
211           WITH PROCEDURE P1 (RESULTS : OUT ACC2; X : ACC2 := AC2)
212                    IS P;
213          FUNCTION FUNC RETURN ACC;
214
215          FUNCTION FUNC RETURN ACC IS
216               RESULTS : ACC;
217          BEGIN
218               P1 (RESULTS);
219               RETURN RESULTS;
220          EXCEPTION
221               WHEN CONSTRAINT_ERROR =>
222                    RETURN NEW STRING'("ABCDE");
223               WHEN OTHERS =>
224                    FAILED ( "WRONG EXCEPTION RAISED WITH " &
225                             "NFUNC2" );
226                    RETURN NULL;
227          END FUNC;
228
229          FUNCTION NFUNC2 IS NEW FUNC;
230
231     BEGIN
232          AC := NFUNC2;
233          IF AC = NULL OR ELSE AC.ALL /= "ABCDE" THEN
234            FAILED ( "NO OR WRONG EXCEPTION RAISED WITH NFUNC2" );
235          END IF;
236     END;
237
238     DECLARE
239          SUBTYPE FLOAT1 IS FLOAT RANGE -1.0 .. 0.0;
240          SUBTYPE FLOAT2 IS FLOAT RANGE  0.0 .. 1.0;
241
242          PROCEDURE PSUB (RESULTS : OUT FLOAT2; X : FLOAT2) IS
243          BEGIN
244               IF EQUAL (3, 3) THEN
245                    RESULTS := X;
246               ELSE
247                    RESULTS := 0.0;
248               END IF;
249          END PSUB;
250
251          GENERIC
252               WITH PROCEDURE P (RESULTS : OUT FLOAT1;
253                                 X : FLOAT1 := -0.0625) IS PSUB;
254          PACKAGE PKG IS END PKG;
255
256          PACKAGE BODY PKG IS
257               RESULTS : FLOAT1;
258          BEGIN
259               P (RESULTS);
260               IF RESULTS = 1.0 THEN
261                    FAILED ( "NO EXCEPTION RAISED WITH " &
262                             "PROCEDURE 'P' AND PACKAGE " &
263                             "'PKG' - 1" );
264               ELSE
265                    FAILED ( "NO EXCEPTION RAISED WITH " &
266                             "PROCEDURE 'P' AND PACKAGE " &
267                             "'PKG' - 2" );
268               END IF;
269          EXCEPTION
270               WHEN CONSTRAINT_ERROR =>
271                    NULL;
272               WHEN OTHERS =>
273                    FAILED ( "WRONG EXCEPTION RAISED WITH " &
274                             "PROCEDURE 'P' AND PACKAGE 'PKG'" );
275          END PKG;
276
277          PACKAGE NPKG IS NEW PKG;
278     BEGIN
279          COMMENT ( "PACKAGE BODY ELABORATED - 2" );
280     END;
281
282     DECLARE
283          TYPE FIXED IS DELTA 0.125 RANGE -1.0 .. 1.0;
284          SUBTYPE FIXED1 IS FIXED RANGE -0.5 .. 0.0;
285          SUBTYPE FIXED2 IS FIXED RANGE  0.0 .. 0.5;
286
287          PROCEDURE P (RESULTS : OUT FIXED1; X : FIXED1) IS
288          BEGIN
289               IF EQUAL (3, 3) THEN
290                    RESULTS := X;
291               ELSE
292                    RESULTS := X;
293               END IF;
294          END P;
295
296          GENERIC
297               TYPE F IS DELTA <>;
298               F1 : F;
299               WITH PROCEDURE P (RESULTS : OUT F; X : F) IS <> ;
300          PROCEDURE PROC;
301
302          PROCEDURE PROC IS
303               RESULTS : F;
304          BEGIN
305               P (RESULTS, F1);
306               IF RESULTS = 0.0 THEN
307                    FAILED ( "NO EXCEPTION RAISED WITH " &
308                             "PROCEDURE 'P' AND PROCEDURE " &
309                             "'PROC' - 1" );
310               ELSE
311                    FAILED ( "NO EXCEPTION RAISED WITH " &
312                             "PROCEDURE 'P' AND PROCEDURE " &
313                             "'PROC' - 2" );
314               END IF;
315          EXCEPTION
316               WHEN CONSTRAINT_ERROR =>
317                    NULL;
318               WHEN OTHERS =>
319                    FAILED ( "WRONG EXCEPTION RAISED WITH " &
320                             "PROCEDURE 'P' AND PROCEDURE " &
321                             "'PROC'" );
322          END PROC;
323
324          PROCEDURE NPROC IS NEW PROC (FIXED2, 0.125);
325
326     BEGIN
327          NPROC;
328     END;
329
330     RESULT;
331
332END CC1311B;
333