1-- C32107A.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 OBJECT DECLARATIONS ARE ELABORATED IN THE ORDER OF THEIR
26-- OCCURRENCE, I.E., THAT EXPRESSIONS ASSOCIATED WITH ONE DECLARATION
27-- (INCLUDING DEFAULT EXPRESSIONS, IF APPROPRIATE) ARE EVALUATED BEFORE
28-- ANY EXPRESSION BELONGING TO THE NEXT DECLARATION. ALSO, CHECK THAT
29-- EXPRESSIONS IN THE SUBTYPE INDICATION OR THE CONSTRAINED ARRAY
30-- DEFINITION ARE EVALUATED BEFORE ANY INITIALIZATION EXPRESSIONS ARE
31-- EVALUATED.
32
33-- R.WILLIAMS 9/24/86
34
35WITH REPORT; USE REPORT;
36PROCEDURE C32107A IS
37
38     BUMP : INTEGER := 0;
39
40     ORDER_CHECK : INTEGER;
41
42     G1, H1, I1 : INTEGER;
43
44     FIRST_CALL : BOOLEAN := TRUE;
45
46     TYPE ARR1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
47
48     TYPE ARR1_NAME IS ACCESS ARR1;
49
50     TYPE ARR2 IS ARRAY (POSITIVE RANGE <>, POSITIVE RANGE <>) OF
51          INTEGER;
52
53     TYPE REC (D : INTEGER) IS
54          RECORD
55               COMP : INTEGER;
56          END RECORD;
57
58     TYPE REC_NAME IS ACCESS REC;
59
60     FUNCTION F RETURN INTEGER IS
61     BEGIN
62          BUMP := BUMP + 1;
63          RETURN BUMP;
64     END F;
65
66     FUNCTION G RETURN INTEGER IS
67     BEGIN
68          BUMP := BUMP + 1;
69          G1 := BUMP;
70          RETURN BUMP;
71     END G;
72
73     FUNCTION H RETURN INTEGER IS
74     BEGIN
75          BUMP := BUMP + 1;
76          H1 := BUMP;
77          RETURN BUMP;
78     END H;
79
80     FUNCTION I RETURN INTEGER IS
81     BEGIN
82          IF FIRST_CALL THEN
83               BUMP := BUMP + 1;
84               I1 := BUMP;
85               FIRST_CALL := FALSE;
86          END IF;
87          RETURN I1;
88     END I;
89
90BEGIN
91     TEST ( "C32107A", "CHECK THAT OBJECT DECLARATIONS ARE " &
92                       "ELABORATED IN THE ORDER OF THEIR " &
93                       "OCCURRENCE, I.E., THAT EXPRESSIONS " &
94                       "ASSOCIATED WITH ONE DECLARATION (INCLUDING " &
95                       "DEFAULT EXPRESSIONS, IF APPROPRIATE) ARE " &
96                       "EVALUATED BEFORE ANY EXPRESSION BELONGING " &
97                       "TO THE NEXT DECLARATION.  ALSO, CHECK THAT " &
98                       "EXPRESSIONS IN THE SUBTYPE INDICATION OR " &
99                       "THE CONSTRAINED ARRAY DEFINITION ARE " &
100                       "EVALUATED BEFORE ANY INITIALIZATION " &
101                       "EXPRESSIONS ARE EVALUATED" );
102
103     DECLARE -- (A).
104          I1 : INTEGER := 10000 * F;
105          A1 : CONSTANT ARRAY (1 .. H) OF REC (G * 100) :=
106               (1 .. H1 => (G1 * 100, I * 10));
107          I2 : CONSTANT INTEGER := F * 1000;
108     BEGIN
109          ORDER_CHECK := I1 + I2 + A1'LAST + A1 (1).D + A1 (1).COMP;
110          IF ORDER_CHECK = 15243 OR ORDER_CHECK = 15342 THEN
111               COMMENT ( "ORDER_CHECK HAS VALUE " &
112                          INTEGER'IMAGE (ORDER_CHECK) & " - (A)" );
113          ELSE
114               FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " &
115                        "VALUE OF ORDER_CHECK SHOULD BE 15343 OR " &
116                        "15242 -- ACTUAL VALUE IS " &
117                         INTEGER'IMAGE (ORDER_CHECK) & " - (A)" );
118          END IF;
119     END; -- (A).
120
121     BUMP := 0;
122
123     DECLARE -- (B).
124          A : ARR2 (1 .. F, 1 .. F * 10);
125          R : REC (G * 100) := (G1 * 100, F * 1000);
126          I : INTEGER RANGE 1 .. H;
127          S : REC (F * 10);
128     BEGIN
129          ORDER_CHECK :=
130               A'LAST (1) + A'LAST (2) + R.D + R.COMP;
131          IF (H1 + S.D = 65) AND
132             (ORDER_CHECK = 4321 OR ORDER_CHECK = 4312) THEN
133               COMMENT ( "ORDER_CHECK HAS VALUE 65 " &
134                          INTEGER'IMAGE (ORDER_CHECK) & " - (B)" );
135          ELSE
136               FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " &
137                        "VALUE OF ORDER_CHECK SHOULD BE 65 4321 OR " &
138                        "65 4312 -- ACTUAL VALUE IS " &
139                         INTEGER'IMAGE (H1 + S.D) &
140                         INTEGER'IMAGE (ORDER_CHECK) & " - (B)" );
141          END IF;
142     END; -- (B).
143
144     BUMP := 0;
145
146     DECLARE -- (C).
147          I1 : CONSTANT INTEGER RANGE 1 .. G * 10 := F;
148          A1 : ARRAY (1 .. F * 100) OF INTEGER RANGE 1 .. H * 1000;
149     BEGIN
150          ORDER_CHECK := I1 + (G1 * 10) + A1'LAST + (H1 * 1000);
151          IF ORDER_CHECK = 4312 OR ORDER_CHECK = 3412 THEN
152               COMMENT ( "ORDER_CHECK HAS VALUE " &
153                          INTEGER'IMAGE (ORDER_CHECK) & " - (C)" );
154          ELSE
155               FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " &
156                        "VALUE OF ORDER_CHECK SHOULD BE 4312 OR " &
157                        "3412 -- ACTUAL VALUE IS " &
158                         INTEGER'IMAGE (ORDER_CHECK) & " - (C)" );
159          END IF;
160     END; -- (C).
161
162     BUMP := 0;
163     FIRST_CALL := TRUE;
164
165     DECLARE -- (D).
166          A1 : ARRAY (1 .. G) OF REC (H * 10000) :=
167               (1 .. G1 => (H1 * 10000, I * 100));
168          R1 : CONSTANT REC := (F * 1000, F * 10);
169
170     BEGIN
171          ORDER_CHECK :=
172               A1'LAST + A1 (1).D + A1 (1).COMP + R1.D + R1.COMP;
173          IF ORDER_CHECK = 25341 OR ORDER_CHECK = 24351 OR
174             ORDER_CHECK = 15342 OR ORDER_CHECK = 14352 THEN
175               COMMENT ( "ORDER_CHECK HAS VALUE " &
176                          INTEGER'IMAGE (ORDER_CHECK) & " - (D)" );
177          ELSE
178               FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " &
179                        "VALUE OF ORDER_CHECK SHOULD BE 25341, " &
180                        "24351, 15342 OR 14352  -- ACTUAL VALUE IS " &
181                         INTEGER'IMAGE (ORDER_CHECK) & " - (D)" );
182          END IF;
183     END; -- (D).
184
185     BUMP := 0;
186
187     DECLARE -- (E).
188          A1 : CONSTANT ARR1_NAME := NEW ARR1' (1 .. F => F * 10);
189          R1 : REC_NAME (H * 100) := NEW REC'(H1 * 100, F * 1000);
190
191     BEGIN
192          ORDER_CHECK := A1.ALL'LAST + A1.ALL (1) + R1.D + R1.COMP;
193          IF ORDER_CHECK /= 4321 THEN
194               FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " &
195                        "VALUE OF ORDER_CHECK SHOULD BE 4321 " &
196                        "-- ACTUAL VALUE IS " &
197                         INTEGER'IMAGE (ORDER_CHECK) & " - (E)" );
198          END IF;
199     END; -- (E).
200
201     BUMP := 0;
202     FIRST_CALL := TRUE;
203
204     DECLARE -- (F).
205          A1 : CONSTANT ARRAY (1 .. G) OF INTEGER RANGE 1 .. H * 100 :=
206               (1 .. G1 => I * 10);
207          A2 : ARR1 (1 .. F * 1000);
208     BEGIN
209          ORDER_CHECK :=
210               A1'LAST + (H1 * 100) + A1 (1) + A2'LAST;
211          IF ORDER_CHECK = 4231 OR ORDER_CHECK = 4132 THEN
212               COMMENT ( "ORDER_CHECK HAS VALUE " &
213                          INTEGER'IMAGE (ORDER_CHECK) & " - (F)" );
214          ELSE
215               FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " &
216                        "VALUE OF ORDER_CHECK SHOULD BE 4231 OR " &
217                        "4132 -- ACTUAL VALUE IS " &
218                         INTEGER'IMAGE (ORDER_CHECK) & " - (F)" );
219          END IF;
220     END; -- (F).
221
222     BUMP := 0;
223
224     DECLARE -- (G).
225          A1 : ARR1_NAME (1 .. G) := NEW ARR1 (1 .. G1);
226          R1 : CONSTANT REC_NAME (H * 10) :=
227               NEW REC'(H1 * 10, F * 100);
228     BEGIN
229          ORDER_CHECK := A1.ALL'LAST + R1.D + R1.COMP;
230          IF ORDER_CHECK /= 321 THEN
231               FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " &
232                        "VALUE OF ORDER_CHECK SHOULD BE 321 OR " &
233                        "-- ACTUAL VALUE IS " &
234                         INTEGER'IMAGE (ORDER_CHECK) & " - (G)" );
235          END IF;
236     END; -- (G).
237
238     BUMP := 0;
239
240     DECLARE -- (H).
241          TYPE REC (D : INTEGER := F) IS
242               RECORD
243                    COMP : INTEGER := F * 10;
244               END RECORD;
245
246          R1 : REC;
247          R2 : REC (G * 100) := (G1 * 100, F * 1000);
248     BEGIN
249          ORDER_CHECK := R1.D + R1.COMP + R2.D + R2.COMP;
250          IF ORDER_CHECK = 4321 OR ORDER_CHECK = 4312 OR
251             ORDER_CHECK = 3421 OR ORDER_CHECK = 3412 THEN
252               COMMENT ( "ORDER_CHECK HAS VALUE " &
253                          INTEGER'IMAGE (ORDER_CHECK) & " - (H)" );
254          ELSE
255               FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " &
256                        "VALUE OF ORDER_CHECK SHOULD BE 4321, " &
257                        "4312, 3421, OR 3412 -- ACTUAL VALUE IS " &
258                         INTEGER'IMAGE (ORDER_CHECK) & " - (H)" );
259          END IF;
260     END; -- (H).
261
262     BUMP := 0;
263
264     DECLARE -- (I).
265          TYPE REC2 (D1, D2 : INTEGER) IS
266               RECORD
267                    COMP : INTEGER;
268               END RECORD;
269
270          R1 : REC2 (G  * 1000, H  * 10000) :=
271                    (G1 * 1000, H1 * 10000, F * 100);
272          R2 : REC2 (F, F * 10);
273     BEGIN
274          ORDER_CHECK := R1.D1 + R1.D2 + R1.COMP + R2.D1 + R2.D2;
275          IF ORDER_CHECK = 21354 OR ORDER_CHECK = 21345 OR
276             ORDER_CHECK = 12345 OR ORDER_CHECK = 12354 THEN
277               COMMENT ( "ORDER_CHECK HAS VALUE " &
278                          INTEGER'IMAGE (ORDER_CHECK) & " - (I)" );
279          ELSE
280               FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " &
281                        "VALUE OF ORDER_CHECK SHOULD BE 21354, " &
282                        "21345, 12354, OR 12345 -- ACTUAL VALUE IS " &
283                         INTEGER'IMAGE (ORDER_CHECK) & " - (I)" );
284          END IF;
285
286     END; -- (I).
287
288     BUMP := 0;
289
290     DECLARE -- (J).
291          PACKAGE P IS
292               TYPE PRIV (D : INTEGER) IS PRIVATE;
293
294               P1 : CONSTANT PRIV;
295               P2 : CONSTANT PRIV;
296
297               FUNCTION GET_A (P : PRIV) RETURN INTEGER;
298          PRIVATE
299               TYPE PRIV (D : INTEGER) IS
300                    RECORD
301                         COMP : INTEGER;
302                    END RECORD;
303               P1 : CONSTANT PRIV := (F , F * 10);
304               P2 : CONSTANT PRIV := (F * 100, F * 1000);
305          END P;
306
307          PACKAGE BODY P IS
308               FUNCTION GET_A (P : PRIV) RETURN INTEGER IS
309               BEGIN
310                    RETURN P.COMP;
311               END GET_A;
312          END P;
313
314          USE P;
315     BEGIN
316          ORDER_CHECK := P1.D + GET_A (P1) + P2.D + GET_A (P2);
317          IF ORDER_CHECK = 4321 OR ORDER_CHECK = 4312 OR
318             ORDER_CHECK = 3412 OR ORDER_CHECK = 3421 THEN
319               COMMENT ( "ORDER_CHECK HAS VALUE " &
320                          INTEGER'IMAGE (ORDER_CHECK) & " - (J)" );
321          ELSE
322               FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " &
323                        "VALUE OF ORDER_CHECK SHOULD BE 4321, " &
324                        "4312, 3421, OR 3412 -- ACTUAL VALUE IS " &
325                         INTEGER'IMAGE (ORDER_CHECK) & " - (J)" );
326          END IF;
327     END; -- (J).
328
329     BUMP := 0;
330
331     DECLARE -- (K).
332          PACKAGE P IS
333               TYPE PRIV (D1, D2 : INTEGER) IS PRIVATE;
334
335          PRIVATE
336               TYPE PRIV (D1, D2 : INTEGER) IS
337                    RECORD
338                         NULL;
339                    END RECORD;
340          END P;
341
342          USE P;
343
344          P1 : PRIV (F, F * 10);
345          P2 : PRIV (F * 100, F * 1000);
346
347     BEGIN
348          ORDER_CHECK := P1.D1 + P1.D2 + P2.D1 + P2.D2;
349          IF ORDER_CHECK = 4321 OR ORDER_CHECK = 4312 OR
350             ORDER_CHECK = 3412 OR ORDER_CHECK = 3421 THEN
351               COMMENT ( "ORDER_CHECK HAS VALUE " &
352                          INTEGER'IMAGE (ORDER_CHECK) & " - (K)" );
353          ELSE
354               FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " &
355                        "VALUE OF ORDER_CHECK SHOULD BE 4321, 4312, " &
356                        "3421, OR 3412 -- ACTUAL VALUE IS " &
357                         INTEGER'IMAGE (ORDER_CHECK) & " - (K)" );
358          END IF;
359
360     END; -- (K).
361
362     RESULT;
363END C32107A;
364