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/] [cc3128a.ada] - Blame information for rev 816

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 149 jeremybenn
-- CC3128A.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, FOR A CONSTRAINED IN FORMAL PARAMETER HAVING AN ACCESS TYPE,
27
--     CONSTRAINT_ERROR IS RAISED IF AND ONLY IF THE ACTUAL PARAMETER IS NOT
28
--     NULL AND THE OBJECT DESIGNATED BY THE ACTUAL PARAMETER DOES NOT SATISFY
29
--     THE FORMAL PARAMETER'S CONSTRAINTS.
30
 
31
-- HISTORY:
32
--     RJW 10/28/88  CREATED ORIGINAL TEST.
33
--     JRL 02/28/96  Removed cases where the designated subtypes of the formal
34
--                   and actual do not statically match. Corrected commentary.
35
 
36
WITH REPORT; USE REPORT;
37
PROCEDURE CC3128A IS
38
 
39
BEGIN
40
     TEST ("CC3128A", "FOR A CONSTRAINED IN FORMAL PARAMETER HAVING " &
41
                      "AN ACCESS TYPE, CONSTRAINT_ERROR IS RAISED " &
42
                      "IF AND ONLY IF THE ACTUAL PARAMETER IS NOT " &
43
                      "NULL AND THE OBJECT DESIGNATED BY THE ACTUAL " &
44
                      "PARAMETER DOES NOT SATISFY FORMAL PARAMETER'S " &
45
                      "CONSTRAINTS");
46
 
47
     DECLARE
48
          TYPE REC (D : INTEGER := 10) IS
49
               RECORD
50
                    NULL;
51
               END RECORD;
52
 
53
          TYPE ACCREC IS ACCESS REC;
54
 
55
          SUBTYPE LINK IS ACCREC (5);
56
 
57
          GENERIC
58
               LINK1 : LINK;
59
          FUNCTION F (I : INTEGER) RETURN INTEGER;
60
 
61
          FUNCTION F (I : INTEGER) RETURN INTEGER IS
62
          BEGIN
63
               IF I /= 5 THEN
64
                    FAILED ("CONSTRAINT_ERROR NOT RAISED PRIOR " &
65
                            "TO CALL TO FUNCTION F - 1");
66
               END IF;
67
               IF NOT EQUAL (I, 5) AND THEN
68
                  NOT EQUAL (LINK1.D, LINK1.D) THEN
69
                    COMMENT ("DISREGARD");
70
               END IF;
71
               RETURN I + 1;
72
          EXCEPTION
73
               WHEN OTHERS =>
74
                    FAILED ("EXCEPTION RAISED WITHIN FUNCTION F - 1");
75
               RETURN I + 1;
76
          END F;
77
 
78
          GENERIC
79
               TYPE PRIV (D : INTEGER) IS PRIVATE;
80
               PRIV1 : PRIV;
81
          PACKAGE GEN IS
82
               TYPE ACCPRIV IS ACCESS PRIV;
83
               SUBTYPE LINK IS ACCPRIV (5);
84
               GENERIC
85
                    LINK1 : LINK;
86
                    I : IN OUT INTEGER;
87
               PACKAGE P IS END P;
88
          END GEN;
89
 
90
          PACKAGE BODY GEN IS
91
               PACKAGE BODY P IS
92
               BEGIN
93
                    IF I /= 5 THEN
94
                         FAILED ("CONSTRAINT_ERROR NOT RAISED PRIOR " &
95
                                 "TO PACKAGE BODY P - 1");
96
                    END IF;
97
                    IF NOT EQUAL (I, 5) AND THEN
98
                       NOT EQUAL (LINK1.D, LINK1.D) THEN
99
                         COMMENT ("DISREGARD");
100
                    END IF;
101
                    I := I + 1;
102
               EXCEPTION
103
                    WHEN OTHERS =>
104
                         FAILED ("EXCEPTION RAISED WITHIN " &
105
                                 "PACKAGE P - 1");
106
                    I := I + 1;
107
               END P;
108
 
109
          BEGIN
110
               BEGIN
111
                    DECLARE
112
                         AR10 : ACCPRIV;
113
                         I : INTEGER := IDENT_INT (5);
114
                         PACKAGE P1 IS NEW P (AR10, I);
115
                    BEGIN
116
                         IF I /= 6 THEN
117
                              FAILED ("INCORRECT RESULT - " &
118
                                      "PACKAGE P1");
119
                         END IF;
120
                    EXCEPTION
121
                         WHEN OTHERS =>
122
                              FAILED ("EXCEPTION RAISED TOO LATE - " &
123
                                      "PACKAGE P1 - 1");
124
                    END;
125
               EXCEPTION
126
                    WHEN OTHERS =>
127
                         FAILED ("EXCEPTION RAISED AT INSTANTIATION " &
128
                                 "OF PACKAGE P1 WITH NULL ACCESS " &
129
                                 "VALUE");
