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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 149 jeremybenn
-- C48008A.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
-- FOR ALLOCATORS OF THE FORM "NEW T X", CHECK THAT CONSTRAINT_ERROR IS
26
-- RAISED IF T IS AN UNCONSTRAINED RECORD, PRIVATE, OR LIMITED TYPE, X
27
-- IS A DISCRIMINANT CONSTRAINT, AND
28
--   1) ONE OF THE VALUES OF X IS OUTSIDE THE RANGE OF THE CORRESPONDING
29
--      DISCRIMINANT;
30
--   2) ONE OF THE DISCRIMINANT VALUES IS NOT COMPATIBLE WITH A
31
--      CONSTRAINT OF A SUBCOMPONENT IN WHICH IT IS USED;
32
--   3) ONE OF THE DISCRIMINANT VALUES DOES NOT EQUAL THE CORRESPONDING
33
--      VALUE OF THE ALLOCATOR'S BASE TYPE;
34
--   4) A DEFAULT INITIALIZATION RAISES AN EXCEPTION.
35
 
36
-- RM  01/08/80
37
-- NL  10/13/81
38
-- SPS 10/26/82
39
-- JBG 03/02/83
40
-- EG  07/05/84
41
-- PWB 02/05/86  CORRECTED TEST ERROR:
42
--               CHANGED "FAILED" TO "COMMENT" IN PROCEDURE INCR_CHECK,
43
--               SO AS NOT TO PROHIBIT EVAL OF DEFLT EXPR (AI-00397/01)
44
--               ADDED COMMENTS FOR CASES.
45
 
46
WITH REPORT;
47
 
48
PROCEDURE  C48008A  IS
49
 
50
     USE REPORT;
51
 
52
BEGIN
53
 
54
     TEST( "C48008A" , "FOR ALLOCATORS OF THE FORM 'NEW T X', " &
55
                       "CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN " &
56
                       "APPROPRIATE - UNCONSTRAINED RECORD AND " &
57
                       "PRIVATE TYPES");
58
 
59
     DECLARE
60
 
61
          DISC_FLAG : BOOLEAN := FALSE;
62
          INCR_VAL : INTEGER;
63
          FUNCTION INCR(A : INTEGER) RETURN INTEGER;
64
 
65
          SUBTYPE I1_7 IS INTEGER RANGE IDENT_INT(1)..IDENT_INT(7);
66
          SUBTYPE I1_10 IS INTEGER RANGE IDENT_INT(1)..IDENT_INT(10);
67
          SUBTYPE I2_9 IS INTEGER RANGE IDENT_INT(2)..IDENT_INT(9);
68
 
69
          TYPE REC (A : I2_9) IS
70
               RECORD
71
                    B : INTEGER := INCR(2);
72
               END RECORD;
73
 
74
          TYPE ARR IS ARRAY (I2_9 RANGE <>) OF INTEGER;
75
 
76
          TYPE T_REC (C : I1_10) IS
77
               RECORD
78
                    D : REC(C);
79
               END RECORD;
80
 
81
          TYPE T_ARR (C : I1_10) IS
82
               RECORD
83
                    D : ARR(2..C);
84
                    E : ARR(C..9);
85
               END RECORD;
86
 
87
          TYPE T_REC_REC (A : I1_10) IS
88
               RECORD
89
                    B : T_REC(A);
90
               END RECORD;
91
 
92
          TYPE T_REC_ARR (A : I1_10) IS
93
               RECORD
94
                    B : T_ARR(A);
95
               END RECORD;
96
 
97
          TYPE  TB (  A : I1_7 )  IS
98
               RECORD
99
                    R : INTEGER := INCR(1);
100
               END RECORD;
101
 
102
          TYPE UR (A : INTEGER) IS
103
               RECORD
104
                    B : I2_9 := INCR(1);
105
               END RECORD;
106
 
107
          TYPE A_T_REC_REC IS ACCESS T_REC_REC;
108
          TYPE A_T_REC_ARR IS ACCESS T_REC_ARR;
109
          TYPE ATB IS ACCESS TB;
110
          TYPE ACTB IS ACCESS TB(3);
111
          TYPE A_UR IS ACCESS UR;
112
 
113
          VA_T_REC_REC : A_T_REC_REC;
114
          VA_T_REC_ARR : A_T_REC_ARR;
115
          VB  : ATB;
116
          VCB : ACTB;
117
          V_A_UR : A_UR;
118
 
119
          BOOL : BOOLEAN;
120
 
121
          FUNCTION DISC (A : INTEGER) RETURN INTEGER;
122
 
123
 
124
          PACKAGE  P  IS
125
               TYPE  PRIV( A : I1_10 := DISC(8) )  IS PRIVATE;
126
               CONS_PRIV : CONSTANT PRIV;
127
          PRIVATE
128
               TYPE  PRIV( A : I1_10 := DISC(8) )  IS
129
                    RECORD
130
                         R : INTEGER := INCR(1);
131
                    END RECORD;
