1-- 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
36WITH REPORT; USE REPORT;
37PROCEDURE 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
64BEGIN
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
236EXCEPTION
237     WHEN OTHERS =>
238          FAILED ("CONSTRAINT CHECK DONE TOO EARLY");
239          RESULT;
240
241END C37213B;
242