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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 720 jeremybenn 
-- C34005P.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 ONE-DIMENSIONAL ARRAY TYPES WHOSE
28 
--     COMPONENT TYPE IS A LIMITED TYPE.
29 
 
30 
-- HISTORY:
31 
--     JRK 08/17/87  CREATED ORIGINAL TEST.
32 
--     VCL 07/01/88  MODIFIED THE STATEMENTS INVOLVING THE 'SIZE
33 
--                   ATTRIBUTE TO REMOVE ANY ASSUMPTIONS ABOUT THE
34 
--                   SIZES.  ADDED EXCEPTION HANDLERS TO CATCH INCORRECT
35 
--                   TYPE CONVERSIONS TO DERIVED SUBTYPES.
36 
--     PWN 11/30/94  REMOVED 'BASE USE ILLEGAL IN ADA 9X.
37 
--     RLB 10/03/02  REMOVED ILLEGAL (BY AI-246) TYPE CONVERSIONS AND
38 
--                   SUPPORTING CODE.
39 
 
40 
WITH SYSTEM; USE SYSTEM;
41 
WITH REPORT; USE REPORT;
42 
 
43 
PROCEDURE C34005P IS
44 
 
45 
     PACKAGE PKG_L IS
46 
 
47 
          TYPE LP IS LIMITED PRIVATE;
48 
 
49 
          FUNCTION CREATE (X : INTEGER) RETURN LP;
50 
 
51 
          FUNCTION VALUE (X : LP) RETURN INTEGER;
52 
 
53 
          FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN;
54 
 
55 
          PROCEDURE ASSIGN (X : OUT LP; Y : LP);
56 
 
57 
          C1 : CONSTANT LP;
58 
          C2 : CONSTANT LP;
59 
          C3 : CONSTANT LP;
60 
          C4 : CONSTANT LP;
61 
          C5 : CONSTANT LP;
62 
          C6 : CONSTANT LP;
63 
 
64 
     PRIVATE
65 
 
66 
          TYPE LP IS NEW INTEGER;
67 
 
68 
          C1 : CONSTANT LP := 1;
69 
          C2 : CONSTANT LP := 2;
70 
          C3 : CONSTANT LP := 3;
71 
          C4 : CONSTANT LP := 4;
72 
          C5 : CONSTANT LP := 5;
73 
          C6 : CONSTANT LP := 6;
74 
 
75 
     END PKG_L;
76 
 
77 
     USE PKG_L;
78 
 
79 
     SUBTYPE COMPONENT IS LP;
80 
 
81 
     PACKAGE PKG_P IS
82 
 
83 
          FIRST : CONSTANT := 0;
84 
          LAST  : CONSTANT := 100;
85 
 
86 
          SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST;
87 
 
88 
          TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT;
89 
 
90 
          FUNCTION CREATE ( F, L  : INDEX;
91 
                            C     : COMPONENT;
92 
                            DUMMY : PARENT   -- TO RESOLVE OVERLOADING.
93 
                          ) RETURN PARENT;
94 
 
95 
          FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN;
96 
 
97 
          FUNCTION AGGR (X, Y : COMPONENT) RETURN PARENT;
98 
 
99 
          FUNCTION AGGR (X, Y, Z : COMPONENT) RETURN PARENT;
100 
 
101 
     END PKG_P;
102 
 
103 
     USE PKG_P;
104 
 
105 
     TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7));
106 
 
107 
     X : T;
108 
     W : PARENT (5 .. 7);
109 
     C : COMPONENT;
110 
     B : BOOLEAN := FALSE;
111 
     N : CONSTANT := 1;
112 
 
113 
     PROCEDURE A (X : ADDRESS) IS
114 
     BEGIN
115 
          B := IDENT_BOOL (TRUE);
116 
     END A;
117 
 
118 
     FUNCTION V RETURN T IS
119 
          RESULT : T;
