URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [cc/] [cc1311b.ada] - Blame information for rev 309

Go to most recent revision | Details | Compare with Previous | View Log


-- CC1311B.ADA
 
--                             Grant of Unlimited Rights
--
--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained 
--     unlimited rights in the software and documentation contained herein.
--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making 
--     this public release, the Government intends to confer upon all 
--     recipients unlimited rights  equal to those held by the Government.  
--     These rights include rights to use, duplicate, release or disclose the 
--     released technical data and computer software in whole or in part, in 
--     any manner and for any purpose whatsoever, and to have or permit others 
--     to do so.
--
--                                    DISCLAIMER
--
--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED 
--     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE 
--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--     PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- OBJECTIVE:
--     CHECK THAT IF PARAMETERS OF DEFAULT AND FORMAL SUBPROGRAMS HAVE
--     THE SAME TYPE BUT NOT THE SAME SUBTYPE, THE PARAMETER SUBTYPES OF
--     THE SUBPROGRAM DENOTED BY THE DEFAULT ARE USED INSTEAD OF
--     SUBTYPES SPECIFIED IN THE FORMAL SUBPROGRAM DECLARATION.
 
-- HISTORY:
--     RJW 06/11/86 CREATED ORIGINAL TEST.
--     DHH 10/20/86 CORRECTED RANGE ERRORS.
--     PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
--     PWN 10/27/95 REMOVED CHECKS AGAINST ARRAY SLIDING RULES THAT
--                  HAVE BEEN RELAXED.
--     PWN 10/25/96 RESTORED CHECKS WITH NEW ADA 95 EXPECTED RESULTS.
 
WITH REPORT; USE REPORT;
 
PROCEDURE CC1311B IS
 
