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