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/] [c34009f.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 
-- C34009F.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 
--     FOR DERIVED NON-LIMITED PRIVATE TYPES WITH DISCRIMINANTS:
27 
 
28 
--        CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT
29 
--        FOR THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION
30 
--        IS CONSTRAINED.
31 
 
32 
--        CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS
33 
--        ALSO IMPOSED ON THE DERIVED SUBTYPE.
34 
 
35 
-- HISTORY:
36 
--     JRK 08/31/87  CREATED ORIGINAL TEST.
37 
 
38 
WITH REPORT; USE REPORT;
39 
 
40 
PROCEDURE C34009F IS
41 
 
42 
     PACKAGE PKG IS
43 
 
44 
          MAX_LEN : CONSTANT := 10;
45 
 
46 
          SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN;
47 
 
48 
          TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 1) IS PRIVATE;
49 
 
50 
          FUNCTION CREATE ( B : BOOLEAN;
51 
                            L : LENGTH;
52 
                            I : INTEGER;
53 
                            S : STRING;
54 
                            J : INTEGER;
55 
                            F : FLOAT;
56 
                            X : PARENT  -- TO RESOLVE OVERLOADING.
57 
                          ) RETURN PARENT;
58 
 
59 
          FUNCTION CON ( B : BOOLEAN;
60 
                         L : LENGTH;
61 
                         I : INTEGER;
62 
                         S : STRING;
63 
                         J : INTEGER
64 
                       ) RETURN PARENT;
65 
 
66 
          FUNCTION CON ( B : BOOLEAN;
67 
                         L : LENGTH;
68 
                         I : INTEGER;
69 
                         F : FLOAT
70 
                       ) RETURN PARENT;
71 
 
72 
     PRIVATE
73 
 
74 
          TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 1) IS
75 
               RECORD
76 
                    I : INTEGER;
77 
                    CASE B IS
78 
                         WHEN TRUE =>
79 
                              S : STRING (1 .. L);
80 
                              J : INTEGER;
81 
                         WHEN FALSE =>
82 
                              F : FLOAT := 5.0;
83 
                    END CASE;
84 
               END RECORD;
85 
 
86 
     END PKG;
87 
 
88 
     USE PKG;
89 
 
90 
     TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3));
91 
 
92 
     SUBTYPE SUBPARENT IS PARENT (TRUE, 3);
93 
 
94 
     TYPE S IS NEW SUBPARENT;
95 
 
96 
     X : T;
97 
     Y : S;
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 ("C34009F", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
147 
                      "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
148 
                      "WHEN THE DERIVED TYPE DEFINITION IS " &
149 
                      "CONSTRAINED.  ALSO CHECK THAT ANY CONSTRAINT " &
150 
                      "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
151 
                      "ON THE DERIVED SUBTYPE.  CHECK FOR DERIVED " &
152 
                      "NON-LIMITED PRIVATE TYPES WITH DISCRIMINANTS");
153 
 
154 
     X := CON (TRUE, 3, 2, "AAA", 2);
155 
     Y := CON (TRUE, 3, 2, "AAA", 2);
156 
 
157 
     -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
158 
 
159 
     IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) /=
160 
        CON (FALSE, 2, 3, 6.0) OR
161 
        CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) /=
162 
        CON (FALSE, 2, 3, 6.0) THEN
163 
          FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE SUBTYPE");
164 
     END IF;
165 
 
166 
     IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) IN T OR
167 
        CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) IN S THEN
168 
          FAILED ("INCORRECT ""IN""");
169 
     END IF;
170 
 
171 
     -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
172 
 
173 
     IF X.B /= TRUE OR X.L /= 3 OR
174 
        Y.B /= TRUE OR Y.L /= 3 THEN
175 
          FAILED ("INCORRECT SELECTION OF DISCRIMINANT VALUES");
176 
     END IF;
177 
 
178 
     IF NOT X'CONSTRAINED OR NOT Y'CONSTRAINED THEN
