OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c3/] [c34007g.ada] - Blame information for rev 720

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 720 jeremybenn
-- C34007G.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 THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED
27
--     (IMPLICITLY) FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE IS A
28
--     MULTI-DIMENSIONAL ARRAY TYPE.
29
 
30
-- HISTORY:
31
--     JRK 09/25/86  CREATED ORIGINAL TEST.
32
--     BCB 10/21/87  CHANGED HEADER TO STANDARD FORMAT.  REVISED TEST SO
33
--                   T'STORAGE_SIZE IS NOT REQUIRED TO BE > 1.
34
--     BCB 03/07/90  PUT CHECK FOR 'STORAGE_SIZE IN EXCEPTION HANDLER.
35
--     THS 09/18/90  REMOVED DECLARATION OF B, MADE THE BODY OF
36
--                   PROCEDURE A NULL, AND DELETED ALL REFERENCES TO B.
37
--     PWN 01/31/95  REMOVED INCONSISTENCIES WITH ADA 9X.
38
 
39
WITH SYSTEM; USE SYSTEM;
40
WITH REPORT; USE REPORT;
41
 
42
PROCEDURE C34007G IS
43
 
44
     SUBTYPE COMPONENT IS INTEGER;
45
 
46
     TYPE DESIGNATED IS ARRAY (NATURAL RANGE <>, NATURAL RANGE <>) OF
47
                              COMPONENT;
48
 
49
     SUBTYPE SUBDESIGNATED IS DESIGNATED
50
                                   (IDENT_INT (4) .. IDENT_INT (5),
51
                                    IDENT_INT (6) .. IDENT_INT (8));
52
 
53
     PACKAGE PKG IS
54
 
55
          TYPE PARENT IS ACCESS DESIGNATED;
56
 
57
          FUNCTION CREATE ( F1, L1 : NATURAL;
58
                            F2, L2 : NATURAL;
59
                            C      : COMPONENT;
60
                            DUMMY  : PARENT   -- TO RESOLVE OVERLOADING.
61
                          ) RETURN PARENT;
62
 
63
     END PKG;
64
 
65
     USE PKG;
66
 
67
     TYPE T IS NEW PARENT (IDENT_INT (4) .. IDENT_INT (5),
68
                           IDENT_INT (6) .. IDENT_INT (8));
69
 
70
     X : T         := NEW SUBDESIGNATED'(OTHERS => (OTHERS => 2));
71
     Y : T         := NEW SUBDESIGNATED'((1, 2, 3), (4, 5, 6));
72
     W : PARENT    := NEW SUBDESIGNATED'(OTHERS => (OTHERS => 2));
73
     C : COMPONENT := 1;
74
     N : CONSTANT  := 2;
75
 
76
     PROCEDURE A (X : ADDRESS) IS
77
     BEGIN
78
          NULL;
79
     END A;
80
 
81
     FUNCTION V RETURN T IS
82
     BEGIN
83
          RETURN NEW SUBDESIGNATED'(OTHERS => (OTHERS => C));
84
     END V;
85
 
86
     PACKAGE BODY PKG IS
87
 
88
          FUNCTION CREATE
89
             ( F1, L1 : NATURAL;
90
               F2, L2 : NATURAL;
91
               C      : COMPONENT;
92
               DUMMY  : PARENT
93
             ) RETURN PARENT
94
          IS
95
               A : PARENT    := NEW DESIGNATED (F1 .. L1, F2 .. L2);
96
               B : COMPONENT := C;
97
          BEGIN
98
               FOR I IN F1 .. L1 LOOP
99
                    FOR J IN F2 .. L2 LOOP
100
                         A (I, J) := B;
101
                         B := B + 1;
102
                    END LOOP;
103
               END LOOP;
104
               RETURN A;
105
          END CREATE;
106
 
107
     END PKG;
108
 
109
     FUNCTION IDENT (X : T) RETURN T IS
110
     BEGIN
111
          IF X = NULL OR ELSE
112
             EQUAL (X'LENGTH, X'LENGTH) THEN
113
               RETURN X;                          -- ALWAYS EXECUTED.
114
          END IF;
115
          RETURN NEW SUBDESIGNATED;
116
     END IDENT;
117
 
118
BEGIN
119
     TEST ("C34007G", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
120
                      "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
121
                      "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " &
122
                      "MULTI-DIMENSIONAL ARRAY TYPE");
123
 
124
     IF Y = NULL OR ELSE Y.ALL /= ((1, 2, 3), (4, 5, 6)) THEN
125
          FAILED ("INCORRECT INITIALIZATION");
126
     END IF;
127
 
128
     X := IDENT (Y);
129
     IF X /= Y THEN
130
          FAILED ("INCORRECT :=");
131
     END IF;
132
 
133
     IF T'(X) /= Y THEN
134
          FAILED ("INCORRECT QUALIFICATION");
135
     END IF;
136
 