130
               END;
131
 
132
               BEGIN
133
                    DECLARE
134
                         AR10 : ACCPRIV := NEW PRIV'(PRIV1);
135
                         I : INTEGER := IDENT_INT (0);
136
                         PACKAGE P1 IS NEW P (AR10, I);
137
                    BEGIN
138
                         FAILED ("NO EXCEPTION RAISED BY " &
139
                                 "INSTANTIATION OF PACKAGE P1");
140
                    EXCEPTION
141
                         WHEN OTHERS =>
142
                              FAILED ("EXCEPTION RAISED TOO LATE - " &
143
                                      "PACKAGE P1 - 2");
144
                    END;
145
               EXCEPTION
146
                    WHEN CONSTRAINT_ERROR =>
147
                         NULL;
148
                    WHEN OTHERS =>
149
                         FAILED ("WRONG EXCEPTION RAISED AT " &
150
                                 "INSTANTIATION OF PACKAGE P1");
151
               END;
152
          END GEN;
153
 
154
          PACKAGE NEWGEN IS NEW GEN (REC, (D => 10));
155
 
156
     BEGIN
157
          BEGIN
158
               DECLARE
159
                    I : INTEGER := IDENT_INT (5);
160
                    AR10 : ACCREC;
161
                    FUNCTION F1 IS NEW F (AR10);
162
               BEGIN
163
                    I := F1 (I);
164
                    IF I /= 6 THEN
165
                         FAILED ("INCORRECT RESULT RETURNED BY " &
166
                                 "FUNCTION F1");
167
                    END IF;
168
               EXCEPTION
169
                    WHEN OTHERS =>
170
                         FAILED ("EXCEPTION RAISED AT CALL TO " &
171
                                 "FUNCTION F1 - 1");
172
               END;
173
          EXCEPTION
174
               WHEN OTHERS =>
175
                    FAILED ("EXCEPTION RAISED AT INSTANTIATION OF " &
176
                            "FUNCTION F1 WITH NULL ACCESS VALUE");
177
          END;
178
 
179
          BEGIN
180
               DECLARE
181
                    I : INTEGER := IDENT_INT (0);
182
                    AR10 : ACCREC := NEW REC'(D => 10);
183
                    FUNCTION F1 IS NEW F (AR10);
184
               BEGIN
185
                    FAILED ("NO EXCEPTION RAISED BY INSTANTIATION " &
186
                            "OF FUNCTION F1");
187
                    I := F1 (I);
188
               EXCEPTION
189
                    WHEN OTHERS =>
190
                         FAILED ("EXCEPTION RAISED AT CALL TO " &
191
                                 "FUNCTION F1 - 2");
192
               END;
193
          EXCEPTION
194
               WHEN CONSTRAINT_ERROR =>
195
                    NULL;
196
               WHEN OTHERS =>
197
                    FAILED ("WRONG EXCEPTION RAISED AT " &
198
                            "INSTANTIATION OF FUNCTION F1");
199
          END;
200
     END;
201
 
202
     DECLARE
203
          TYPE ARR IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
204
 
205
          TYPE ACCARR IS ACCESS ARR;
206
 
207
          SUBTYPE LINK IS ACCARR (1 .. 5);
208
 
209
          GENERIC
210
               LINK1 : LINK;
211
          FUNCTION F (I : INTEGER) RETURN INTEGER;
212
 
213
          FUNCTION F (I : INTEGER) RETURN INTEGER IS
214
          BEGIN
215
               IF I /= 5 THEN
216
                    FAILED ("CONSTRAINT_ERROR NOT RAISED PRIOR " &
217
                            "TO CALL TO FUNCTION F - 2");
218
               END IF;
219
               IF NOT EQUAL (I, 5) AND THEN
220
                  NOT EQUAL (LINK1(IDENT_INT (3)),LINK1(IDENT_INT (3)))
221
                  THEN
222
                    COMMENT ("DISREGARD");
223
               END IF;
224
               RETURN I + 1;
225
          EXCEPTION
226
               WHEN OTHERS =>
227
                    FAILED ("EXCEPTION RAISED WITHIN FUNCTION F - 2");
228
               RETURN I + 1;
229
          END F;
230
 
231
          GENERIC
232
               TYPE GENARR IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
233
          PACKAGE GEN IS
234
               TYPE ACCGENARR IS ACCESS GENARR;
235
               SUBTYPE LINK IS ACCGENARR (1 .. 5);
236
               GENERIC
237
                    LINK1 : LINK;
238
                    I : IN OUT INTEGER;
239
               PACKAGE P IS END P;
240
          END GEN;
241
 
242
          PACKAGE BODY GEN IS
243
               PACKAGE BODY P IS
244
               BEGIN
245
                    IF I /= 5 THEN
