OpenCores
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/] [c3/] [c38002a.ada] - Blame information for rev 294

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 294 jeremybenn
-- C38002A.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 AN UNCONSTRAINED ARRAY TYPE OR A RECORD WITHOUT
27
--     DEFAULT DISCRIMINANTS CAN BE USED IN AN ACCESS_TYPE_DEFINITION
28
--     WITHOUT AN INDEX OR DISCRIMINANT CONSTRAINT.
29
--
30
--     CHECK THAT (NON-STATIC) INDEX OR DISCRIMINANT CONSTRAINTS CAN
31
--     SUBSEQUENTLY BE IMPOSED WHEN THE TYPE IS USED IN AN OBJECT
32
--     DECLARATION, ARRAY COMPONENT DECLARATION, RECORD COMPONENT
33
--     DECLARATION, ACCESS TYPE DECLARATION, PARAMETER DECLARATION,
34
--     DERIVED TYPE DEFINITION, PRIVATE TYPE.
35
--
36
--     CHECK FOR UNCONSTRAINED GENERIC FORMAL TYPE.
37
 
38
-- HISTORY:
39
--     AH  09/02/86 CREATED ORIGINAL TEST.
40
--     DHH 08/16/88 REVISED HEADER AND ENTERED COMMENTS FOR PRIVATE TYPE
41
--                  AND CORRECTED INDENTATION.
42
--     BCB 04/12/90 ADDED CHECKS FOR AN ARRAY AS A SUBPROGRAM RETURN
43
--                  TYPE AND AN ARRAY AS A FORMAL PARAMETER.
44
--     LDC 10/01/90 ADDED CODE SO F, FPROC, G, GPROC AREN'T OPTIMIZED 
45
--                  AWAY
46
 
47
WITH REPORT; USE REPORT;
48
PROCEDURE C38002A IS
49
 
50
BEGIN
51
     TEST ("C38002A", "NON-STATIC CONSTRAINTS CAN BE IMPOSED " &
52
           "ON ACCESS TYPES ACCESSING PREVIOUSLY UNCONSTRAINED " &
53
           "ARRAY OR RECORD TYPES");
54
 
55
     DECLARE
56
          C3 : CONSTANT INTEGER := IDENT_INT(3);
57
 
58
          TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER;
59
          TYPE ARR_NAME IS ACCESS ARR;
60
          SUBTYPE ARR_NAME_3 IS ARR_NAME(1..3);
61
 
62
          TYPE REC(DISC : INTEGER) IS
63
               RECORD
64
                    COMP : ARR_NAME(1..DISC);
65
               END RECORD;
66
          TYPE REC_NAME IS ACCESS REC;
67
 
68
          OBJ : REC_NAME(C3);
69
 
70
          TYPE ARR2 IS ARRAY (1..10) OF REC_NAME(C3);
71
 
72
          TYPE REC2 IS
73
               RECORD
74
                    COMP2 : REC_NAME(C3);
75
               END RECORD;
76
 
77
          TYPE NAME_REC_NAME IS ACCESS REC_NAME(C3);
78
 
79
          TYPE DERIV IS NEW REC_NAME(C3);
80
          SUBTYPE REC_NAME_3 IS REC_NAME(C3);
81
 
82
          FUNCTION F (PARM : REC_NAME_3) RETURN REC_NAME_3 IS
83
          BEGIN
84
               IF NOT EQUAL(IDENT_INT(3), 1 + IDENT_INT(2)) THEN
85
                    COMMENT("DON'T OPTIMIZE F AWAY");
86
               END IF;
87
               RETURN PARM;
88
          END;
89
 
90
          PROCEDURE FPROC (PARM : REC_NAME_3) IS
91
          BEGIN
92
               IF NOT EQUAL(IDENT_INT(4), 2 + IDENT_INT(2)) THEN
93
                    COMMENT("DON'T OPTIMIZE FPROC AWAY");
94
               END IF;
95
          END FPROC;
96
 
97
          FUNCTION G (PA : ARR_NAME_3) RETURN ARR_NAME_3 IS
98
          BEGIN
99
               IF NOT EQUAL(IDENT_INT(5), 3 + IDENT_INT(2)) THEN
100
                    COMMENT("DON'T OPTIMIZE G AWAY");
101
               END IF;
102
               RETURN PA;
103
          END G;
104
 
105
          PROCEDURE GPROC (PA : ARR_NAME_3) IS
106
          BEGIN
