1-- C34009J.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 THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED
27--     (IMPLICITLY) FOR DERIVED LIMITED PRIVATE TYPES WITH
28--     DISCRIMINANTS.
29
30-- HISTORY:
31--     JRK 09/01/87  CREATED ORIGINAL TEST.
32--     WMC 03/13/92  REVISED TYPE'SIZE CHECKS.
33--     PWN 01/31/95  REMOVED INCONSISTENCIES WITH ADA 9X.
34
35WITH SYSTEM; USE SYSTEM;
36WITH REPORT; USE REPORT;
37
38PROCEDURE C34009J IS
39
40     PACKAGE PKG IS
41
42          MAX_LEN : CONSTANT := 10;
43
44          SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN;
45
46          TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 3) IS
47                      LIMITED PRIVATE;
48
49          FUNCTION CREATE ( B : BOOLEAN;
50                            L : LENGTH;
51                            I : INTEGER;
52                            S : STRING;
53                            J : INTEGER;
54                            F : FLOAT;
55                            X : PARENT  -- TO RESOLVE OVERLOADING.
56                          ) RETURN PARENT;
57
58          FUNCTION CON ( B : BOOLEAN;
59                         L : LENGTH;
60                         I : INTEGER;
61                         S : STRING;
62                         J : INTEGER
63                       ) RETURN PARENT;
64
65          FUNCTION CON ( B : BOOLEAN;
66                         L : LENGTH;
67                         I : INTEGER;
68                         F : FLOAT
69                       ) RETURN PARENT;
70
71          FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN;
72
73          PROCEDURE ASSIGN (X : OUT PARENT; Y : PARENT);
74
75     PRIVATE
76
77          TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 3) IS
78               RECORD
79                    I : INTEGER := 2;
80                    CASE B IS
81                         WHEN TRUE =>
82                              S : STRING (1 .. L) := (1 .. L => 'A');
83                              J : INTEGER := 2;
84                         WHEN FALSE =>
85                              F : FLOAT := 5.0;
86                    END CASE;
87               END RECORD;
88
89     END PKG;
90
91     USE PKG;
92
93     TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3));
94
95     X : T;
96     W : PARENT;
97     B : BOOLEAN := FALSE;
98
99     PROCEDURE A (X : ADDRESS) IS
100     BEGIN
101          B := IDENT_BOOL (TRUE);
102     END A;
103
104     PACKAGE BODY PKG IS
105
106          FUNCTION CREATE
107             ( B : BOOLEAN;
108               L : LENGTH;
109               I : INTEGER;
110               S : STRING;
111               J : INTEGER;
112               F : FLOAT;
113               X : PARENT
114             ) RETURN PARENT
115          IS
116          BEGIN
117               CASE B IS
118                    WHEN TRUE =>
119                         RETURN (TRUE, L, I, S, J);
120                    WHEN FALSE =>
121                         RETURN (FALSE, L, I, F);
122               END CASE;
123          END CREATE;
124
125          FUNCTION CON
126             ( B : BOOLEAN;
127               L : LENGTH;
128               I : INTEGER;
129               S : STRING;
130               J : INTEGER
131             ) RETURN PARENT
132          IS
133          BEGIN
134               RETURN (TRUE, L, I, S, J);
135          END CON;
136
137          FUNCTION CON
138             ( B : BOOLEAN;
139               L : LENGTH;
140               I : INTEGER;
141               F : FLOAT
142             ) RETURN PARENT
143          IS
144          BEGIN
145               RETURN (FALSE, L, I, F);
146          END CON;
147
148          FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS
149          BEGIN
150               RETURN X = Y;
151          END EQUAL;
152
153          PROCEDURE ASSIGN (X : OUT PARENT; Y : PARENT) IS
154          BEGIN
155               X := Y;
156          END ASSIGN;
157
158     END PKG;
159
160BEGIN
161     TEST ("C34009J", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
162                      "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
163                      "LIMITED PRIVATE TYPES WITH DISCRIMINANTS");
164
165     IF EQUAL (3, 3) THEN
166          ASSIGN (X, CON (TRUE, 3, 1, "ABC", 4));
167     END IF;
168     IF NOT EQUAL (T'(X), CON (TRUE, 3, 1, "ABC", 4)) THEN
169          FAILED ("INCORRECT QUALIFICATION");
170     END IF;
171
172     IF NOT EQUAL (T (X), CON (TRUE, 3, 1, "ABC", 4)) THEN
173          FAILED ("INCORRECT SELF CONVERSION");
174     END IF;
175
176     IF EQUAL (3, 3) THEN
177          ASSIGN (W, CON (TRUE, 3, 1, "ABC", 4));
178     END IF;
179     IF NOT EQUAL (T (W), CON (TRUE, 3, 1, "ABC", 4)) THEN
180          FAILED ("INCORRECT CONVERSION FROM PARENT");
181     END IF;
182
183     IF NOT EQUAL (PARENT (X), CON (TRUE, 3, 1, "ABC", 4)) OR
184        NOT EQUAL (PARENT (CREATE (FALSE, 2, 3, "XX", 5, 6.0, X)),
185                   CON (FALSE, 2, 3, 6.0)) THEN
186          FAILED ("INCORRECT CONVERSION TO PARENT");
187     END IF;
188
189     IF X.B /= TRUE OR X.L /= 3 OR
190        CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . B /= FALSE OR
191        CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . L /= 2 THEN
192          FAILED ("INCORRECT SELECTION (DISCRIMINANT)");
193     END IF;
194
195     IF NOT (X IN T) OR CON (FALSE, 2, 3, 6.0) IN T THEN
196          FAILED ("INCORRECT ""IN""");
197     END IF;
198
199     IF X NOT IN T OR NOT (CON (FALSE, 2, 3, 6.0) NOT IN T) THEN
200          FAILED ("INCORRECT ""NOT IN""");
201     END IF;
202
203     B := FALSE;
204     A (X'ADDRESS);
205     IF NOT B THEN
206          FAILED ("INCORRECT 'ADDRESS");
207     END IF;
208
209
210     IF NOT X'CONSTRAINED THEN
211          FAILED ("INCORRECT OBJECT'CONSTRAINED");
212     END IF;
213
214     IF T'SIZE <= 0 THEN
215          FAILED ("INCORRECT TYPE'SIZE");
216     END IF;
217
218     IF X'SIZE   < T'SIZE OR
219        X.B'SIZE < BOOLEAN'SIZE OR
220        X.L'SIZE < LENGTH'SIZE THEN
221          FAILED ("INCORRECT OBJECT'SIZE");
222     END IF;
223
224     RESULT;
225END C34009J;
226