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

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

Line No. Rev Author Line
1 149 jeremybenn
-- C48009B.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
26
-- IS RAISED IF T IS AN UNCONSTRAINED RECORD OR PRIVATE TYPE, (X) IS AN
27
-- AGGREGATE OR A VALUE OF TYPE T, AND ONE OF THE DISCRIMINANT VALUES IN
28
-- X:
29
--   1) DOES NOT SATISFY THE RANGE CONSTRAINT FOR THE CORRESPONDING
30
--      DISCRIMINANT OF T.
31
--   2) DOES NOT EQUAL THE DISCRIMINANT VALUE SPECIFIED IN THE
32
--      DECLARATION OF THE ALLOCATOR'S BASE TYPE.
33
--   3) A DISCRIMINANT VALUE IS COMPATIBLE WITH A DISCRIMINANT'S SUBTYPE
34
--      BUT DOES NOT PROVIDE A COMPATIBLE INDEX OR DISCRIMINANT
35
--      CONSTRAINT FOR A SUBCOMPONENT DEPENDENT ON THE DISCRIMINANT.
36
 
37
-- RM  01/08/80
38
-- NL  10/13/81
39
-- SPS 10/26/82
40
-- JBG 03/02/83
41
-- EG  07/05/84
42
 
43
WITH REPORT;
44
 
45
PROCEDURE  C48009B  IS
46
 
47
     USE REPORT;
48
 
49
BEGIN
50
 
51
     TEST( "C48009B" , "FOR ALLOCATORS OF THE FORM 'NEW T '(X)', " &
52
                       "CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN " &
53
                       "APPROPRIATE - UNCONSTRAINED RECORD AND " &
54
                       "PRIVATE TYPES");
55
 
56
     DECLARE
57
 
58
          SUBTYPE I1_7 IS INTEGER RANGE IDENT_INT(1)..IDENT_INT(7);
59
          SUBTYPE I1_10 IS INTEGER RANGE IDENT_INT(1)..IDENT_INT(10);
60
          SUBTYPE I2_9 IS INTEGER RANGE IDENT_INT(2)..IDENT_INT(9);
61
 
62
          TYPE REC (A : I2_9) IS
63
               RECORD
64
                    NULL;
65
               END RECORD;
66
 
67
          TYPE ARR IS ARRAY (I2_9 RANGE <>) OF INTEGER;
68
 
69
          TYPE T_REC (C : I1_10) IS
70
               RECORD
71
                    D : REC(C);
72
               END RECORD;
73
 
74
          TYPE T_ARR (C : I1_10) IS
75
               RECORD
76
                    D : ARR(2..C);
77
                    E : ARR(C..9);
78
               END RECORD;
79
 
80
          TYPE T_REC_REC (A : I1_10) IS
81
               RECORD
82
                    B : T_REC(A);
83
               END RECORD;
84
 
85
          TYPE T_REC_ARR (A : I1_10) IS
86
               RECORD
87
                    B : T_ARR(A);
88
               END RECORD;
89
 
90
          TYPE  TB (  A : I1_7 )  IS
91
               RECORD
92
                    R : INTEGER;
93
               END RECORD;
94
 
95
          TYPE A_T_REC_REC IS ACCESS T_REC_REC;
96
          TYPE A_T_REC_ARR IS ACCESS T_REC_ARR;
97
          TYPE ATB IS ACCESS TB;
98
          TYPE ACTB IS ACCESS TB(3);
99
 
100
          VA_T_REC_REC : A_T_REC_REC;
101
          VA_T_REC_ARR : A_T_REC_ARR;
102
          VB  : ATB;
103
          VCB : ACTB;
104
 
105
          PACKAGE  P  IS
106
               TYPE  PRIV( A : I1_10 )  IS PRIVATE;
107
               CONS_PRIV : CONSTANT PRIV;
108
          PRIVATE
109
               TYPE  PRIV( A : I1_10 )  IS
110
                    RECORD
111
                         R : INTEGER;
112
                    END RECORD;
113
               CONS_PRIV : CONSTANT PRIV := (2, 3);
114
          END P;
115
 
116
          USE P;
117
 
118
          TYPE  A_PRIV  IS  ACCESS P.PRIV;
119
          TYPE  A_CPRIV IS  ACCESS P.PRIV (3);
120
 
121
          VP  : A_PRIV;
122
          VCP : A_CPRIV;
123
 
124
          FUNCTION ALLOC1(X : P.PRIV) RETURN A_CPRIV IS
125
          BEGIN
126
               IF EQUAL(1, 1) THEN
127
                    RETURN NEW P.PRIV'(X);
128
               ELSE
129
                    RETURN NULL;
130
               END IF;
131
          END ALLOC1;
132
          FUNCTION ALLOC2(X : TB) RETURN ACTB IS
133
          BEGIN