BEGIN
     TEST ("CC1311B", "CHECK THAT IF PARAMETERS OF DEFAULT AND " &
                      "FORMAL SUBPROGRAMS HAVE THE SAME TYPE BUT " &
                      "NOT THE SAME SUBTYPE, THE PARAMETER SUBTYPES " &
                      "OF THE SUBPROGRAM DENOTED BY THE DEFAULT ARE " &
                      "USED INSTEAD OF SUBTYPES SPECIFIED IN THE " &
                      "FORMAL SUBPROGRAM DECLARATION" );
 
     DECLARE
          TYPE NUMBERS IS (ZERO, ONE ,TWO);
          SUBTYPE ZERO_TWO IS NUMBERS;
          SUBTYPE ZERO_ONE IS NUMBERS RANGE ZERO .. ONE;
 
          FUNCTION FSUB (X : ZERO_ONE) RETURN ZERO_ONE IS
          BEGIN
               RETURN NUMBERS'VAL (IDENT_INT (NUMBERS'POS (ONE)));
          END FSUB;
 
          GENERIC
               WITH FUNCTION F (X : ZERO_TWO := TWO) RETURN ZERO_TWO
                    IS FSUB;
          FUNCTION FUNC  RETURN ZERO_TWO;
 
          FUNCTION FUNC RETURN ZERO_TWO IS
          BEGIN
               RETURN F;
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    RETURN ZERO;
               WHEN OTHERS =>
                    FAILED ( "WRONG EXCEPTION RAISED WITH " &
                             "NFUNC1" );
                    RETURN ZERO;
          END FUNC;
 
          FUNCTION NFUNC1 IS NEW FUNC;
 
     BEGIN
          IF NFUNC1 = ONE THEN
               FAILED ( "NO EXCEPTION RAISED WITH NFUNC1" );
          END IF;
     END;
 
     DECLARE
          TYPE GENDER IS (MALE, FEMALE);
 
          TYPE PERSON (SEX : GENDER) IS
               RECORD
                   CASE SEX IS
                         WHEN MALE =>
                              BEARDED : BOOLEAN;
                         WHEN FEMALE =>
                              CHILDREN : INTEGER;
                    END CASE;
               END RECORD;
 
          SUBTYPE MAN IS PERSON (SEX => MALE);
          SUBTYPE TESTWRITER IS PERSON (FEMALE);
 
          ROSA : TESTWRITER := (FEMALE, 4);
 
          FUNCTION F (X : MAN) RETURN PERSON IS
               TOM : PERSON (MALE) := (MALE, FALSE);
          BEGIN
               IF EQUAL (3, 3) THEN
                    RETURN X;
               ELSE
                    RETURN TOM;
               END IF;
          END F;
 
          GENERIC
               TYPE T IS PRIVATE;
               X1 : T;
               WITH FUNCTION F (X : T) RETURN T IS <> ;
          PACKAGE PKG IS END PKG;
 
          PACKAGE BODY PKG IS
          BEGIN
               IF F(X1) = X1 THEN
                    FAILED ( "NO EXCEPTION RAISED WITH " &
                             "FUNCTION 'F' AND PACKAGE " &
                             "'PKG' - 1" );
               ELSE
                    FAILED ( "NO EXCEPTION RAISED WITH " &
                             "FUNCTION 'F' AND PACKAGE " &
                             "'PKG' - 2" );
               END IF;
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    NULL;
               WHEN OTHERS =>
                    FAILED ( "WRONG EXCEPTION RAISED WITH " &
                             "FUNCTION 'F' AND PACKAGE 'PKG'" );
          END PKG;
 
          PACKAGE NPKG IS NEW PKG (TESTWRITER, ROSA);
 
     BEGIN
          COMMENT ( "PACKAGE BODY ELABORATED - 1" );
     END;
 
     DECLARE
          TYPE VECTOR IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
          SUBTYPE SUBV1 IS VECTOR (1 .. 5);
          SUBTYPE SUBV2 IS VECTOR (2 .. 6);
 
          V1 : SUBV1 := (1, 2, 3, 4, 5);
 
          FUNCTION FSUB (Y : SUBV2) RETURN VECTOR IS
               Z : SUBV2;
          BEGIN
               FOR I IN Y'RANGE LOOP
                    Z (I) := IDENT_INT (Y (I));
               END LOOP;
               RETURN Z;
          END;
 
          GENERIC
           WITH FUNCTION F (X : SUBV1 := V1) RETURN SUBV1 IS FSUB;
          PROCEDURE PROC;
 
          PROCEDURE PROC IS
          BEGIN
               IF F = V1 THEN
                    COMMENT ( "NO EXCEPTION RAISED WITH " &
                              "FUNCTION 'F' AND PROCEDURE " &
                              "'PROC' - 1" );
               ELSE
                    COMMENT ( "NO EXCEPTION RAISED WITH " &
                              "FUNCTION 'F' AND PROCEDURE " &
                              "'PROC' - 2" );
               END IF;
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    FAILED ( "CONSTRAINT_ERROR RAISED WITH " &
                             "FUNCTION 'F' AND PROCEDURE " &
                             "'PROC'" );
               WHEN OTHERS =>
                    FAILED ( "WRONG EXCEPTION RAISED WITH " &
                             "FUNCTION 'F' AND PROCEDURE " &
                             "'PROC'" );
          END PROC;
 
          PROCEDURE NPROC IS NEW PROC;
     BEGIN
          NPROC;
     END;
 
     DECLARE
 
          TYPE ACC IS ACCESS STRING;
 
          SUBTYPE INDEX1 IS INTEGER RANGE 1 .. 5;
          SUBTYPE INDEX2 IS INTEGER RANGE 2 .. 6;
 
          SUBTYPE ACC1 IS ACC (INDEX1);
          SUBTYPE ACC2 IS ACC (INDEX2);
 
          AC2 : ACC2 := NEW STRING'(2 .. 6 => 'A');
          AC  : ACC;
 
          PROCEDURE P (RESULTS : OUT ACC1; X : ACC1) IS
          BEGIN
               RESULTS := NULL;
          END P;
 
          GENERIC
           WITH PROCEDURE P1 (RESULTS : OUT ACC2; X : ACC2 := AC2)
                    IS P;
          FUNCTION FUNC RETURN ACC;
 
          FUNCTION FUNC RETURN ACC IS
               RESULTS : ACC;
          BEGIN
               P1 (RESULTS);
               RETURN RESULTS;
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    RETURN NEW STRING'("ABCDE");
               WHEN OTHERS =>
                    FAILED ( "WRONG EXCEPTION RAISED WITH " &
                             "NFUNC2" );
                    RETURN NULL;
          END FUNC;
 
          FUNCTION NFUNC2 IS NEW FUNC;
 
     BEGIN
          AC := NFUNC2;
          IF AC = NULL OR ELSE AC.ALL /= "ABCDE" THEN
            FAILED ( "NO OR WRONG EXCEPTION RAISED WITH NFUNC2" );
          END IF;
     END;
 
     DECLARE
          SUBTYPE FLOAT1 IS FLOAT RANGE -1.0 .. 0.0;
          SUBTYPE FLOAT2 IS FLOAT RANGE  0.0 .. 1.0;
 
          PROCEDURE PSUB (RESULTS : OUT FLOAT2; X : FLOAT2) IS
          BEGIN
               IF EQUAL (3, 3) THEN
                    RESULTS := X;
               ELSE
                    RESULTS := 0.0;
               END IF;
          END PSUB;
 
          GENERIC
               WITH PROCEDURE P (RESULTS : OUT FLOAT1;
                                 X : FLOAT1 := -0.0625) IS PSUB;
          PACKAGE PKG IS END PKG;
 
          PACKAGE BODY PKG IS
               RESULTS : FLOAT1;
          BEGIN
               P (RESULTS);
               IF RESULTS = 1.0 THEN
                    FAILED ( "NO EXCEPTION RAISED WITH " &
                             "PROCEDURE 'P' AND PACKAGE " &
                             "'PKG' - 1" );
               ELSE
                    FAILED ( "NO EXCEPTION RAISED WITH " &
                             "PROCEDURE 'P' AND PACKAGE " &
                             "'PKG' - 2" );
               END IF;
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    NULL;
               WHEN OTHERS =>
                    FAILED ( "WRONG EXCEPTION RAISED WITH " &
                             "PROCEDURE 'P' AND PACKAGE 'PKG'" );
          END PKG;
 
          PACKAGE NPKG IS NEW PKG;
     BEGIN
          COMMENT ( "PACKAGE BODY ELABORATED - 2" );
     END;
 
     DECLARE
          TYPE FIXED IS DELTA 0.125 RANGE -1.0 .. 1.0;
          SUBTYPE FIXED1 IS FIXED RANGE -0.5 .. 0.0;
          SUBTYPE FIXED2 IS FIXED RANGE  0.0 .. 0.5;
 
          PROCEDURE P (RESULTS : OUT FIXED1; X : FIXED1) IS
          BEGIN
               IF EQUAL (3, 3) THEN
                    RESULTS := X;
               ELSE
                    RESULTS := X;
               END IF;
          END P;
 
          GENERIC
               TYPE F IS DELTA <>;
               F1 : F;
               WITH PROCEDURE P (RESULTS : OUT F; X : F) IS <> ;
          PROCEDURE PROC;
 
          PROCEDURE PROC IS
               RESULTS : F;
          BEGIN
               P (RESULTS, F1);
               IF RESULTS = 0.0 THEN
                    FAILED ( "NO EXCEPTION RAISED WITH " &
                             "PROCEDURE 'P' AND PROCEDURE " &
                             "'PROC' - 1" );
               ELSE
                    FAILED ( "NO EXCEPTION RAISED WITH " &
                             "PROCEDURE 'P' AND PROCEDURE " &
                             "'PROC' - 2" );
               END IF;
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    NULL;
               WHEN OTHERS =>
                    FAILED ( "WRONG EXCEPTION RAISED WITH " &
                             "PROCEDURE 'P' AND PROCEDURE " &
                             "'PROC'" );
          END PROC;
 
          PROCEDURE NPROC IS NEW PROC (FIXED2, 0.125);
 
     BEGIN
          NPROC;
     END;
 
     RESULT;
 
END CC1311B;

Browse

Tools

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [cc/] [cc1311b.ada] - Blame information for rev 309

Line No.	Rev	Author	Line
1	294	jeremybenn	`-- 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
39			`WITH REPORT; USE REPORT;`
40
41			`PROCEDURE CC1311B IS`
42
43			`BEGIN`
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
332			`END CC1311B;`