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/] [c34006j.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
-- C34006J.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 RECORD TYPES WITH DISCRIMINANTS AND WITH
28
--     A LIMITED COMPONENT TYPE.
29
 
30
-- HISTORY:
31
--     JRK 08/25/87  CREATED ORIGINAL TEST.
32
--     VCL 06/28/88  MODIFIED THE STATEMENTS INVOLVING THE 'SIZE
33
--                   ATTRIBUTE TO REMOVE ANY ASSUMPTIONS ABOUT THE
34
--                   SIZES.
35
--     PWN 11/30/94  REMOVED 'BASE USE ILLEGAL IN ADA 9X.
36
 
37
WITH SYSTEM; USE SYSTEM;
38
WITH REPORT; USE REPORT;
39
 
40
PROCEDURE C34006J IS
41
 
42
     PACKAGE PKG_L IS
43
 
44
          TYPE LP IS LIMITED PRIVATE;
45
 
46
          FUNCTION CREATE (X : INTEGER) RETURN LP;
47
 
48
          FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN;
49
 
50
          PROCEDURE ASSIGN (X : OUT LP; Y : LP);
51
 
52
          C4 : CONSTANT LP;
53
          C5 : CONSTANT LP;
54
 
55
     PRIVATE
56
 
57
          TYPE LP IS NEW INTEGER;
58
 
59
          C4 : CONSTANT LP := 4;
60
          C5 : CONSTANT LP := 5;
61
 
62
     END PKG_L;
63
 
64
     USE PKG_L;
65
 
66
     SUBTYPE COMPONENT IS LP;
67
 
68
     PACKAGE PKG_P IS
69
 
70
          MAX_LEN : CONSTANT := 10;
71
 
72
          SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN;
73
 
74
          TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 3) IS
75
               RECORD
76
                    I : INTEGER := 2;
77
                    CASE B IS
78
                         WHEN TRUE =>
79
                              S : STRING (1 .. L) := (1 .. L => 'A');
80
                              C : COMPONENT;
81
                         WHEN FALSE =>
82
                              F : FLOAT := 5.0;
83
                    END CASE;
84
               END RECORD;
85
 
86
          FUNCTION CREATE ( B : BOOLEAN;
87
                            L : LENGTH;
88
                            I : INTEGER;
89
                            S : STRING;
90
                            C : COMPONENT;
91
                            F : FLOAT;
92
                            X : PARENT  -- TO RESOLVE OVERLOADING.
93
                          ) RETURN PARENT;
94
 
95
          FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN;
96
 
97
          FUNCTION AGGR ( B : BOOLEAN;
98
                          L : LENGTH;
99
                          I : INTEGER;
100
                          S : STRING;
101
                          C : COMPONENT
102
                        ) RETURN PARENT;
103
 
104
          FUNCTION AGGR ( B : BOOLEAN;
105
                          L : LENGTH;
106
                          I : INTEGER;
107
                          F : FLOAT
108
                        ) RETURN PARENT;
109
 
110
     END PKG_P;
111
 
112
     USE PKG_P;
113
 
114
     TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3));
115
 
116
     X : T;
117
     W : PARENT;
118
     B : BOOLEAN := FALSE;
119
 
120
     PROCEDURE A (X : ADDRESS) IS
121
     BEGIN
122
          B := IDENT_BOOL (TRUE);
123
     END A;
124
 
125
     PACKAGE BODY PKG_L IS
126
 
127
          FUNCTION CREATE (X : INTEGER) RETURN LP IS
128
          BEGIN
129
               RETURN LP (IDENT_INT (X));
130
          END CREATE;
131
 
132
          FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS
133
          BEGIN
134
               RETURN X = Y;
135
          END EQUAL;
136
 
137
          PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS
138
          BEGIN
139
               X := Y;
140
          END ASSIGN;
141
 
142
     END PKG_L;
143
 
144
     PACKAGE BODY PKG_P IS
145
 
146
          FUNCTION CREATE
147
             ( B : BOOLEAN;
148
               L : LENGTH;
149
               I : INTEGER;
150
               S : STRING;
151
               C : COMPONENT;
152
               F : FLOAT;
153
               X : PARENT
154
             ) RETURN PARENT
155
          IS
156
               A : PARENT (B, L);
157
          BEGIN
158
               A.I := I;
159
               CASE B IS
160
                    WHEN TRUE =>
161
                         A.S := S;
162
                         ASSIGN (A.C, C);
163
                    WHEN FALSE =>
164
                         A.F := F;
165
               END CASE;
166
               RETURN A;
167
          END CREATE;
168
 
169
          FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS
170
          BEGIN
171
               IF X.B /= Y.B OR X.L /= Y.L OR X.I /= Y.I THEN
172
                    RETURN FALSE;
173
               END IF;
174
               CASE X.B IS
175
                    WHEN TRUE =>
176
                         RETURN X.S = Y.S AND EQUAL (X.C, Y.C);
177
                    WHEN FALSE =>
178
                         RETURN X.F = Y.F;
179
               END CASE;
180
          END EQUAL;
181
 
182
          FUNCTION AGGR
183
             ( B : BOOLEAN;
184
               L : LENGTH;
185
               I : INTEGER;
186
               S : STRING;
187
               C : COMPONENT
188
             ) RETURN PARENT
189
          IS
190
               RESULT : PARENT (B, L);
191
          BEGIN
192
               RESULT.I := I;
193
               RESULT.S := S;
