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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 720 jeremybenn 
-- C34009J.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 LIMITED PRIVATE TYPES WITH
28 
--     DISCRIMINANTS.
29 
 
30 
-- HISTORY:
31 
--     JRK 09/01/87  CREATED ORIGINAL TEST.
32 
--     WMC 03/13/92  REVISED TYPE'SIZE CHECKS.
33 
--     PWN 01/31/95  REMOVED INCONSISTENCIES WITH ADA 9X.
34 
 
35 
WITH SYSTEM; USE SYSTEM;
36 
WITH REPORT; USE REPORT;
37 
 
38 
PROCEDURE C34009J IS
39 
 
40 
     PACKAGE PKG IS
41 
 
42 
          MAX_LEN : CONSTANT := 10;
43 
 
44 
          SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN;
45 
 
46 
          TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 3) IS
47 
                      LIMITED PRIVATE;
48 
 
49 
          FUNCTION CREATE ( B : BOOLEAN;
50 
                            L : LENGTH;
51 
                            I : INTEGER;
52 
                            S : STRING;
53 
                            J : INTEGER;
54 
                            F : FLOAT;
55 
                            X : PARENT  -- TO RESOLVE OVERLOADING.
56 
                          ) RETURN PARENT;
57 
 
58 
          FUNCTION CON ( B : BOOLEAN;
59 
                         L : LENGTH;
60 
                         I : INTEGER;
61 
                         S : STRING;
62 
                         J : INTEGER
63 
                       ) RETURN PARENT;
64 
 
65 
          FUNCTION CON ( B : BOOLEAN;
66 
                         L : LENGTH;
67 
                         I : INTEGER;
68 
                         F : FLOAT
69 
                       ) RETURN PARENT;
70 
 
71 
          FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN;
72 
 
73 
          PROCEDURE ASSIGN (X : OUT PARENT; Y : PARENT);
74 
 
75 
     PRIVATE
76 
 
77 
          TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 3) IS
78 
               RECORD
79 
                    I : INTEGER := 2;
80 
                    CASE B IS
81 
                         WHEN TRUE =>
82 
                              S : STRING (1 .. L) := (1 .. L => 'A');
83 
                              J : INTEGER := 2;
84 
                         WHEN FALSE =>
85 
                              F : FLOAT := 5.0;
86 
                    END CASE;
87 
               END RECORD;
88 
 
89 
     END PKG;
90 
 
91 
     USE PKG;
92 
 
93 
     TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3));
94 
 
95 
     X : T;
96 
     W : PARENT;
97 
     B : BOOLEAN := FALSE;
98 
 
99 
     PROCEDURE A (X : ADDRESS) IS
100 
     BEGIN
101 
          B := IDENT_BOOL (TRUE);
102 
     END A;
103 
 
104 
     PACKAGE BODY PKG IS
105 
 
106 
          FUNCTION CREATE
107 
             ( B : BOOLEAN;
108 
               L : LENGTH;
109 
               I : INTEGER;
110 
               S : STRING;
111 
               J : INTEGER;
112 
               F : FLOAT;
113 
               X : PARENT
114 
             ) RETURN PARENT
115 
          IS
116 
          BEGIN
117 
               CASE B IS
118 
                    WHEN TRUE =>
119 
                         RETURN (TRUE, L, I, S, J);
120 
                    WHEN FALSE =>
121 
                         RETURN (FALSE, L, I, F);
122 
               END CASE;
123 
          END CREATE;
124 
 
125 
          FUNCTION CON
126 
             ( B : BOOLEAN;
127 
               L : LENGTH;
128 
               I : INTEGER;
129 
               S : STRING;
130 
               J : INTEGER
131 
             ) RETURN PARENT
132 
          IS
133 
          BEGIN
134 
               RETURN (TRUE, L, I, S, J);
135 
          END CON;
136 
 
137 
          FUNCTION CON