132
               CONS_PRIV : CONSTANT PRIV := (2, 3);
133
          END P;
134
 
135
          TYPE  A_PRIV  IS  ACCESS P.PRIV;
136
          TYPE  A_CPRIV IS  ACCESS P.PRIV (3);
137
 
138
          VP  : A_PRIV;
139
          VCP : A_CPRIV;
140
 
141
          PROCEDURE PREC_REC (X : A_T_REC_REC) IS
142
          BEGIN
143
               NULL;
144
          END PREC_REC;
145
 
146
          PROCEDURE PREC_ARR (X : A_T_REC_ARR) IS
147
          BEGIN
148
               NULL;
149
          END PREC_ARR;
150
 
151
          PROCEDURE PB (X : ATB) IS
152
          BEGIN
153
               NULL;
154
          END PB;
155
 
156
          PROCEDURE PCB (X : ACTB) IS
157
          BEGIN
158
               NULL;
159
          END PCB;
160
 
161
          PROCEDURE PPRIV (X : A_PRIV) IS
162
          BEGIN
163
               NULL;
164
          END PPRIV;
165
 
166
          PROCEDURE PCPRIV (X : A_CPRIV) IS
167
          BEGIN
168
               NULL;
169
          END PCPRIV;
170
 
171
          FUNCTION DISC (A : INTEGER) RETURN INTEGER IS
172
          BEGIN
173
               DISC_FLAG := TRUE;
174
               RETURN A;
175
          END DISC;
176
 
177
          FUNCTION INCR(A : INTEGER) RETURN INTEGER IS
178
          BEGIN
179
               INCR_VAL := IDENT_INT(INCR_VAL+1);
180
               RETURN A;
181
          END INCR;
182
 
183
          PROCEDURE INCR_CHECK(CASE_ID : STRING) IS
184
          BEGIN
185
               IF INCR_VAL /= IDENT_INT(0) THEN
186
                    COMMENT ("DEFAULT INITIAL VALUE WAS EVALUATED - " &
187
                             "CASE " & CASE_ID);
188
               END IF;
189
          END INCR_CHECK;
190
 
191
     BEGIN
192
 
193
          BEGIN  -- A1A: 0 ILLEGAL FOR TB.A.
194
               INCR_VAL := 0;
195
               VB  :=  NEW TB (A => 0);
196
               FAILED ("NO EXCEPTION RAISED - CASE A1A");
197
          EXCEPTION
198
               WHEN  CONSTRAINT_ERROR  =>
199
                    INCR_CHECK("A1A");
200
               WHEN  OTHERS            =>
201
                    FAILED( "WRONG EXCEPTION RAISED - CASE A1A" );
202
          END;   -- A1A
203
 
204
          BEGIN  -- A1B: 8 ILLEGAL IN I1_7.
205
               INCR_VAL := 0;