120 
     BEGIN
121 
          FOR I IN RESULT'RANGE LOOP
122 
               ASSIGN (RESULT (I), C);
123 
          END LOOP;
124 
          RETURN RESULT;
125 
     END V;
126 
 
127 
     PACKAGE BODY PKG_L IS
128 
 
129 
          FUNCTION CREATE (X : INTEGER) RETURN LP IS
130 
          BEGIN
131 
               RETURN LP (IDENT_INT (X));
132 
          END CREATE;
133 
 
134 
          FUNCTION VALUE (X : LP) RETURN INTEGER IS
135 
          BEGIN
136 
               RETURN INTEGER (X);
137 
          END VALUE;
138 
 
139 
          FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS
140 
          BEGIN
141 
               RETURN X = Y;
142 
          END EQUAL;
143 
 
144 
          PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS
145 
          BEGIN
146 
               X := Y;
147 
          END ASSIGN;
148 
 
149 
     END PKG_L;
150 
 
151 
     PACKAGE BODY PKG_P IS
152 
 
153 
          FUNCTION CREATE
154 
             ( F, L  : INDEX;
155 
               C     : COMPONENT;
156 
               DUMMY : PARENT
157 
             ) RETURN PARENT
158 
          IS
159 
               A : PARENT (F .. L);
160 
               B : COMPONENT;
161 
          BEGIN
162 
               ASSIGN (B, C);
163 
               FOR I IN F .. L LOOP
164 
                    ASSIGN (A (I), B);
165 
                    ASSIGN (B, CREATE (VALUE (B) + 1));
166 
               END LOOP;
167 
               RETURN A;
168 
          END CREATE;
169 
 
170 
          FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS
171 
          BEGIN
172 
               IF X'LENGTH /= Y'LENGTH THEN
173 
                    RETURN FALSE;
174 
               ELSE FOR I IN X'RANGE LOOP
175 
                         IF NOT EQUAL (X (I),
176 
                                       Y (I - X'FIRST + Y'FIRST)) THEN
177 
                              RETURN FALSE;
178 
                         END IF;
179 
                    END LOOP;
180 
               END IF;
181 
               RETURN TRUE;
182 
          END EQUAL;
183 
 
184 
          FUNCTION AGGR (X, Y : COMPONENT) RETURN PARENT IS
185 
               RESULT : PARENT (INDEX'FIRST .. INDEX'FIRST + 1);
186 
          BEGIN