137
     IF T (X) /= Y THEN
138
          FAILED ("INCORRECT SELF CONVERSION");
139
     END IF;
140
 
141
     IF EQUAL (3, 3) THEN
142
          W := NEW SUBDESIGNATED'((1, 2, 3), (4, 5, 6));
143
     END IF;
144
     X := T (W);
145
     IF X = NULL OR ELSE X = Y OR ELSE
146
        X.ALL /= ((1, 2, 3), (4, 5, 6)) THEN
147
          FAILED ("INCORRECT CONVERSION FROM PARENT");
148
     END IF;
149
 
150
     X := IDENT (Y);
151
     W := PARENT (X);
152
     IF W = NULL OR ELSE W.ALL /= ((1, 2, 3), (4, 5, 6)) OR ELSE
153
        T (W) /= Y THEN
154
          FAILED ("INCORRECT CONVERSION TO PARENT - 1");
155
     END IF;
156
 
157
     W := PARENT (CREATE (6, 9, 2, 3, 4, X));
158
     IF W = NULL OR ELSE
159
        W.ALL /= ((4, 5), (6, 7), (8, 9), (10, 11)) THEN
160
          FAILED ("INCORRECT CONVERSION TO PARENT - 2");
161
     END IF;
162
 
163
     IF IDENT (NULL) /= NULL OR X = NULL THEN
164
          FAILED ("INCORRECT NULL");
165
     END IF;
166
 