206
               VB  :=  NEW TB (A => I1_7'(IDENT_INT(8)));
207
               FAILED ("NO EXCEPTION RAISED - CASE A1B");
208
          EXCEPTION
209
               WHEN  CONSTRAINT_ERROR  =>
210
                    INCR_CHECK("A1B");
211
               WHEN  OTHERS            =>
212
                    FAILED( "WRONG EXCEPTION RAISED - CASE A1B");
213
          END;   -- A1B
214
 
215
          BEGIN  -- A1C: 8 ILLEGAL FOR TB.A.
216
               INCR_VAL := 0;
217
               PB(NEW TB (A => 8));
218
               FAILED ("NO EXCEPTION RAISED - CASE A1C");
219
          EXCEPTION
220
               WHEN  CONSTRAINT_ERROR  =>
221
                    INCR_CHECK("A1C");
222
               WHEN  OTHERS            =>
223
                    FAILED( "WRONG EXCEPTION RAISED - CASE A1C");
224
          END;   --A1C
225
 
226
          BEGIN  --A1D: 0 ILLEGAL FOR TB.A.
227
               INCR_VAL := 0;
228
               BOOL := ATB'(NEW TB(A => 0)) = NULL;
229
               FAILED ("NO EXCEPTION RAISED - CASE A1D");
230
          EXCEPTION
231
               WHEN  CONSTRAINT_ERROR  =>
232
                    INCR_CHECK("A1D");
233
               WHEN  OTHERS            =>
234
                    FAILED( "WRONG EXCEPTION RAISED - CASE A1D");
235
          END;   --A1D
236
 
237
          BEGIN  --A1E: 11 ILLEGAL FOR PRIV.A.
238
               DISC_FLAG := FALSE;
239
               INCR_VAL := 0;
240
               VP := NEW P.PRIV(11);
241
               FAILED("NO EXCEPTION RAISED - CASE A1E");
242
          EXCEPTION
243
               WHEN CONSTRAINT_ERROR =>
244
                    IF DISC_FLAG THEN
245
                         FAILED ("DISCR DEFAULT EVALUATED WHEN " &
246
                                 "EXPLICIT VALUE WAS PROVIDED - A1E");
247
                    END IF;
248
                    INCR_CHECK("A1E");
249
               WHEN OTHERS           =>
250
                    FAILED("WRONG EXCEPTION RAISED - CASE A1E");
251
          END;   -- A1E
252
 
253
          BEGIN  -- A2A: 1 ILLEGAL FOR REC.A.
254
               INCR_VAL := 0;
255
               VA_T_REC_REC := NEW T_REC_REC(A => I1_10'(IDENT_INT(1)));
256
               FAILED ("NO EXCEPTION RAISED - CASE A2A");
257
          EXCEPTION
258
               WHEN CONSTRAINT_ERROR =>
259
                    INCR_CHECK("A2A");
260
               WHEN OTHERS =>
261
                    FAILED ("WRONG EXCEPTION RAISED - CASE A2A");
262
          END;   -- A2A
263
 
264
          BEGIN  --A2B: 10 ILLEGAL FOR REC.A.
265
               INCR_VAL := 0;
266
               VA_T_REC_REC := NEW T_REC_REC (10);
267
               FAILED ("NO EXCEPTION RAISED - CASE A2B");
268
          EXCEPTION
269
               WHEN CONSTRAINT_ERROR =>
270
                    INCR_CHECK("A2B");
271
               WHEN OTHERS =>
272
                    FAILED ("WRONG EXCEPTION RAISED - CASE A2B");
273
          END;   -- A2B
274
 
275
          BEGIN  -- A2C: 1 ILLEGAL FOR T.ARR.E'FIRST.
276
               INCR_VAL := 0;
277
               PREC_ARR (NEW T_REC_ARR (1));
278
               FAILED ("NO EXCEPTION RAISED - CASE A2C");
279
          EXCEPTION
280
               WHEN CONSTRAINT_ERROR =>
281
                    INCR_CHECK ("A2C");
282
               WHEN OTHERS =>
283
                    FAILED ("WRONG EXCEPTION RAISED - CASE A2C");
284
          END;   -- A2C
285
 
286
          BEGIN  -- A2D: 10 ILLEGAL FOR T_ARR.D'LAST.
287
               INCR_VAL := 0;
288
               BOOL := NEW T_REC_ARR (IDENT_INT(10)) = NULL;
289
               FAILED ("NO EXCEPTION RAISED - CASE A2D");
290
          EXCEPTION
291
               WHEN CONSTRAINT_ERROR =>
292
                    INCR_CHECK ("A2D");
293
               WHEN OTHERS =>
294
                    FAILED ("WRONG EXCEPTION RAISED - CASE A2D");
295
          END;   -- A2D
296
 
297
          BEGIN -- A3A: ASSIGNMENT VIOLATES CONSTRAINT ON VCB'S SUBTYPE.
298
               INCR_VAL := 0;
299
               VCB := NEW TB (4);
300
               FAILED ("NO EXCEPTION RAISED - CASE A3A");
301
          EXCEPTION
302
               WHEN CONSTRAINT_ERROR =>
303
                    INCR_CHECK("A3A");
304
               WHEN OTHERS =>
305
                    FAILED ("WRONG EXCEPTION RAISED - CASE A3A");
306
          END;   -- A3A
307
 
308
          BEGIN  -- A3B: PARM ASSOC VIOLATES CONSTRAINT ON PARM SUBTYPE.
309
               INCR_VAL := 0;
310
               PCB (NEW TB (4));
311
               FAILED ("NO EXCEPTION RAISED - CASE A3B");
312
          EXCEPTION
313
               WHEN CONSTRAINT_ERROR =>
314
                    INCR_CHECK("A3B");
315
               WHEN OTHERS =>
316
                    FAILED ("WRONG EXCEPTION RAISED - CASE A3B");
317
          END;   -- A3B
318
 
319
          BEGIN  -- A3C: 2 VIOLATES CONSTRAINT ON SUBTYPE ACTB.
320
               INCR_VAL := 0;
321
               BOOL := ACTB'(NEW TB (IDENT_INT(2))) = NULL;
322
               FAILED ("NO EXCEPTION RAISED - CASE A3C");
323
          EXCEPTION
324
               WHEN CONSTRAINT_ERROR =>
325
                    INCR_CHECK("A3C");
326
               WHEN OTHERS =>
327
                    FAILED ("WRONG EXCEPTION RAISED - CASE A3C");
328
          END;   -- A3C
329
 
330
          BEGIN  -- A4A: EVALUATION OF DEFAULT RAISES EXCEPTION.
331
               INCR_VAL := 0;
332
               V_A_UR := NEW UR(4);
333
               FAILED ("NO EXCEPTION RAISED - CASE A4A");
334
          EXCEPTION
335
               WHEN CONSTRAINT_ERROR =>
336
                    NULL;
337
               WHEN OTHERS =>
338
                    FAILED ("WRONG EXCEPTION RAISED - CASE A4A");
339
          END;   -- A4A
340
 
341
     END;
342
 
343
     RESULT;
344
 
345
END C48008A;

powered by: WebSVN 2.1.0

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