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

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

Line No. Rev Author Line
1 294 jeremybenn
-- C37213F.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
-- CHECK THAT IF
26
--        A DISCRIMINANT CONSTRAINT
27
-- DEPENDS ON A DISCRIMINANT, THE NON-DISCRIMINANT EXPRESSIONS IN THE
28
-- CONSTRAINT ARE EVALUATED WHEN THE COMPONENT SUBTYPE DEFINITION IS
29
-- ELABORATED, BUT THE VALUES ARE CHECKED WHEN THE RECORD TYPE IS:
30
--
31
--   CASE D: USED WITHOUT A CONSTRAINT ONLY IN AN ALLOCATOR OR OBJECT
32
--      DECLARATION AND THE COMPONENT IS PRESENT IN THE DEFAULT SUBTYPE.
33
 
34
-- JBG 10/17/86
35
 
36
WITH REPORT; USE REPORT;
37
PROCEDURE C37213F IS
38
 
39
     SUBTYPE SM IS INTEGER RANGE 1..10;
40
 
41
     TYPE REC (D1, D2 : SM) IS
42
          RECORD NULL; END RECORD;
43
 
44
     F1_CONS : INTEGER := 2;
45
 
46
     FUNCTION CHK (
47
          CONS    : INTEGER;
48
          VALUE   : INTEGER;
49
          MESSAGE : STRING) RETURN BOOLEAN IS
50
     BEGIN
51
          IF CONS /= VALUE THEN
