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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 720 jeremybenn 
-- C37213B.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 
-- CHECK THAT IF
26 
--        A DISCRIMINANT CONSTRAINT
27 
-- DEPENDS ON A DISCRIMINANT, THE NON-DISCRIMINANT EXPRESSIONS IN THE
28 
-- CONSTRAINT ARE EVALUATED WHEN THE COMPONENT SUBTYPE DEFINITION IS
29 
-- ELABORATED, BUT THE VALUES ARE CHECKED WHEN THE RECORD TYPE IS:
30 
--
31 
--   CASE B: USED WITHOUT A CONSTRAINT ONLY IN AN ALLOCATOR OR OBJECT
32 
--      DECLARATION.
33 
 
34 
-- JBG 10/17/86
35 
 
36 
WITH REPORT; USE REPORT;
37 
PROCEDURE C37213B IS
38 
 
39 
     SUBTYPE SM IS INTEGER RANGE 1..10;
40 
 
41 
     TYPE REC (D1, D2 : SM) IS
42 
          RECORD NULL; END RECORD;
43 
 
44 
     F1_CONS : INTEGER := 2;
45 
 
46 
     FUNCTION CHK (
47 
          CONS    : INTEGER;
48 
          VALUE   : INTEGER;
49 
          MESSAGE : STRING) RETURN BOOLEAN IS
50 
     BEGIN
51 
          IF CONS /= VALUE THEN
