1-- C32001E.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 IN MULTIPLE OBJECT DECLARATIONS FOR PRIVATE TYPES, THE
26-- SUBTYPE INDICATION AND THE INITIALIZATION EXPRESSIONS ARE EVALUATED
27-- ONCE FOR EACH NAMED OBJECT THAT IS DECLARED AND THE SUBTYPE
28-- INDICATION IS EVALUATED FIRST.  ALSO, CHECK THAT THE EVALUATIONS
29-- YIELD THE SAME RESULT AS A SEQUENCE OF SINGLE OBJECT DECLARATIONS.
30
31-- RJW 7/18/86
32
33WITH REPORT; USE REPORT;
34
35PROCEDURE C32001E IS
36
37     BUMP : ARRAY (1 .. 10) OF INTEGER := (OTHERS => 0);
38     G1 : ARRAY (5 .. 6) OF INTEGER;
39
40     FUNCTION F (I : INTEGER) RETURN INTEGER IS
41     BEGIN
42          BUMP (I) := BUMP (I) + 1;
43          RETURN BUMP (I);
44     END F;
45
46     FUNCTION G (I : INTEGER) RETURN INTEGER IS
47     BEGIN
48          BUMP (I) := BUMP (I) + 1;
49          G1 (I) := BUMP (I);
50          RETURN BUMP (I);
51     END G;
52
53BEGIN
54     TEST ("C32001E", "CHECK THAT IN MULTIPLE OBJECT DECLARATIONS " &
55                      "FOR PRIVATE TYPES, THE SUBTYPE INDICATION " &
56                      "AND THE INITIALIZATION EXPRESSIONS ARE " &
57                      "EVALUATED ONCE FOR EACH NAMED OBJECT THAT " &
58                      "IS DECLARED AND THE SUBTYPE INDICATION IS " &
59                      "EVALUATED FIRST.  ALSO, CHECK THAT THE " &
60                      "EVALUATIONS YIELD THE SAME RESULT AS A " &
61                      "SEQUENCE OF SINGLE OBJECT DECLARATIONS" );
62
63     DECLARE
64          PACKAGE PKG1 IS
65               TYPE PBOOL IS PRIVATE;
66               TYPE PINT IS PRIVATE;
67               TYPE PREC (D : INTEGER) IS PRIVATE;
68               TYPE PARR IS PRIVATE;
69               TYPE PACC IS PRIVATE;
70
71               FUNCTION INIT1 (I : INTEGER) RETURN PBOOL;
72               FUNCTION INIT2 (I : INTEGER) RETURN PINT;
73               FUNCTION INIT3 (I : INTEGER) RETURN PREC;
74               FUNCTION INIT4 (I : INTEGER) RETURN PARR;
75               FUNCTION INIT5 (I : INTEGER) RETURN PACC;
76
77               PROCEDURE CHECK1 (B : PBOOL; I : INTEGER; S : STRING);
78               PROCEDURE CHECK2 (I : PINT;  J : INTEGER; S : STRING);
79               PROCEDURE CHECK3 (R : PREC;  I, J : INTEGER;
80                                 S : STRING);
81               PROCEDURE CHECK4 (A : PARR;  I, J : INTEGER;
82                                 S : STRING);
83               PROCEDURE CHECK5 (V : PACC; S : STRING);
84               PROCEDURE CHECK6 (V : PACC; S : STRING);
85
86          PRIVATE
87               TYPE PBOOL IS NEW BOOLEAN;
88               TYPE PINT IS NEW INTEGER;
89
90               TYPE PREC (D : INTEGER) IS
91                    RECORD
92                         VALUE : INTEGER;
93                    END RECORD;
94
95               TYPE PARR IS ARRAY (1 .. 2) OF INTEGER;
96
97               TYPE VECTOR IS ARRAY (NATURAL RANGE <>) OF INTEGER;
98               TYPE PACC IS ACCESS VECTOR;
99          END PKG1;
100
101          PACKAGE BODY PKG1 IS
102               FUNCTION INIT1 (I : INTEGER) RETURN PBOOL IS
103               BEGIN
104                    RETURN PBOOL'VAL (F (I) - 1);
105               END INIT1;
106
107               FUNCTION INIT2 (I : INTEGER) RETURN PINT IS
108               BEGIN
109                    RETURN PINT'VAL (F (I));
110               END INIT2;
111
112               FUNCTION INIT3 (I : INTEGER) RETURN PREC IS
113                    PR : PREC (G1 (I)) := (G1 (I), F (I));
114               BEGIN
115                    RETURN PR;
116               END INIT3;
117
118               FUNCTION INIT4 (I : INTEGER) RETURN PARR IS
119                    PA : PARR := (1 .. 2 => F (I));
120               BEGIN
121                    RETURN PA;
122               END INIT4;
123
124               FUNCTION INIT5 (I : INTEGER) RETURN PACC IS
125                    ACCV : PACC := NEW VECTOR'(1 .. F (I) => F (I));
126               BEGIN
127                    RETURN ACCV;
128               END INIT5;
129
130               PROCEDURE CHECK1 (B : PBOOL; I : INTEGER; S : STRING) IS
131               BEGIN
132                    IF B /= PBOOL'VAL (I) THEN
133                         FAILED ( S & " HAS AN INCORRECT VALUE OF " &
134                                  PBOOL'IMAGE (B));
135                    END IF;
136               END CHECK1;
137
138               PROCEDURE CHECK2 (I : PINT; J : INTEGER; S : STRING) IS
139               BEGIN
140                    IF I /= PINT'VAL (J) THEN
141                         FAILED ( S & " HAS AN INCORRECT VALUE OF " &
142                                  PINT'IMAGE (I));
143                    END IF;
144               END CHECK2;
145
146               PROCEDURE CHECK3 (R : PREC; I, J : INTEGER;
147                                 S : STRING) IS
148               BEGIN
149                    IF R.D /= I THEN
150                         FAILED ( S & ".D HAS AN INCORRECT VALUE OF "
151                                  & INTEGER'IMAGE (R.D));
152                    END IF;
153
154                    IF R.VALUE /= J THEN
155                         FAILED ( S & ".VALUE HAS AN INCORRECT " &
156                                  "VALUE OF " &
157                                  INTEGER'IMAGE (R.VALUE));
158                    END IF;
159               END CHECK3;
160
161               PROCEDURE CHECK4 (A : PARR; I, J : INTEGER;
162                                 S : STRING) IS
163               BEGIN
164                    IF A /= (I, J) AND A /= (J, I) THEN
165                         FAILED ( S & " HAS AN INCORRECT VALUE" );
166                    END IF;
167               END CHECK4;
168
169               PROCEDURE CHECK5 (V : PACC; S : STRING) IS
170               BEGIN
171                    IF V'LAST /= 1 THEN
172                         FAILED ( S & " HAS AN INCORRECT UPPER BOUND "
173                                  & "OF " & INTEGER'IMAGE (V'LAST));
174                    END IF;
175
176                    IF V (1) /= 2 THEN
177                         FAILED ( S & " HAS AN INCORRECT COMPONENT " &
178                                  "VALUE" );
179                    END IF;
180               END CHECK5;
181
182               PROCEDURE CHECK6 (V : PACC; S : STRING) IS
183               BEGIN
184                    IF V'LAST /= 3 THEN
185                         FAILED ( S & " HAS AN INCORRECT UPPER BOUND "
186                                  & "OF " & INTEGER'IMAGE (V'LAST));
187                    END IF;
188
189                    IF V.ALL = (4, 5, 6) OR V.ALL = (5, 4, 6) OR
190                       V.ALL = (4, 6, 5) OR V.ALL = (6, 4, 5) OR
191                       V.ALL = (5, 6, 4) OR V.ALL = (6, 5, 4) THEN
192                         NULL;
193                    ELSE
194                         FAILED ( S & " HAS AN INCORRECT COMPONENT " &
195                                  "VALUE" );
196                    END IF;
197               END CHECK6;
198
199          END PKG1;
200
201          PACKAGE PKG2 IS END PKG2;
202
203          PACKAGE BODY PKG2 IS
204               USE PKG1;
205
206               B1, B2   : PBOOL := INIT1 (1);
207               CB1, CB2 : CONSTANT PBOOL := INIT1 (2);
208
209               I1, I2   : PINT := INIT2 (3);
210               CI1, CI2 : CONSTANT PINT := INIT2 (4);
211
212               R1, R2   : PREC (G (5)) := INIT3 (5);
213               CR1, CR2 : CONSTANT PREC (G (6)) := INIT3 (6);
214
215               A1, A2   : PARR := INIT4 (7);
216               CA1, CA2 : CONSTANT PARR := INIT4 (8);
217
218               V1, V2   : PACC  := INIT5 (9);
219               CV1, CV2 : CONSTANT PACC  := INIT5 (10);
220
221          BEGIN
222               CHECK1 (B1, 0, "B1");
223               CHECK1 (B2, 1, "B2");
224               CHECK1 (CB1, 0, "CB1");
225               CHECK1 (CB2, 1, "CB2");
226
227               CHECK2 (I1, 1, "I1");
228               CHECK2 (I2, 2, "I2");
229               CHECK2 (CI1, 1, "CI1");
230               CHECK2 (CI2, 2, "CI2");
231
232               CHECK3 (R1, 1, 2, "R1");
233               CHECK3 (R2, 3, 4, "R2");
234               CHECK3 (CR1, 1, 2, "CR1");
235               CHECK3 (CR2, 3, 4, "CR2");
236
237               CHECK4 (A1, 1, 2, "A1");
238               CHECK4 (A2, 3, 4, "A2");
239               CHECK4 (CA1, 1, 2, "CA1");
240               CHECK4 (CA2, 3, 4, "CA2");
241
242               CHECK5 (V1, "V1");
243               CHECK6 (V2, "V2");
244               CHECK5 (CV1, "CV1");
245               CHECK6 (CV2, "CV2");
246      END PKG2;
247
248     BEGIN
249          NULL;
250     END;
251
252     RESULT;
253END C32001E;
254