OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-old/] [gcc-4.2.2/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [cc/] [cc1311b.ada] - Blame information for rev 816

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 149 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;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.