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

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

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