167
     X := IDENT (NEW SUBDESIGNATED'((1, 2, 3), (4, 5, 6)));
168
     IF (X = NULL OR ELSE X = Y OR ELSE
169
         X.ALL /= ((1, 2, 3), (4, 5, 6))) OR
170
        X = NEW DESIGNATED'((1, 2), (3, 4), (5, 6)) THEN
171
          FAILED ("INCORRECT ALLOCATOR");
172
     END IF;
173
 
174
     X := IDENT (Y);
175
     IF X.ALL /= ((1, 2, 3), (4, 5, 6)) OR
176
        CREATE (6, 9, 2, 3, 4, X) . ALL /=
177
        ((4, 5), (6, 7), (8, 9), (10, 11)) THEN
178
          FAILED ("INCORRECT .ALL (VALUE)");
179
     END IF;
180
 
181
     X.ALL := ((10, 11, 12), (13, 14, 15));
182
     IF X /= Y OR Y.ALL /= ((10, 11, 12), (13, 14, 15)) THEN
183
          FAILED ("INCORRECT .ALL (ASSIGNMENT)");
184
     END IF;
185
 
186
     Y.ALL := ((1, 2, 3), (4, 5, 6));
187
     BEGIN
188
          CREATE (6, 9, 2, 3, 4, X) . ALL :=
189
               ((20, 21), (22, 23), (24, 25), (26, 27));
190
     EXCEPTION
191
          WHEN OTHERS =>
192
               FAILED ("EXCEPTION FOR .ALL (ASSIGNMENT)");
193
     END;
194
 
195
     X := IDENT (NULL);
196
     BEGIN
197
          IF X.ALL = ((0, 0, 0), (0, 0, 0)) THEN
198
               FAILED ("NO EXCEPTION FOR NULL.ALL - 1");
199
          ELSE FAILED ("NO EXCEPTION FOR NULL.ALL - 2");
200
          END IF;
201
     EXCEPTION
202
          WHEN CONSTRAINT_ERROR =>
203
               NULL;
204
          WHEN OTHERS =>
205
               FAILED ("WRONG EXCEPTION FOR NULL.ALL");
206
     END;
207
 
208
     X := IDENT (Y);
209
     IF X (IDENT_INT (4), IDENT_INT (6)) /= 1 OR
210
        CREATE (6, 9, 2, 3, 4, X) (9, 3) /= 11 THEN
211
          FAILED ("INCORRECT INDEX (VALUE)");
212
     END IF;
213
 
214
     X (IDENT_INT (5), IDENT_INT (8)) := 7;
215
     IF X /= Y OR Y.ALL /= ((1, 2, 3), (4, 5, 7)) THEN
216
          FAILED ("INCORRECT INDEX (ASSIGNMENT)");
217
     END IF;
218
 
219
     Y.ALL := ((1, 2, 3), (4, 5, 6));
220
     X := IDENT (Y);
221
     BEGIN
222
          CREATE (6, 9, 2, 3, 4, X) (6, 2) := 15;
223
     EXCEPTION
224
          WHEN OTHERS =>
225
               FAILED ("EXCEPTION FOR INDEX (ASSIGNMENT)");
226
     END;
227
 
228
     IF X = NULL OR X = NEW SUBDESIGNATED OR NOT (X = Y) OR
229
        X = CREATE (6, 9, 2, 3, 4, X) THEN
230
          FAILED ("INCORRECT =");
231
     END IF;
232
 
233
     IF X /= Y OR NOT (X /= NULL) OR
234
        NOT (X /= CREATE (7, 9, 2, 4, 1, X)) THEN
235
          FAILED ("INCORRECT /=");
236
     END IF;
237
 
238
     IF NOT (X IN T) OR CREATE (2, 3, 4, 5, 1, X) IN T THEN
239
          FAILED ("INCORRECT ""IN""");
240
     END IF;
241
 
242
     IF X NOT IN T OR NOT (CREATE (7, 9, 2, 4, 1, X) NOT IN T) THEN
243
          FAILED ("INCORRECT ""NOT IN""");
244
     END IF;
245
 
246
     A (X'ADDRESS);
247
 
248
     IF X'FIRST /= 4 THEN
249
          FAILED ("INCORRECT OBJECT'FIRST");
250
     END IF;
251
 
252
     IF V'FIRST /= 4 THEN
253
          FAILED ("INCORRECT VALUE'FIRST");
254
     END IF;
255
 
256
     IF X'FIRST (N) /= 6 THEN
257
          FAILED ("INCORRECT OBJECT'FIRST (N)");
258
     END IF;
259
 
260
     IF V'FIRST (N) /= 6 THEN
261
          FAILED ("INCORRECT VALUE'FIRST (N)");
262
     END IF;
263
 
264
     IF X'LAST /= 5 THEN
265
          FAILED ("INCORRECT OBJECT'LAST");
266
     END IF;
267
 
268
     IF V'LAST /= 5 THEN
269
          FAILED ("INCORRECT VALUE'LAST");
270
     END IF;
271
 
272
     IF X'LAST (N) /= 8 THEN
273
          FAILED ("INCORRECT OBJECT'LAST (N)");
274
     END IF;
275
 
276
     IF V'LAST (N) /= 8 THEN
277
          FAILED ("INCORRECT VALUE'LAST (N)");
278
     END IF;
279
 
280
     IF X'LENGTH /= 2 THEN
281
          FAILED ("INCORRECT OBJECT'LENGTH");
282
     END IF;
283
 
284
     IF V'LENGTH /= 2 THEN
285
          FAILED ("INCORRECT VALUE'LENGTH");
286
     END IF;
287
 
288
     IF X'LENGTH (N) /= 3 THEN
289
          FAILED ("INCORRECT OBJECT'LENGTH (N)");
290
     END IF;
291
 
292
     IF V'LENGTH (N) /= 3 THEN
293
          FAILED ("INCORRECT VALUE'LENGTH (N)");
294
     END IF;
295
 
296
     DECLARE
297
          Y : DESIGNATED (X'RANGE, 1 .. 3);
298
     BEGIN
299
          IF Y'FIRST /= 4 OR Y'LAST /= 5 THEN
300
               FAILED ("INCORRECT OBJECT'RANGE");
301
          END IF;
302
     END;
303
 
304
     DECLARE
305
          Y : DESIGNATED (V'RANGE, 1 .. 3);
306
     BEGIN
307
          IF Y'FIRST /= 4 OR Y'LAST /= 5 THEN
308
               FAILED ("INCORRECT VALUE'RANGE");
309
          END IF;
310
     END;
311
 
312
     DECLARE
313
          Y : DESIGNATED (1 .. 2, X'RANGE (N));
314
     BEGIN
315
          IF Y'FIRST (N) /= 6 OR Y'LAST (N) /= 8 THEN
316
               FAILED ("INCORRECT OBJECT'RANGE (N)");
317
          END IF;
318
     END;
319
 
320
     DECLARE
321
          Y : DESIGNATED (1 .. 2, V'RANGE (N));
322
     BEGIN
323
          IF Y'FIRST (N) /= 6 OR Y'LAST (N) /= 8 THEN
324
               FAILED ("INCORRECT VALUE'RANGE (N)");
325
          END IF;
326
     END;
327
 
328
     IF T'SIZE < 1 THEN
329
          FAILED ("INCORRECT TYPE'SIZE");
330
     END IF;
331
 
332
     IF X'SIZE < T'SIZE THEN
333
          FAILED ("INCORRECT OBJECT'SIZE");
334
     END IF;
335
 
336
     BEGIN
337
          IF T'STORAGE_SIZE /= PARENT'STORAGE_SIZE THEN
338
               FAILED ("COLLECTION SIZE OF DERIVED TYPE IS NOT " &
339
                       "EQUAL TO COLLECTION SIZE OF PARENT TYPE");
340
          END IF;
341
     EXCEPTION
342
          WHEN PROGRAM_ERROR =>
343
               COMMENT ("PROGRAM_ERROR RAISED FOR " &
344
                        "UNDEFINED STORAGE_SIZE (AI-00608)");
345
          WHEN OTHERS =>
346
               FAILED ("UNEXPECTED EXCEPTION RAISED");
347
     END;
348
 
349
     RESULT;
350
END C34007G;

powered by: WebSVN 2.1.0

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