107
               IF NOT EQUAL(IDENT_INT(6), 4 + IDENT_INT(2)) THEN
108
                    COMMENT("DON'T OPTIMIZE GPROC AWAY");
109
               END IF;
110
          END GPROC;
111
 
112
     BEGIN
113
          DECLARE
114
               R : REC_NAME;
115
          BEGIN
116
               R := NEW REC'(DISC => 3, COMP => NEW ARR'(1..3 => 5));
117
               R := F(R);
118
               R := NEW REC'(DISC => 4, COMP => NEW ARR'(1..4 => 5));
119
               R := F(R);
120
               FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &
121
                       "ACCEPTED BY FUNCTION FOR RECORD");
122
          EXCEPTION
123
               WHEN CONSTRAINT_ERROR =>
124
                    IF R = NULL OR ELSE R.DISC /= 4 THEN
125
                         FAILED ("ERROR IN EVALUATION/ASSIGNMENT OF " &
126
                                 "ACCESS VALUE - RECORD,FUNCTION");
127
                    END IF;
128
          END;
129
 
130
          DECLARE
131
               R : REC_NAME;
132
          BEGIN
133
               R := NEW REC'(DISC => 3, COMP => NEW ARR'(1..3 => 5));
134
               FPROC(R);
135
               R := NEW REC'(DISC => 4, COMP => NEW ARR'(1..4 => 5));
136
               FPROC(R);
137
               FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &
138
                       "ACCEPTED BY PROCEDURE FOR RECORD");
139
          EXCEPTION
140
               WHEN CONSTRAINT_ERROR =>
141
                    IF R = NULL OR ELSE R.DISC /= 4 THEN
142
                         FAILED ("ERROR IN EVALUATION/ASSIGNMENT OF " &
143
                                 "ACCESS VALUE - RECORD,PROCEDURE");
144
                    END IF;
145
          END;
146
 
147
          DECLARE
148
               A : ARR_NAME;
149
          BEGIN
150
               A := NEW ARR'(1..3 => 5);
151
               A := G(A);
152
               A := NEW ARR'(1..4 => 6);
153
               A := G(A);
154
               FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &
155
                       "ACCEPTED BY FUNCTION FOR ARRAY");
156
          EXCEPTION
157
               WHEN CONSTRAINT_ERROR =>
158
                    IF A = NULL OR ELSE A(4) /= 6 THEN
159
                         FAILED ("ERROR IN EVALUATION/ASSIGNMENT OF " &
160
                                 "ACCESS VALUE - ARRAY,FUNCTION");
161
                    END IF;
162
          END;
163
 
164
          DECLARE
165
               A : ARR_NAME;
166
          BEGIN
167
               A := NEW ARR'(1..3 => 5);
168
               GPROC(A);
169
               A := NEW ARR'(1..4 => 6);
170
               GPROC(A);
171
               FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &
172
                       "ACCEPTED BY PROCEDURE FOR ARRAY");
173
          EXCEPTION
174
               WHEN CONSTRAINT_ERROR =>
175
                    IF A = NULL OR ELSE A(4) /= 6 THEN
176
                         FAILED ("ERROR IN EVALUATION/ASSIGNMENT OF " &
177
                                 "ACCESS VALUE - ARRAY,PROCEDURE");
178
                    END IF;
179
          END;
180
     END;
181
 
182
     DECLARE
183
          C3 : CONSTANT INTEGER := IDENT_INT(3);
184
 
185
          TYPE REC (DISC : INTEGER) IS
186
               RECORD
187
                    NULL;
188
               END RECORD;
189
 
190
          TYPE P_ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER;
191
          TYPE P_ARR_NAME IS ACCESS P_ARR;
192
 
193
          TYPE P_REC_NAME IS ACCESS REC;
194
 
195
          GENERIC
196
               TYPE UNCON_ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER;
197
          PACKAGE P IS
198
               TYPE ACC_REC IS ACCESS REC;
199
               TYPE ACC_ARR IS ACCESS UNCON_ARR;
200
               TYPE ACC_P_ARR IS ACCESS P_ARR;
201
               SUBTYPE ACC_P_ARR_3 IS ACC_P_ARR(1..3);
202
               OBJ : ACC_REC(C3);
203
 
204
               TYPE ARR2 IS ARRAY (1..10) OF ACC_REC(C3);
205
 
206
               TYPE REC1 IS
207
                    RECORD
208
                         COMP1 : ACC_REC(C3);
209
                    END RECORD;
210
 
211
               TYPE REC2 IS