138 
             ( B : BOOLEAN;
139 
               L : LENGTH;
140 
               I : INTEGER;
141 
               F : FLOAT
142 
             ) RETURN PARENT
143 
          IS
144 
          BEGIN
145 
               RETURN (FALSE, L, I, F);
146 
          END CON;
147 
 
148 
          FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS
149 
          BEGIN
150 
               RETURN X = Y;
151 
          END EQUAL;
152 
 
153 
          PROCEDURE ASSIGN (X : OUT PARENT; Y : PARENT) IS
154 
          BEGIN
155 
               X := Y;
156 
          END ASSIGN;
157 
 
158 
     END PKG;
159 
 
160 
BEGIN
161 
     TEST ("C34009J", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
162 
                      "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
163 
                      "LIMITED PRIVATE TYPES WITH DISCRIMINANTS");
164 
 
165 
     IF EQUAL (3, 3) THEN
166 
          ASSIGN (X, CON (TRUE, 3, 1, "ABC", 4));
167 
     END IF;
168 
     IF NOT EQUAL (T'(X), CON (TRUE, 3, 1, "ABC", 4)) THEN
169 
          FAILED ("INCORRECT QUALIFICATION");
170 
     END IF;
171 
 
172 
     IF NOT EQUAL (T (X), CON (TRUE, 3, 1, "ABC", 4)) THEN
173 
          FAILED ("INCORRECT SELF CONVERSION");
174 
     END IF;
175 
 
176 
     IF EQUAL (3, 3) THEN
177 
          ASSIGN (W, CON (TRUE, 3, 1, "ABC", 4));
178 
     END IF;
179 
     IF NOT EQUAL (T (W), CON (TRUE, 3, 1, "ABC", 4)) THEN
180 
          FAILED ("INCORRECT CONVERSION FROM PARENT");
181 
     END IF;
182 
 
183 
     IF NOT EQUAL (PARENT (X), CON (TRUE, 3, 1, "ABC", 4)) OR
184 
        NOT EQUAL (PARENT (CREATE (FALSE, 2, 3, "XX", 5, 6.0, X)),
185 
                   CON (FALSE, 2, 3, 6.0)) THEN
186 
          FAILED ("INCORRECT CONVERSION TO PARENT");
187 
     END IF;
188 
 
189 
     IF X.B /= TRUE OR X.L /= 3 OR
190 
        CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . B /= FALSE OR
191 
        CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . L /= 2 THEN
192 
          FAILED ("INCORRECT SELECTION (DISCRIMINANT)");
193 
     END IF;
194 
 
195 
     IF NOT (X IN T) OR CON (FALSE, 2, 3, 6.0) IN T THEN
196 
          FAILED ("INCORRECT ""IN""");
197 
     END IF;
198 
 
199 
     IF X NOT IN T OR NOT (CON (FALSE, 2, 3, 6.0) NOT IN T) THEN
200 
          FAILED ("INCORRECT ""NOT IN""");
201 
     END IF;
202 
 
203 
     B := FALSE;
204 
     A (X'ADDRESS);
205 
     IF NOT B THEN
206 
          FAILED ("INCORRECT 'ADDRESS");
207 
     END IF;
208 
 
209 
 
210 
     IF NOT X'CONSTRAINED THEN
211 
          FAILED ("INCORRECT OBJECT'CONSTRAINED");
212 
     END IF;
213 
 
214 
     IF T'SIZE <= 0 THEN
215 
          FAILED ("INCORRECT TYPE'SIZE");
216 
     END IF;
217 
 
218 
     IF X'SIZE   < T'SIZE OR
219 
        X.B'SIZE < BOOLEAN'SIZE OR
220 
        X.L'SIZE < LENGTH'SIZE THEN
221 
          FAILED ("INCORRECT OBJECT'SIZE");
222 
     END IF;
223 
 
224 
     RESULT;
225 
END C34009J;

powered by: WebSVN 2.1.0

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