194
               ASSIGN (RESULT.C, C);
195
               RETURN RESULT;
196
          END AGGR;
197
 
198
          FUNCTION AGGR
199
             ( B : BOOLEAN;
200
               L : LENGTH;
201
               I : INTEGER;
202
               F : FLOAT
203
             ) RETURN PARENT
204
          IS
205
               RESULT : PARENT (B, L);
206
          BEGIN
207
               RESULT.I := I;
208
               RESULT.F := F;
209
               RETURN RESULT;
210
          END AGGR;
211
 
212
     END PKG_P;
213
 
214
BEGIN
215
     TEST ("C34006J", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
216
                      "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
217
                      "RECORD TYPES WITH DISCRIMINANTS AND WITH A " &
218
                      "LIMITED COMPONENT TYPE");
219
 
220
     X.I := IDENT_INT (1);
221
     X.S := IDENT_STR ("ABC");
222
     ASSIGN (X.C, CREATE (4));
223
 
224
     W.I := IDENT_INT (1);
225
     W.S := IDENT_STR ("ABC");
226
     ASSIGN (W.C, CREATE (4));
227
 
228
     IF NOT EQUAL (T'(X), AGGR (TRUE, 3, 1, "ABC", C4)) THEN
229
          FAILED ("INCORRECT QUALIFICATION");
230
     END IF;
231
 
232
     IF NOT EQUAL (T(X), AGGR (TRUE, 3, 1, "ABC", C4)) THEN
233
          FAILED ("INCORRECT SELF CONVERSION");
234
     END IF;
235
 
236
     IF NOT EQUAL (T(W), AGGR (TRUE, 3, 1, "ABC", C4)) THEN
237
          FAILED ("INCORRECT CONVERSION FROM PARENT");
238
     END IF;
239
 
240
     IF NOT EQUAL (PARENT(X), AGGR (TRUE, 3, 1, "ABC", C4))   OR
241
        NOT EQUAL (PARENT(CREATE (FALSE, 2, 3, "XX", C5, 6.0, X)),
242
                   AGGR (FALSE, 2, 3, 6.0))   THEN
243
          FAILED ("INCORRECT CONVERSION TO PARENT");
244
     END IF;
245
 
246
     IF X.B /= TRUE OR X.L /= 3 OR
247
        CREATE (FALSE, 2, 3, "XX", C5, 6.0, X).B /= FALSE OR
248
        CREATE (FALSE, 2, 3, "XX", C5, 6.0, X).L /= 2 THEN
249
          FAILED ("INCORRECT SELECTION (DISCRIMINANT)");
250
     END IF;
251
 
252
     IF X.I /= 1 OR X.S /= "ABC" OR NOT EQUAL (X.C, C4) OR
253
        CREATE (FALSE, 2, 3, "XX", C5, 6.0, X).I /= 3 OR
254
        CREATE (FALSE, 2, 3, "XX", C5, 6.0, X).F /= 6.0 THEN
255
          FAILED ("INCORRECT SELECTION (VALUE)");
256
     END IF;
257
 
258
     X.I := IDENT_INT (7);
259
     X.S := IDENT_STR ("XYZ");
260
     IF NOT EQUAL (X, AGGR (TRUE, 3, 7, "XYZ", C4)) THEN
261
          FAILED ("INCORRECT SELECTION (ASSIGNMENT)");
262
     END IF;
263
 
264
     X.I := IDENT_INT (1);
265
     X.S := IDENT_STR ("ABC");
266
     IF NOT (X IN T) OR AGGR (FALSE, 2, 3, 6.0) IN T THEN
267
          FAILED ("INCORRECT ""IN""");
268
     END IF;
269
 
270
     IF X NOT IN T OR NOT (AGGR (FALSE, 2, 3, 6.0) NOT IN T) THEN
271
          FAILED ("INCORRECT ""NOT IN""");
272
     END IF;
273
 
274
     B := FALSE;
275
     A (X'ADDRESS);
276
     IF NOT B THEN
277
          FAILED ("INCORRECT 'ADDRESS");
278
     END IF;
279
 
280
     IF NOT X'CONSTRAINED THEN
281
          FAILED ("INCORRECT 'CONSTRAINED");
282
     END IF;
283
 
284
     IF X.C'FIRST_BIT < 0 THEN
285
          FAILED ("INCORRECT 'FIRST_BIT");
286
     END IF;
287
 
288
     IF X.C'LAST_BIT < 0 OR
289
        X.C'LAST_BIT - X.C'FIRST_BIT + 1 /= X.C'SIZE THEN
290
          FAILED ("INCORRECT 'LAST_BIT");
291
     END IF;
292
 
293
     IF X.C'POSITION < 0 THEN
294
          FAILED ("INCORRECT 'POSITION");
295
     END IF;
296
 
297
     IF X'SIZE < T'SIZE THEN
298
          COMMENT ("X'SIZE < T'SIZE");
299
     ELSIF X'SIZE = T'SIZE THEN
300
          COMMENT ("X'SIZE = T'SIZE");
301
     ELSE
302
          COMMENT ("X'SIZE > T'SIZE");
303
     END IF;
304
 
305
     RESULT;
306
EXCEPTION
307
     WHEN OTHERS =>
308
          FAILED ("UNEXPECTED EXCEPTION RAISED WHILE CHECKING BASIC " &
309
                  "OPERATIONS");
310
          RESULT;
311
END C34006J;

powered by: WebSVN 2.1.0

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