212
                    RECORD
213
                         COMP2 : ACC_ARR(1..C3);
214
                    END RECORD;
215
 
216
               SUBTYPE ACC_REC_3 IS ACC_REC(C3);
217
 
218
               FUNCTION F (PARM : ACC_REC_3) RETURN ACC_REC_3;
219
 
220
               PROCEDURE FPROC (PARM : ACC_REC_3);
221
 
222
               FUNCTION G (PA : ACC_P_ARR_3) RETURN ACC_P_ARR_3;
223
 
224
               PROCEDURE GPROC (PA : ACC_P_ARR_3);
225
 
226
               TYPE ACC1 IS PRIVATE;
227
               TYPE ACC2 IS PRIVATE;
228
               TYPE DER1 IS PRIVATE;
229
               TYPE DER2 IS PRIVATE;
230
 
231
          PRIVATE
232
 
233
               TYPE ACC1 IS ACCESS ACC_REC(C3);
234
               TYPE ACC2 IS ACCESS ACC_ARR(1..C3);
235
               TYPE DER1 IS NEW ACC_REC(C3);
236
               TYPE DER2 IS NEW ACC_ARR(1..C3);
237
          END P;
238
 
239
          PACKAGE BODY P IS
240
               FUNCTION F (PARM : ACC_REC_3) RETURN ACC_REC_3 IS
241
               BEGIN
242
                    IF NOT EQUAL(IDENT_INT(3), 1 + IDENT_INT(2)) THEN
243
                         COMMENT("DON'T OPTIMIZE F AWAY");
244
                    END IF;
245
                    RETURN PARM;
246
               END;
247
 
248
               PROCEDURE FPROC (PARM : ACC_REC_3) IS
249
               BEGIN
250
                    IF NOT EQUAL(IDENT_INT(4), 2 + IDENT_INT(2)) THEN
251
                         COMMENT("DON'T OPTIMIZE FPROC AWAY");
252
                    END IF;
253
               END FPROC;
254
 
255
               FUNCTION G (PA : ACC_P_ARR_3) RETURN ACC_P_ARR_3 IS
256
               BEGIN
257
                    IF NOT EQUAL(IDENT_INT(5), 3 + IDENT_INT(2)) THEN
258
                         COMMENT("DON'T OPTIMIZE G AWAY");
259
                    END IF;
260
                    RETURN PA;
261
               END;
262
 
263
               PROCEDURE GPROC (PA : ACC_P_ARR_3) IS
264
               BEGIN
265
                    IF NOT EQUAL(IDENT_INT(6), 4 + IDENT_INT(2)) THEN
266
                         COMMENT("DON'T OPTIMIZE GPROC AWAY");
267
                    END IF;
268
               END GPROC;
269
          END P;
270
 
271
          PACKAGE NP IS NEW P (UNCON_ARR => P_ARR);
272
 
273
          USE NP;
274
 
275
     BEGIN
276
          DECLARE
277
               R : ACC_REC;
278
          BEGIN
279
               R := NEW REC(DISC => 3);
280
               R := F(R);
281
               R := NEW REC(DISC => 4);
282
               R := F(R);
283
               FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &
284
                       "ACCEPTED BY FUNCTION FOR A RECORD -GENERIC");
285
          EXCEPTION
286
               WHEN CONSTRAINT_ERROR =>
287
                    IF R = NULL OR ELSE R.DISC /= 4 THEN
288
                         FAILED ("ERROR IN EVALUATION/ASSIGNMENT " &
289
                                 "OF ACCESS VALUE - RECORD," &
290
                                 "FUNCTION -GENERIC");
291
                    END IF;
292
          END;
293
 
294
          DECLARE
295
               R : ACC_REC;
296
          BEGIN
297
               R := NEW REC(DISC => 3);
298
               FPROC(R);
299
               R := NEW REC(DISC => 4);
300
               FPROC(R);
301
               FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &
302
                       "ACCEPTED BY PROCEDURE FOR A RECORD -GENERIC");
303
          EXCEPTION
304
               WHEN CONSTRAINT_ERROR =>
305
                    IF R = NULL OR ELSE R.DISC /= 4 THEN
306
                         FAILED ("ERROR IN EVALUATION/ASSIGNMENT " &
307
                                 "OF ACCESS VALUE - RECORD," &
308
                                 "PROCEDURE -GENERIC");
309
                    END IF;
310
          END;
311
 
312
          DECLARE
313
               A : ACC_P_ARR;