246
                         FAILED ("CONSTRAINT_ERROR NOT RAISED PRIOR " &
247
                                 "TO PACKAGE BODY P - 2");
248
                    END IF;
249
                    IF NOT EQUAL (I, 5) AND THEN
250
                       NOT
251
                       EQUAL(LINK1(IDENT_INT (3)),LINK1(IDENT_INT (3)))
252
                       THEN
253
                         COMMENT ("DISREGARD");
254
                    END IF;
255
                    I := I + 1;
256
               EXCEPTION
257
                    WHEN OTHERS =>
258
                         FAILED ("EXCEPTION RAISED WITHIN " &
259
                                 "PACKAGE P - 2");
260
                    I := I + 1;
261
               END P;
262
 
263
          BEGIN
264
               BEGIN
265
                    DECLARE
266
                         AR26 : ACCGENARR (2 .. 6);
267
                         I : INTEGER := IDENT_INT (5);
268
                         PACKAGE P2 IS NEW P (AR26, I);
269
                    BEGIN
270
                         IF I /= 6 THEN
271
                              FAILED ("INCORRECT RESULT - " &
272
                                      "PACKAGE P2");
273
                         END IF;
274
                    EXCEPTION
275
                         WHEN OTHERS =>
276
                              FAILED ("EXCEPTION RAISED TOO LATE - " &
277
                                      "PACKAGE P2 - 1");
278
                    END;
279
               EXCEPTION
280
                    WHEN OTHERS =>
281
                         FAILED ("EXCEPTION RAISED AT INSTANTIATION " &
282
                                 "OF PACKAGE P2 WITH NULL ACCESS " &
283
                                 "VALUE");
284
               END;
285
 
286
               BEGIN
287
                    DECLARE
288
                         AR26 : ACCGENARR
289
                                (IDENT_INT (2) .. IDENT_INT (6)) :=
290
                                NEW GENARR'(1,2,3,4,5);
291
                         I : INTEGER := IDENT_INT (0);
292
                         PACKAGE P2 IS NEW P (AR26, I);
293
                    BEGIN
294
                         FAILED ("NO EXCEPTION RAISED BY " &
295
                                 "INSTANTIATION OF PACKAGE P2");
296
                    EXCEPTION
297
                         WHEN OTHERS =>
298
                              FAILED ("EXCEPTION RAISED TOO LATE - " &
299
                                      "PACKAGE P2 - 2");
300
                    END;
301
               EXCEPTION
302
                    WHEN CONSTRAINT_ERROR =>
303
                         NULL;
304
                    WHEN OTHERS =>
305
                         FAILED ("WRONG EXCEPTION RAISED AT " &
306
                                 "INSTANTIATION OF PACKAGE P2");
307
               END;
308
          END GEN;
309
 
310
          PACKAGE NEWGEN IS NEW GEN (ARR);
311
 
312
     BEGIN
313
          BEGIN
314
               DECLARE
315
                    I : INTEGER := IDENT_INT (5);
316
                    AR26 : ACCARR (IDENT_INT (2) .. IDENT_INT (6));
317
                    FUNCTION F2 IS NEW F (AR26);
318
               BEGIN
319
                    I := F2 (I);
320
                    IF I /= 6 THEN
321
                         FAILED ("INCORRECT RESULT RETURNED BY " &
322
                                 "FUNCTION F2");
323
                    END IF;
324
               EXCEPTION
325
                    WHEN OTHERS =>
326
                         FAILED ("EXCEPTION RAISED AT CALL TO " &
327
                                 "FUNCTION F2 - 1");
328
               END;
329
          EXCEPTION
330
               WHEN OTHERS =>
331
                    FAILED ("EXCEPTION RAISED AT INSTANTIATION OF " &
332
                            "FUNCTION F2 WITH NULL ACCESS VALUE");
333
          END;
334
 
335
          BEGIN
336
               DECLARE
337
                    I : INTEGER := IDENT_INT (0);
338
                    AR26 : ACCARR (2 .. 6) := NEW ARR'(1,2,3,4,5);
339
                    FUNCTION F2 IS NEW F (AR26);
340
               BEGIN
341
                    FAILED ("NO EXCEPTION RAISED BY INSTANTIATION " &
342
                            "OF FUNCTION F2");
343
                    I := F2 (I);
344
               EXCEPTION
345
                    WHEN OTHERS =>
346
                         FAILED ("EXCEPTION RAISED AT CALL TO " &
347
                                 "FUNCTION F2 - 2");
348
               END;
349
          EXCEPTION
350
               WHEN CONSTRAINT_ERROR =>
351
                    NULL;
352
               WHEN OTHERS =>
353
                    FAILED ("WRONG EXCEPTION RAISED AT " &
354
                            "INSTANTIATION OF FUNCTION F2");
355
          END;
356
     END;
357
     RESULT;
358
END CC3128A;

powered by: WebSVN 2.1.0

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