179 
          FAILED ("INCORRECT 'CONSTRAINED");
180 
     END IF;
181 
 
182 
     BEGIN
183 
          X := CON (TRUE, 3, 1, "ABC", 4);
184 
          Y := CON (TRUE, 3, 1, "ABC", 4);
185 
          IF PARENT (X) /= PARENT (Y) THEN  -- USE X AND Y.
186 
               FAILED ("INCORRECT CONVERSION TO PARENT");
187 
          END IF;
188 
     EXCEPTION
189 
          WHEN OTHERS =>
190 
               FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT");
191 
     END;
192 
 
193 
     BEGIN
194 
          X := CON (FALSE, 3, 2, 6.0);
195 
          FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
196 
                  "X := CON (FALSE, 3, 2, 6.0)");
197 
          IF X = CON (FALSE, 3, 2, 6.0) THEN  -- USE X.
198 
               COMMENT ("X ALTERED -- X := CON (FALSE, 3, 2, 6.0)");
199 
          END IF;
200 
     EXCEPTION
201 
          WHEN CONSTRAINT_ERROR =>
202 
               NULL;
203 
          WHEN OTHERS =>
204 
               FAILED ("WRONG EXCEPTION RAISED -- " &
205 
                       "X := CON (FALSE, 3, 2, 6.0)");
206 
     END;
207 
 
208 
     BEGIN
209 
          X := CON (TRUE, 4, 2, "ZZZZ", 6);
210 
          FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
211 
                  "X := CON (TRUE, 4, 2, ""ZZZZ"", 6)");
212 
          IF X = CON (TRUE, 4, 2, "ZZZZ", 6) THEN  -- USE X.
213 
               COMMENT ("X ALTERED -- " &
214 
                        "X := CON (TRUE, 4, 2, ""ZZZZ"", 6)");
215 
          END IF;
216 
     EXCEPTION
217 
          WHEN CONSTRAINT_ERROR =>
218 
               NULL;
219 
          WHEN OTHERS =>
220 
               FAILED ("WRONG EXCEPTION RAISED -- " &
221 
                       "X := CON (TRUE, 4, 2, ""ZZZZ"", 6)");
222 
     END;
223 
 
224 
     BEGIN
225 
          Y := CON (FALSE, 3, 2, 6.0);
226 
          FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
227 
                  "Y := CON (FALSE, 3, 2, 6.0)");
228 
          IF Y = CON (FALSE, 3, 2, 6.0) THEN  -- USE Y.
229 
               COMMENT ("Y ALTERED -- Y := CON (FALSE, 3, 2, 6.0)");
230 
          END IF;
231 
     EXCEPTION
232 
          WHEN CONSTRAINT_ERROR =>
233 
               NULL;
234 
          WHEN OTHERS =>
235 
               FAILED ("WRONG EXCEPTION RAISED -- " &
236 
                       "Y := CON (FALSE, 3, 2, 6.0)");
237 
     END;
238 
 
239 
     BEGIN
240 
          Y := CON (TRUE, 4, 2, "ZZZZ", 6);
241 
          FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
242 
                  "Y := CON (TRUE, 4, 2, ""ZZZZ"", 6)");
243 
          IF Y = CON (TRUE, 4, 2, "ZZZZ", 6) THEN  -- USE Y.
244 
               COMMENT ("Y ALTERED -- " &
245 
                        "Y := CON (TRUE, 4, 2, ""ZZZZ"", 6)");
246 
          END IF;
247 
     EXCEPTION
248 
          WHEN CONSTRAINT_ERROR =>
249 
               NULL;
250 
          WHEN OTHERS =>
251 
               FAILED ("WRONG EXCEPTION RAISED -- " &
252 
                       "Y := CON (TRUE, 4, 2, ""ZZZZ"", 6)");
253 
     END;
254 
 
255 
     RESULT;
256 
END C34009F;

powered by: WebSVN 2.1.0

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