1-- C74203A.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-- OBJECTIVE:
26--     CHECK THAT MEMBERSHIP TESTS, QUALIFICATION, AND EXPLICIT
27--     CONVERSION ARE AVAILABLE FOR LIMITED AND NON-LIMITED PRIVATE
28--     TYPES.  INCLUDE TYPES WITH DISCRIMINANTS AND TYPES
29--     WITH LIMITED COMPONENTS.
30
31-- HISTORY:
32--     BCB 03/10/88  CREATED ORIGINAL TEST.
33
34WITH REPORT; USE REPORT;
35
36PROCEDURE C74203A IS
37
38     PACKAGE PP IS
39          TYPE LIM IS LIMITED PRIVATE;
40          PROCEDURE INIT (Z1 : OUT LIM; Z2 : INTEGER);
41
42          TYPE A IS PRIVATE;
43          SUBTYPE SUBA IS A;
44          A1 : CONSTANT A;
45
46          TYPE B IS LIMITED PRIVATE;
47          B1 : CONSTANT B;
48
49          TYPE C IS PRIVATE;
50          C1 : CONSTANT C;
51
52          TYPE D IS LIMITED PRIVATE;
53          D1 : CONSTANT D;
54
55          TYPE E (DISC1 : INTEGER := 5) IS PRIVATE;
56          SUBTYPE SUBE IS E;
57          E1 : CONSTANT E;
58
59          TYPE F (DISC2 : INTEGER := 15) IS LIMITED PRIVATE;
60          F1 : CONSTANT F;
61
62          TYPE G (DISC3 : INTEGER) IS PRIVATE;
63          G1 : CONSTANT G;
64
65          TYPE H (DISC4 : INTEGER) IS LIMITED PRIVATE;
66          H1 : CONSTANT H;
67
68          TYPE I IS RECORD
69               COMPI : LIM;
70          END RECORD;
71          SUBTYPE SUBI IS I;
72
73          TYPE J IS ARRAY(1..5) OF LIM;
74          SUBTYPE SUBJ IS J;
75
76          TYPE S1 IS (VINCE, TOM, PHIL, JODIE, ROSA, TERESA);
77          TYPE S2 IS (THIS, THAT, THESE, THOSE, THEM);
78          TYPE S3 IS RANGE 1 .. 100;
79          TYPE S4 IS RANGE 1 .. 100;
80     PRIVATE
81          TYPE LIM IS RANGE 1 .. 100;
82
83          TYPE A IS (RED, BLUE, GREEN, YELLOW, BLACK, WHITE);
84          A1 : CONSTANT A := BLUE;
85
86          TYPE B IS (ONE, TWO, THREE, FOUR, FIVE, SIX);
87          B1 : CONSTANT B := THREE;
88
89          TYPE C IS RANGE 1 .. 100;
90          C1 : CONSTANT C := 50;
91
92          TYPE D IS RANGE 1 .. 100;
93          D1 : CONSTANT D := 50;
94
95          TYPE E (DISC1 : INTEGER := 5) IS RECORD
96               COMPE : S1;
97          END RECORD;
98          E1 : CONSTANT E := (DISC1 => 5, COMPE => TOM);
99
100          TYPE F (DISC2 : INTEGER := 15) IS RECORD
101               COMPF : S2;
102          END RECORD;
103          F1 : CONSTANT F := (DISC2 => 15, COMPF => THAT);
104
105          TYPE G (DISC3 : INTEGER) IS RECORD
106               COMPG : S3;
107          END RECORD;
108          G1 : CONSTANT G := (DISC3 => 25, COMPG => 50);
109
110          TYPE H (DISC4 : INTEGER) IS RECORD
111               COMPH : S4;
112          END RECORD;
113          H1 : CONSTANT H := (DISC4 => 30, COMPH => 50);
114     END PP;
115
116     USE PP;
117
118     AVAR : SUBA := A1;
119     EVAR : SUBE := E1;
120
121     IVAR : SUBI;
122     JVAR : SUBJ;
123
124     PACKAGE BODY PP IS
125          PROCEDURE INIT (Z1 : OUT LIM; Z2 : INTEGER) IS
126          BEGIN
127               Z1 := LIM (Z2);
128          END INIT;
129     BEGIN
130          NULL;
131     END PP;
132
133     PROCEDURE QUAL_PRIV (W : A) IS
134     BEGIN
135          NULL;
136     END QUAL_PRIV;
137
138     PROCEDURE QUAL_LIM_PRIV (X : B) IS
139     BEGIN
140          NULL;
141     END QUAL_LIM_PRIV;
142
143     PROCEDURE EXPL_CONV_PRIV_1 (Y : C) IS
144     BEGIN
145          NULL;
146     END EXPL_CONV_PRIV_1;
147
148     PROCEDURE EXPL_CONV_LIM_PRIV_1 (Z : D) IS
149     BEGIN
150          NULL;
151     END EXPL_CONV_LIM_PRIV_1;
152
153     PROCEDURE EXPL_CONV_PRIV_2 (Y2 : G) IS
154     BEGIN
155          NULL;
156     END EXPL_CONV_PRIV_2;
157
158     PROCEDURE EXPL_CONV_LIM_PRIV_2 (Z2 : H) IS
159     BEGIN
160          NULL;
161     END EXPL_CONV_LIM_PRIV_2;
162
163     PROCEDURE EXPL_CONV_PRIV_3 (Y3 : I) IS
164     BEGIN
165          NULL;
166     END EXPL_CONV_PRIV_3;
167
168     PROCEDURE EXPL_CONV_PRIV_4 (Y4 : J) IS
169     BEGIN
170          NULL;
171     END EXPL_CONV_PRIV_4;
172
173BEGIN
174     TEST ("C74203A", "CHECK THAT MEMBERSHIP TESTS, QUALIFICATION, " &
175                      "AND EXPLICIT CONVERSION ARE AVAILABLE FOR " &
176                      "LIMITED AND NON-LIMITED PRIVATE TYPES.  " &
177                      "INCLUDE TYPES WITH DISCRIMINANTS AND " &
178                      "TYPES WITH LIMITED COMPONENTS");
179
180     INIT (IVAR.COMPI, 50);
181
182     FOR K IN IDENT_INT (1) .. IDENT_INT (5) LOOP
183          INIT (JVAR(K), 25);
184     END LOOP;
185
186     IF NOT (AVAR IN A) THEN
187          FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'IN' FOR " &
188                  "PRIVATE TYPE - 1");
189     END IF;
190
191     IF (AVAR NOT IN A) THEN
192          FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'NOT IN' FOR " &
193                  "PRIVATE TYPE - 1");
194     END IF;
195
196     IF NOT (B1 IN B) THEN
197          FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'IN' FOR " &
198                  "LIMITED PRIVATE TYPE - 1");
199     END IF;
200
201     IF (B1 NOT IN B) THEN
202          FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'NOT IN' FOR " &
203                  "LIMITED PRIVATE TYPE - 1");
204     END IF;
205
206     QUAL_PRIV (A'(AVAR));
207
208     QUAL_LIM_PRIV (B'(B1));
209
210     EXPL_CONV_PRIV_1 (C(C1));
211
212     EXPL_CONV_LIM_PRIV_1 (D(D1));
213
214     IF NOT (EVAR IN E) THEN
215          FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'IN' FOR " &
216                  "PRIVATE TYPE - 2");
217     END IF;
218
219     IF (EVAR NOT IN E) THEN
220          FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'NOT IN' FOR " &
221                  "PRIVATE TYPE - 2");
222     END IF;
223
224     IF NOT (F1 IN F) THEN
225          FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'IN' FOR " &
226                  "LIMITED PRIVATE TYPE - 2");
227     END IF;
228
229     IF (F1 NOT IN F) THEN
230          FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'NOT IN' FOR " &
231                  "LIMITED PRIVATE TYPE - 2");
232     END IF;
233
234     EXPL_CONV_PRIV_2 (G(G1));
235
236     EXPL_CONV_LIM_PRIV_2 (H(H1));
237
238     IF NOT (IVAR IN I) THEN
239          FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'IN' FOR " &
240                  "PRIVATE TYPE - 3");
241     END IF;
242
243     IF (IVAR NOT IN I) THEN
244          FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'NOT IN' FOR " &
245                  "PRIVATE TYPE - 3");
246     END IF;
247
248     EXPL_CONV_PRIV_3 (I(IVAR));
249
250     IF NOT (JVAR IN J) THEN
251          FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'IN' FOR " &
252                  "PRIVATE TYPE - 4");
253     END IF;
254
255     IF (JVAR NOT IN J) THEN
256          FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'NOT IN' FOR " &
257                  "PRIVATE TYPE - 4");
258     END IF;
259
260     EXPL_CONV_PRIV_4 (J(JVAR));
261
262     RESULT;
263END C74203A;
264