134
               IF EQUAL(1, 1) THEN
135
                    RETURN NEW TB'(X);
136
               ELSE
137
                    RETURN NULL;
138
               END IF;
139
          END ALLOC2;
140
 
141
     BEGIN
142
 
143
          BEGIN     -- B1
144
               VB  :=  NEW TB'(A => IDENT_INT(0), R => 1);
145
               FAILED ("NO EXCEPTION RAISED - CASE 1A");
146
          EXCEPTION
147
               WHEN  CONSTRAINT_ERROR  =>  NULL;
148
               WHEN  OTHERS            =>
149
                    FAILED( "WRONG EXCEPTION RAISED - CASE 1A" );
150
          END;
151
 
152
          BEGIN
153
               VB  :=  NEW TB'(A => 8, R => 1);
154
               FAILED ("NO EXCEPTION RAISED - CASE 1B");
155
          EXCEPTION
156
               WHEN  CONSTRAINT_ERROR  =>  NULL;
157
               WHEN  OTHERS            =>
158
                    FAILED( "WRONG EXCEPTION RAISED - CASE 1B");
159
          END; -- B1
160
 
161
          BEGIN     -- B2
162
               VCB := NEW TB'(2, 3);
163
               FAILED ("NO EXCEPTION RAISED - CASE 2A");
164
          EXCEPTION
165
               WHEN CONSTRAINT_ERROR => NULL;
166
               WHEN OTHERS =>
167
                    FAILED ("WRONG EXCEPTION RAISED - CASE 2A");
168
          END;
169
 
170
          BEGIN
171
               IF ALLOC2((IDENT_INT(4), 3)) = NULL THEN
172
                    FAILED ("IMPOSSIBLE - CASE 2B");
173
               END IF;
174
               FAILED ("NO EXCEPTION RAISED - CASE 2B");
175
          EXCEPTION
176
               WHEN CONSTRAINT_ERROR => NULL;
177
               WHEN OTHERS =>
178
                    FAILED ("WRONG EXCEPTION RAISED - CASE 2B");
179
          END;
180
 
181
          BEGIN
182
 
183
               IF ALLOC1(CONS_PRIV) = NULL THEN
184
                    FAILED ("IMPOSSIBLE - CASE 2C");
185
               END IF;
186
               FAILED ("NO EXCEPTION RAISED - CASE 2C");
187
 
188
          EXCEPTION
189
 
190
               WHEN CONSTRAINT_ERROR => NULL;
191
               WHEN OTHERS =>
192
                    FAILED ("WRONG EXCEPTION RAISED - CASE 2C");
193
 
194
          END; -- B2
195
 
196
          BEGIN     -- B3
197
 
198
               VA_T_REC_REC := NEW T_REC_REC'(1, (1, (A => 1)));
199
               FAILED ("NO EXCEPTION RAISED - CASE 3A");
200
 
201
          EXCEPTION
202
 
203
               WHEN CONSTRAINT_ERROR => NULL;
204
               WHEN OTHERS =>
205
                    FAILED ("WRONG EXCEPTION RAISED - CASE 3A");
206
 
207
          END;
208
 
209
          BEGIN
210
 
211
               VA_T_REC_REC := NEW T_REC_REC'(10,
212
                                             (10, (A => 10)));
213
               FAILED ("NO EXCEPTION RAISED - CASE 3B");
214
 
215
          EXCEPTION
216
 
217
               WHEN CONSTRAINT_ERROR => NULL;
218
               WHEN OTHERS =>
219
                    FAILED ("WRONG EXCEPTION RAISED - CASE 3B");
220
 
221
          END;
222
 
223
          BEGIN
224
 
225
               VA_T_REC_ARR := NEW T_REC_ARR'(1, (1, (OTHERS => 1),
226
                                                     (OTHERS => 2)));
227
               FAILED ("NO EXCEPTION RAISED - CASE 3C");
228
 
229
          EXCEPTION
230
 
231
               WHEN CONSTRAINT_ERROR => NULL;
232
               WHEN OTHERS =>
233
                    FAILED ("WRONG EXCEPTION RAISED - CASE 3C");
234
 
235
          END;
236
 
237
          BEGIN
238
 
239
               VA_T_REC_ARR := NEW T_REC_ARR'(10, (10, (OTHERS => 1),
240
                                                       (OTHERS => 2)));
241
               FAILED ("NO EXCEPTION RAISED - CASE 3D");
242
 
243
          EXCEPTION
244
 
245
               WHEN CONSTRAINT_ERROR => NULL;
246
               WHEN OTHERS =>
247
                    FAILED ("WRONG EXCEPTION RAISED - CASE 3D");
248
 
249
          END;
250
 
251
     END;
252
 
253
     RESULT;
254
 
255
END C48009B;

powered by: WebSVN 2.1.0

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