52
               FAILED (MESSAGE & ": CONS IS " &
53
                       INTEGER'IMAGE(CONS));
54
          END IF;
55
          RETURN TRUE;
56
     END CHK;
57
 
58
     FUNCTION F1 RETURN INTEGER IS
59
     BEGIN
60
          F1_CONS := F1_CONS - IDENT_INT(1);
61
          RETURN F1_CONS;
62
     END F1;
63
 
64
BEGIN
65
     TEST ("C37213F", "CHECK EVALUATION OF DISCRIMINANT EXPRESSIONS " &
66
                      "WHEN CONSTRAINT DEPENDS ON DISCRIMINANT, " &
67
                      "DISCRIMINANTS HAVE DEFAULTS, AND COMPONENT" &
68
                      "SUBTYPE DETERMINES WHETHER CONSTRAINT SHOULD " &
69
                      "BE CHECKED");
70
 
71
-- CASE D1: COMPONENT IS PRESENT
72
 
73
     DECLARE
74
          TYPE CONS (D3 : INTEGER := IDENT_INT(1)) IS
75
               RECORD
76
                    CASE D3 IS
77
                         WHEN -5..10 =>
78
                              C1 : REC (D3, F1);       -- F1 EVALUATED
79
                         WHEN OTHERS =>
80
                              C2 : INTEGER := IDENT_INT(0);
81
                    END CASE;
82
               END RECORD;
83
          CHK1 : BOOLEAN := CHK (F1_CONS, 1, "F1 NOT EVALUATED");
84
          X : CONS;             -- F1 NOT EVALUATED AGAIN
85
          Y : CONS;             -- F1 NOT EVALUATED AGAIN
86
          CHK2 : BOOLEAN := CHK (F1_CONS, 1, "F1 EVALUATED");
87
     BEGIN
88
          IF X /= (1, (1, 1)) OR Y /= (1, (1, 1)) THEN
89
               FAILED ("DISCRIMINANT VALUES NOT CORRECT");
90
          END IF;
91
     END;
92
 
93
     F1_CONS := 12;
94
 
95
     DECLARE
96
          TYPE CONS (D3 : INTEGER := IDENT_INT(1)) IS
97
               RECORD
98
                    CASE D3 IS
99
                         WHEN -5..10 =>
100
                              C1 : REC(D3, F1);
101
                         WHEN OTHERS =>
102
                              C2 : INTEGER := IDENT_INT(0);
103
                    END CASE;
104
               END RECORD;
105
     BEGIN
106
          BEGIN
107
               DECLARE
108
                    X : CONS;
109
               BEGIN
110
                    FAILED ("DISCRIMINANT CHECK NOT PERFORMED - 1");
111
                    IF X /= (1, (1, 1)) THEN
112
                         COMMENT ("SHOULDN'T GET HERE");
113
                    END IF;
114
               END;
115
          EXCEPTION
116
               WHEN CONSTRAINT_ERROR =>
117
                    NULL;
118
               WHEN OTHERS =>
119
                    FAILED ("UNEXPECTED EXCEPTION - 1");
120
          END;
121
 
122
          BEGIN
123
               DECLARE
124
                    TYPE ACC_CONS IS ACCESS CONS;
125
                    X : ACC_CONS;
126
               BEGIN
127
                    X := NEW CONS;
128
                    FAILED ("DISCRIMINANT CHECK NOT PERFORMED - 2");
129
                    IF X.ALL /= (1, (1, 1)) THEN
130
                         COMMENT ("IRRELEVANT");
131
                    END IF;
132
               EXCEPTION
133
                    WHEN CONSTRAINT_ERROR =>
134
                         NULL;
135
                    WHEN OTHERS =>
136
                         FAILED ("UNEXPECTED EXCEPTION RAISED - 2A");
137
               END;
138
          EXCEPTION
139
               WHEN OTHERS =>
140
                    FAILED ("UNEXPECTED EXCEPTION RAISED - 2B");
141
          END;
142
 
143
          BEGIN
144
               DECLARE
145
                    SUBTYPE SCONS IS CONS;
146
               BEGIN
147
                    DECLARE
148
                         X : SCONS;
149
                    BEGIN
150
                         FAILED ("DISCRIMINANT CHECK NOT " &
151
                                 "PERFORMED - 3");
152
                         IF X /= (1, (1, 1)) THEN
153
                              COMMENT ("IRRELEVANT");
154
                         END IF;
155
                    END;
156
               EXCEPTION
157
                    WHEN CONSTRAINT_ERROR =>
158
                         NULL;
159
                    WHEN OTHERS =>
160
                         FAILED ("UNEXPECTED EXCEPTION RAISED - 3");
161
               END;
162
          EXCEPTION
163
               WHEN OTHERS =>
164
                    FAILED ("CONSTRAINT CHECKED TOO SOON - 3");
165
          END;
166
 
167
          BEGIN
168
               DECLARE
169
                    TYPE ARR IS ARRAY (1..5) OF CONS;
170
               BEGIN
171
                    DECLARE
172
                         X : ARR;
173
                    BEGIN
174
                         FAILED ("DISCRIMINANT CHECK NOT " &
175
                                 "PERFORMED - 4");
176
                         IF X /= (1..5 => (1, (1, 1))) THEN
177
                              COMMENT ("IRRELEVANT");
178
                         END IF;
179
                    END;
180
               EXCEPTION
181
                    WHEN CONSTRAINT_ERROR =>
182
                         NULL;
183
                    WHEN OTHERS =>
184
                         FAILED ("UNEXPECTED EXCEPTION RAISED - 4");
185
               END;
186
          EXCEPTION
187
               WHEN OTHERS =>
188
                    FAILED ("CONSTRAINT CHECKED TOO SOON - 4");
189
          END;
190
 
191
          BEGIN
192
               DECLARE
193
                    TYPE NREC IS
194
                         RECORD
195
                              C1 : CONS;
196
                         END RECORD;
197
               BEGIN
198
                    DECLARE
199
                         X : NREC;
200
                    BEGIN
201
                         FAILED ("DISCRIMINANT CHECK NOT " &
202
                                 "PERFORMED - 5");
203
                         IF X /= (C1 => (1, (1, 1))) THEN
204
                              COMMENT ("IRRELEVANT");
205
                         END IF;
206
                    END;
207
               EXCEPTION
208
                    WHEN CONSTRAINT_ERROR =>
209
                         NULL;
210
                    WHEN OTHERS =>
211
                         FAILED ("UNEXPECTED EXCEPTION RAISED - 5");
212
               END;
213
          EXCEPTION
214
               WHEN OTHERS =>
215
                    FAILED ("CONSTRAINT CHECKED TOO SOON - 5");
216
          END;
217
 
218
          BEGIN
219
               DECLARE
220
                    TYPE DREC IS NEW CONS;
221
               BEGIN
222
                    DECLARE
223
                         X : DREC;
224
                    BEGIN
225
                         FAILED ("DISCRIMINANT CHECK NOT " &
226
                                 "PERFORMED - 6");
227
                         IF X /= (1, (1, 1)) THEN
228
                              COMMENT ("IRRELEVANT");
229
                         END IF;
230
                    END;
231
               EXCEPTION
232
                    WHEN CONSTRAINT_ERROR =>
233
                         NULL;
234
                    WHEN OTHERS =>
235
                         FAILED ("UNEXPECTED EXCEPTION RAISED - 6");
236
               END;
237
          EXCEPTION
238
               WHEN OTHERS =>
239
                    FAILED ("CONSTRAINT CHECKED TOO SOON - 6");
240
          END;
241
 
242
     END;
243
 
244
-- CASE C2 : COMPONENT IS ABSENT
245
 
246
     F1_CONS := 2;
247
 
248
     DECLARE
249
          TYPE CONS (D3 : INTEGER := IDENT_INT(-6)) IS
250
               RECORD
251
                    CASE D3 IS
252
                         WHEN -5..10 =>
253
                              C1 : REC (D3, F1);       -- F1 EVALUATED
254
                         WHEN OTHERS =>
255
                              C2 : INTEGER := IDENT_INT(0);
256
                    END CASE;
257
               END RECORD;
258
          CHK1 : BOOLEAN := CHK (F1_CONS, 1, "F1 NOT EVALUATED - 2");
259
          X : CONS;             -- F1 NOT EVALUATED AGAIN
260
          Y : CONS;             -- F1 NOT EVALUATED AGAIN
261
          CHK2 : BOOLEAN := CHK (F1_CONS, 1, "F1 EVALUATED - 2");
262
     BEGIN
263
          IF X /= (-6, 0) OR Y /= (-6, 0) THEN
264
               FAILED ("DISCRIMINANT VALUES NOT CORRECT");
265
          END IF;
266
     END;
267
 
268
     F1_CONS := 12;
269
 
270
     DECLARE
271
          TYPE CONS (D3 : INTEGER := IDENT_INT(11)) IS
272
               RECORD
273
                    CASE D3 IS
274
                         WHEN -5..10 =>
275
                              C1 : REC(D3, F1);
276
                         WHEN OTHERS =>
277
                              C2 : INTEGER := IDENT_INT(0);
278
                    END CASE;
279
               END RECORD;
280
     BEGIN
281
          BEGIN
282
               DECLARE
283
                    X : CONS;
284
               BEGIN
285
                    IF X /= (11, 0) THEN
286
                         FAILED ("WRONG VALUE FOR X - 11");
287
                    END IF;
288
               END;
289
          EXCEPTION
290
               WHEN OTHERS =>
291
                    FAILED ("NONEXISTENT CONSTRAINT CHECKED - 11");
292
          END;
293
 
294
          BEGIN
295
               DECLARE
296
                    SUBTYPE SCONS IS CONS;
297
               BEGIN
298
                    DECLARE
299
                         X : SCONS;
300
                    BEGIN
301
                         IF X /= (11, 0) THEN
302
                              FAILED ("X VALUE WRONG - 12");
303
                         END IF;
304
                    END;
305
               END;
306
          EXCEPTION
307
               WHEN OTHERS =>
308
                    FAILED ("NONEXISTENT CONSTRAINT CHECKED - 12");
309
          END;
310
 
311
          BEGIN
312
               DECLARE
313
                    TYPE ARR IS ARRAY (1..5) OF CONS;
314
                    X : ARR;
315
               BEGIN
316
                    IF X /= (1..5 => (11, 0)) THEN
317
                         FAILED ("X VALUE INCORRECT - 13");
318
                    END IF;
319
               END;
320
          EXCEPTION
321
               WHEN OTHERS =>
322
                    FAILED ("NONEXISTENT CONSTRAINT CHECKED - 13");
323
          END;
324
 
325
          BEGIN
326
               DECLARE
327
                    TYPE NREC IS
328
                         RECORD
329
                              C1 : CONS;
330
                         END RECORD;
331
                    X : NREC;
332
               BEGIN
333
                    IF X /= (C1 => (11, 0)) THEN
334
                         FAILED ("X VALUE IS INCORRECT - 14");
335
                    END IF;
336
               END;
337
          EXCEPTION
338
               WHEN OTHERS =>
339
                    FAILED ("NONEXISTENT CONSTRAINT CHECKED - 14");
340
          END;
341
 
342
          BEGIN
343
               DECLARE
344
                    TYPE NREC IS NEW CONS;
345
                    X : NREC;
346
               BEGIN
347
                    IF X /= (11, 0) THEN
348
                         FAILED ("X VALUE INCORRECT - 15");
349
                    END IF;
350
               END;
351
          EXCEPTION
352
               WHEN OTHERS =>
353
                    FAILED ("NONEXISTENT CONSTRAINT CHECKED - 15");
354
          END;
355
 
356
          BEGIN
357
               DECLARE
358
                    TYPE ACC_CONS IS ACCESS CONS;
359
                    X : ACC_CONS := NEW CONS;
360
               BEGIN
361
                    IF X.ALL /= (11, 0) THEN
362
                         FAILED ("X VALUE INCORRECT - 17");
363
                    END IF;
364
               END;
365
          EXCEPTION
366
               WHEN OTHERS =>
367
                    FAILED ("NONEXISTENT CONSTRAINT CHECKED - 17");
368
          END;
369
     END;
370
 
371
 
372
     RESULT;
373
 
374
EXCEPTION
375
     WHEN OTHERS =>
376
          FAILED ("CONSTRAINT CHECK DONE TOO EARLY");
377
          RESULT;
378
 
379
END C37213F;

powered by: WebSVN 2.1.0

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