314
          BEGIN
315
               A := NEW P_ARR'(1..3 => 5);
316
               A := G(A);
317
               A := NEW P_ARR'(1..4 => 6);
318
               A := G(A);
319
               FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &
320
                       "ACCEPTED BY FUNCTION FOR AN ARRAY -GENERIC");
321
          EXCEPTION
322
               WHEN CONSTRAINT_ERROR =>
323
                    IF A = NULL OR ELSE A(4) /= 6 THEN
324
                         FAILED ("ERROR IN EVALUATION/ASSIGNMENT " &
325
                                 "OF ACCESS VALUE - ARRAY," &
326
                                 "FUNCTION -GENERIC");
327
                    END IF;
328
          END;
329
 
330
          DECLARE
331
               A : ACC_P_ARR;
332
          BEGIN
333
               A := NEW P_ARR'(1..3 => 5);
334
               GPROC(A);
335
               A := NEW P_ARR'(1..4 => 6);
336
               GPROC(A);
337
               FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &
338
                       "ACCEPTED BY PROCEDURE FOR AN ARRAY -GENERIC");
339
          EXCEPTION
340
               WHEN CONSTRAINT_ERROR =>
341
                    IF A = NULL OR ELSE A(4) /= 6 THEN
342
                         FAILED ("ERROR IN EVALUATION/ASSIGNMENT " &
343
                                 "OF ACCESS VALUE - ARRAY," &
344
                                 "PROCEDURE -GENERIC");
345
                    END IF;
346
          END;
347
     END;
348
 
349
     DECLARE
350
          TYPE CON_INT IS RANGE 1..10;
351
 
352
          GENERIC
353
               TYPE UNCON_INT IS RANGE <>;
354
          PACKAGE P2 IS
355
               SUBTYPE NEW_INT IS UNCON_INT RANGE 1..5;
356
               FUNCTION FUNC_INT (PARM : NEW_INT) RETURN NEW_INT;
357
 
358
               PROCEDURE PROC_INT (PARM : NEW_INT);
359
          END P2;
360
 
361
          PACKAGE BODY P2 IS
362
               FUNCTION FUNC_INT (PARM : NEW_INT) RETURN NEW_INT IS
363
               BEGIN
364
                    IF NOT EQUAL(IDENT_INT(3), 1 + IDENT_INT(2)) THEN
365
                         COMMENT("DON'T OPTIMIZE F AWAY");
366
                    END IF;
367
                    RETURN PARM;
368
               END FUNC_INT;
369
 
370
               PROCEDURE PROC_INT (PARM : NEW_INT) IS
371
               BEGIN
372
                    IF NOT EQUAL(IDENT_INT(4), 2 + IDENT_INT(2)) THEN
373
                         COMMENT("DON'T OPTIMIZE FPROC AWAY");
374
                    END IF;
375
               END PROC_INT;
376
          END P2;
377
 
378
          PACKAGE NP2 IS NEW P2 (UNCON_INT => CON_INT);
379
 
380
          USE NP2;
381
 
382
     BEGIN
383
          DECLARE
384
               R : CON_INT;
385
          BEGIN
386
               R := 2;
387
               R := FUNC_INT(R);
388
               R := 8;
389
               R := FUNC_INT(R);
390
               FAILED ("INCOMPATIBLE CONSTRAINT ON VALUE " &
391
                       "ACCEPTED BY FUNCTION -GENERIC");
392
          EXCEPTION
393
               WHEN CONSTRAINT_ERROR =>
394
                    IF R /= 8 THEN
395
                         FAILED ("ERROR IN EVALUATION/ASSIGNMENT " &
396
                                 "OF VALUE -FUNCTION, GENERIC");
397
                    END IF;
398
          END;
399
 
400
          DECLARE
401
               R : CON_INT;
402
          BEGIN
403
               R := 2;
404
               PROC_INT(R);
405
               R := 9;
406
               PROC_INT(R);
407
               FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &
408
                       "ACCEPTED BY PROCEDURE -GENERIC");
409
          EXCEPTION
410
               WHEN CONSTRAINT_ERROR =>
411
                    IF R /= 9 THEN
412
                         FAILED ("ERROR IN EVALUATION/ASSIGNMENT " &
413
                                 "OF ACCESS VALUE - PROCEDURE, " &
414
                                 "GENERIC");
415
                    END IF;
416
          END;
417
     END;
418
 
419
     RESULT;
420
END C38002A;

powered by: WebSVN 2.1.0

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