52 
               FAILED (MESSAGE & ": CONS IS " &
53 
                       INTEGER'IMAGE(CONS));
54 
          END IF;
55 
          RETURN TRUE;
56 
     END CHK;
57 
 
58 
     FUNCTION F1 RETURN INTEGER IS
59 
     BEGIN
60 
          F1_CONS := F1_CONS - IDENT_INT(1);
61 
          RETURN F1_CONS;
62 
     END F1;
63 
 
64 
BEGIN
65 
     TEST ("C37213B", "CHECK EVALUATION OF DISCRIMINANT EXPRESSIONS " &
66 
                      "WHEN CONSTRAINT DEPENDS ON DISCRIMINANT, " &
67 
                      "AND DISCRIMINANTS HAVE DEFAULTS");
68 
 
69 
-- CASE B
70 
 
71 
     DECLARE
72 
          TYPE CONS (D3 : INTEGER := 1) IS
73 
               RECORD
74 
                    C1 : REC (D3, F1);       -- F1 EVALUATED
75 
               END RECORD;
76 
          CHK1 : BOOLEAN := CHK (F1_CONS, 1, "F1 NOT EVALUATED");
77 
          X : CONS;             -- F1 NOT EVALUATED AGAIN
78 
          Y : CONS;             -- F1 NOT EVALUATED AGAIN
79 
          CHK2 : BOOLEAN := CHK (F1_CONS, 1, "F1 EVALUATED");
80 
     BEGIN
81 
          IF X /= (1, (1, 1)) OR Y /= (1, (1, 1)) THEN
82 
               FAILED ("DISCRIMINANT VALUES NOT CORRECT");
83 
          END IF;
84 
     END;
85 
 
86 
     F1_CONS := 12;
87 
 
88 
     DECLARE
89 
          TYPE CONS (D3 : INTEGER := 1) IS
90 
               RECORD
91 
                    C1 : REC(D3, F1);
92 
               END RECORD;
93 
     BEGIN
94 
          BEGIN
95 
               DECLARE
96 
                    X : CONS;
97 
               BEGIN
98 
                    FAILED ("DISCRIMINANT CHECK NOT PERFORMED - 1");
99 
                    IF X /= (1, (1, 1)) THEN
100 
                         COMMENT ("SHOULDN'T GET HERE");
101 
                    END IF;
102 
               END;
103 
          EXCEPTION
104 
               WHEN CONSTRAINT_ERROR =>
105 
                    NULL;
106 
               WHEN OTHERS =>
107 
                    FAILED ("UNEXPECTED EXCEPTION - 1");
108 
          END;
109 
 
110 
          BEGIN
111 
               DECLARE
112 
                    TYPE ACC_CONS IS ACCESS CONS;
113 
                    X : ACC_CONS;
114 
               BEGIN
115 
                    X := NEW CONS;
116 
                    FAILED ("DISCRIMINANT CHECK NOT PERFORMED - 2");
117 
                    BEGIN
118 
                         IF X.ALL /= (1, (1, 1)) THEN
119 
                              COMMENT ("IRRELEVANT");
120 
                         END IF;
121 
                    END;
122 
               EXCEPTION
123 
                    WHEN CONSTRAINT_ERROR =>
124 
                         NULL;
125 
                    WHEN OTHERS =>
126 
                         FAILED ("UNEXPECTED EXCEPTION RAISED - 2");
127 
               END;
128 
          EXCEPTION
129 
               WHEN OTHERS =>
130 
                    FAILED ("CONSTRAINT CHECKED TOO SOON - 2");
131 
          END;
132 
 
133 
          BEGIN
134 
               DECLARE
135 
                    SUBTYPE SCONS IS CONS;
136 
               BEGIN
137 
                    DECLARE
138 
                         X : SCONS;
139 
                    BEGIN
140 
                         FAILED ("DISCRIMINANT CHECK NOT " &
141 
                                 "PERFORMED - 3");
142 
                         IF X /= (1, (1, 1)) THEN
143 
                              COMMENT ("IRRELEVANT");
144 
                         END IF;
145 
                    END;
146 
               EXCEPTION
147 
                    WHEN CONSTRAINT_ERROR =>
148 
                         NULL;
149 
                    WHEN OTHERS =>
150 
                         FAILED ("UNEXPECTED EXCEPTION RAISED - 3");
151 
               END;
152 
          EXCEPTION
153 
               WHEN OTHERS =>
154 
                    FAILED ("CONSTRAINT CHECKED TOO SOON - 3");
155 
          END;
156 
 
157 
          BEGIN
158 
               DECLARE
159 
                    TYPE ARR IS ARRAY (1..5) OF CONS;
160 
               BEGIN
161 
                    DECLARE
162 
                         X : ARR;
163 
                    BEGIN
164 
                         FAILED ("DISCRIMINANT CHECK NOT " &
165 
                                 "PERFORMED - 4");
166 
                         IF X /= (1..5 => (1, (1, 1))) THEN
167 
                              COMMENT ("IRRELEVANT");
168 
                         END IF;
169 
                    END;
170 
               EXCEPTION
171 
                    WHEN CONSTRAINT_ERROR =>
172 
                         NULL;
173 
                    WHEN OTHERS =>
174 
                         FAILED ("UNEXPECTED EXCEPTION RAISED - 4");
175 
               END;
176 
          EXCEPTION
177 
               WHEN OTHERS =>
178 
                    FAILED ("CONSTRAINT CHECKED TOO SOON - 4");
179 
          END;
180 
 
181 
          BEGIN
182 
               DECLARE
183 
                    TYPE NREC IS
184 
                         RECORD
185 
                              C1 : CONS;
186 
                         END RECORD;
187 
               BEGIN
188 
                    DECLARE
189 
                         X : NREC;
190 
                    BEGIN
191 
                         FAILED ("DISCRIMINANT CHECK NOT " &
192 
                                 "PERFORMED - 5");
193 
                         IF X /= (C1 => (1, (1, 1))) THEN
194 
                              COMMENT ("IRRELEVANT");
195 
                         END IF;
196 
                    END;
197 
               EXCEPTION
198 
                    WHEN CONSTRAINT_ERROR =>
199 
                         NULL;
200 
                    WHEN OTHERS =>
201 
                         FAILED ("UNEXPECTED EXCEPTION RAISED - 5");
202 
               END;
203 
          EXCEPTION
204 
               WHEN OTHERS =>
205 
                    FAILED ("CONSTRAINT CHECKED TOO SOON - 5");
206 
          END;
207 
 
208 
          BEGIN
209 
               DECLARE
210 
                    TYPE DREC IS NEW CONS;
211 
               BEGIN
212 
                    DECLARE
213 
                         X : DREC;
214 
                    BEGIN
215 
                         FAILED ("DISCRIMINANT CHECK NOT " &
216 
                                 "PERFORMED - 6");
217 
                         IF X /= (1, (1, 1)) THEN
218 
                              COMMENT ("IRRELEVANT");
219 
                         END IF;
220 
                    END;
221 
               EXCEPTION
222 
                    WHEN CONSTRAINT_ERROR =>
223 
                         NULL;
224 
                    WHEN OTHERS =>
225 
                         FAILED ("UNEXPECTED EXCEPTION RAISED - 6");
226 
               END;
227 
          EXCEPTION
228 
               WHEN OTHERS =>
229 
                    FAILED ("CONSTRAINT CHECKED TOO SOON - 6");
230 
          END;
231 
 
232 
     END;
233 
 
234 
     RESULT;
235 
 
236 
EXCEPTION
237 
     WHEN OTHERS =>
238 
          FAILED ("CONSTRAINT CHECK DONE TOO EARLY");
239 
          RESULT;
240 
 
241 
END C37213B;

powered by: WebSVN 2.1.0

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