187 
               ASSIGN (RESULT (INDEX'FIRST    ), X);
188 
               ASSIGN (RESULT (INDEX'FIRST + 1), Y);
189 
               RETURN RESULT;
190 
          END AGGR;
191 
 
192 
          FUNCTION AGGR (X, Y, Z : COMPONENT) RETURN PARENT IS
193 
               RESULT : PARENT (INDEX'FIRST .. INDEX'FIRST + 2);
194 
          BEGIN
195 
               ASSIGN (RESULT (INDEX'FIRST    ), X);
196 
               ASSIGN (RESULT (INDEX'FIRST + 1), Y);
197 
               ASSIGN (RESULT (INDEX'FIRST + 2), Z);
198 
               RETURN RESULT;
199 
          END AGGR;
200 
 
201 
     END PKG_P;
202 
 
203 
BEGIN
204 
     TEST ("C34005P", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
205 
                      "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
206 
                      "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " &
207 
                      "TYPE IS A LIMITED TYPE");
208 
 
209 
     ASSIGN (X (IDENT_INT (5)), CREATE (1));
210 
     ASSIGN (X (IDENT_INT (6)), CREATE (2));
211 
     ASSIGN (X (IDENT_INT (7)), CREATE (3));
212 
 
213 
     ASSIGN (W (5), CREATE (1));
214 
     ASSIGN (W (6), CREATE (2));
215 
     ASSIGN (W (7), CREATE (3));
216 
 
217 
     ASSIGN (C, CREATE (2));
218 
 
219 
     IF NOT EQUAL (T'(X), AGGR (C1, C2, C3)) THEN
220 
          FAILED ("INCORRECT QUALIFICATION");
221 
     END IF;
222 
 
223 
     IF NOT EQUAL (T(X), AGGR (C1, C2, C3)) THEN
224 
          FAILED ("INCORRECT SELF CONVERSION");
225 
     END IF;
226 
 
227 
     IF NOT EQUAL (T(W), AGGR (C1, C2, C3)) THEN
228 
          FAILED ("INCORRECT CONVERSION FROM PARENT");
229 
     END IF;
230 
 
231 
     IF NOT EQUAL (PARENT(X), AGGR (C1, C2, C3)) THEN
232 
          FAILED ("INCORRECT CONVERSION TO PARENT - 1");
233 
     END IF;
234 
 
235 
     BEGIN
236 
          IF NOT EQUAL (PARENT(CREATE (2, 3, C4, X)),
237 
                        AGGR (C4, C5))                 THEN
238 
               FAILED ("INCORRECT CONVERSION TO PARENT - 2");
239 
          END IF;
240 
     EXCEPTION
241 
          WHEN OTHERS =>
242 
               FAILED ("EXCEPTION RAISED WHILE CHECKING BASE TYPE " &
243 
                       "VALUES OUTSIDE OF THE SUBTYPE T - 1");
244 
     END;
245 
 
246 
     IF NOT EQUAL (X(IDENT_INT (5)), C1) THEN
247 
          FAILED ("INCORRECT INDEX (VALUE)");
248 
     END IF;
249 
 
250 
     BEGIN
251 
          IF NOT EQUAL (X(IDENT_INT (6)..IDENT_INT (7)),
252 
                        AGGR (C2, C3))     OR
253 
             NOT EQUAL (CREATE (1, 4, C4, X)(1..3),
254 
                        AGGR (C4, C5, C6))           THEN
255 
               FAILED ("INCORRECT SLICE (VALUE)");
256 
          END IF;
257 
     EXCEPTION
258 
          WHEN OTHERS =>
259 
               FAILED ("EXCEPTION RAISED WHILE CHECKING SLICES");
260 
     END;
261 
 
262 
     IF NOT (X IN T) OR AGGR (C1, C2) IN T THEN
263 
          FAILED ("INCORRECT ""IN""");
264 
     END IF;
265 
 
266 
     IF X NOT IN T OR NOT (AGGR (C1, C2) NOT IN T) THEN
267 
          FAILED ("INCORRECT ""NOT IN""");
268 
     END IF;
269 
 
270 
     B := FALSE;
271 
     A (X'ADDRESS);
272 
     IF NOT B THEN
273 
          FAILED ("INCORRECT 'ADDRESS");
274 
     END IF;
275 
 
276 
     IF T'FIRST /= 5 THEN
277 
          FAILED ("INCORRECT TYPE'FIRST");
278 
     END IF;
279 
 
280 
     IF X'FIRST /= 5 THEN
281 
          FAILED ("INCORRECT OBJECT'FIRST");
282 
     END IF;
283 
 
284 
     IF V'FIRST /= 5 THEN
285 
          FAILED ("INCORRECT VALUE'FIRST");
286 
     END IF;
287 
 
288 
     IF T'FIRST (N) /= 5 THEN
289 
          FAILED ("INCORRECT TYPE'FIRST (N)");
290 
     END IF;
291 
 
292 
     IF X'FIRST (N) /= 5 THEN
293 
          FAILED ("INCORRECT OBJECT'FIRST (N)");
294 
     END IF;
295 
 
296 
     IF V'FIRST (N) /= 5 THEN
297 
          FAILED ("INCORRECT VALUE'FIRST (N)");
298 
     END IF;
299 
 
300 
     IF T'LAST /= 7 THEN
301 
          FAILED ("INCORRECT TYPE'LAST");
302 
     END IF;
303 
 
304 
     IF X'LAST /= 7 THEN
305 
          FAILED ("INCORRECT OBJECT'LAST");
306 
     END IF;
307 
 
308 
     IF V'LAST /= 7 THEN
309 
          FAILED ("INCORRECT VALUE'LAST");
310 
     END IF;
311 
 
312 
     IF T'LAST (N) /= 7 THEN
313 
          FAILED ("INCORRECT TYPE'LAST (N)");
314 
     END IF;
315 
 
316 
     IF X'LAST (N) /= 7 THEN
317 
          FAILED ("INCORRECT OBJECT'LAST (N)");
318 
     END IF;
319 
 
320 
     IF V'LAST (N) /= 7 THEN
321 
          FAILED ("INCORRECT VALUE'LAST (N)");
322 
     END IF;
323 
 
324 
     IF T'LENGTH /= 3 THEN
325 
          FAILED ("INCORRECT TYPE'LENGTH");
326 
     END IF;
327 
 
328 
     IF X'LENGTH /= 3 THEN
329 
          FAILED ("INCORRECT OBJECT'LENGTH");
330 
     END IF;
331 
 
332 
     IF V'LENGTH /= 3 THEN
333 
          FAILED ("INCORRECT VALUE'LENGTH");
334 
     END IF;
335 
 
336 
     IF T'LENGTH (N) /= 3 THEN
337 
          FAILED ("INCORRECT TYPE'LENGTH (N)");
338 
     END IF;
339 
 
340 
     IF X'LENGTH (N) /= 3 THEN
341 
          FAILED ("INCORRECT OBJECT'LENGTH (N)");
342 
     END IF;
343 
 
344 
     IF V'LENGTH (N) /= 3 THEN
345 
          FAILED ("INCORRECT VALUE'LENGTH (N)");
346 
     END IF;
347 
 
348 
     DECLARE
349 
          Y : PARENT (T'RANGE);
350 
     BEGIN
351 
          IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
352 
               FAILED ("INCORRECT TYPE'RANGE");
353 
          END IF;
354 
     END;
355 
 
356 
     DECLARE
357 
          Y : PARENT (X'RANGE);
358 
     BEGIN
359 
          IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
360 
               FAILED ("INCORRECT OBJECT'RANGE");
361 
          END IF;
362 
     END;
363 
 
364 
     DECLARE
365 
          Y : PARENT (V'RANGE);
366 
     BEGIN
367 
          IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
368 
               FAILED ("INCORRECT VALUE'RANGE");
369 
          END IF;
370 
     END;
371 
 
372 
     DECLARE
373 
          Y : PARENT (T'RANGE (N));
374 
     BEGIN
375 
          IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
376 
               FAILED ("INCORRECT TYPE'RANGE (N)");
377 
          END IF;
378 
     END;
379 
 
380 
     DECLARE
381 
          Y : PARENT (X'RANGE (N));
382 
     BEGIN
383 
          IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
384 
               FAILED ("INCORRECT OBJECT'RANGE (N)");
385 
          END IF;
386 
     END;
387 
 
388 
     DECLARE
389 
          Y : PARENT (V'RANGE (N));
390 
     BEGIN
391 
          IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
392 
               FAILED ("INCORRECT VALUE'RANGE (N)");
393 
          END IF;
394 
     END;
395 
 
396 
     IF X'SIZE < T'SIZE THEN
397 
          COMMENT ("X'SIZE < T'SIZE");
398 
     ELSIF X'SIZE = T'SIZE THEN
399 
          COMMENT ("X'SIZE = T'SIZE");
400 
     ELSE
401 
          COMMENT ("X'SIZE > T'SIZE");
402 
     END IF;
403 
 
404 
     RESULT;
405 
END C34005P;

powered by: WebSVN 2.1.0

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