1-- C34014P.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 A DERIVED OPERATOR IS VISIBLE AND FURTHER DERIVABLE
27--     UNDER APPROPRIATE CIRCUMSTANCES.
28
29--     CHECK WHEN THE DERIVED OPERATOR IS IMPLICITLY DECLARED IN THE
30--     VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC OPERATOR IS LATER
31--     DECLARED EXPLICITLY IN THE PRIVATE PART.
32
33-- HISTORY:
34--     JRK 09/22/87  CREATED ORIGINAL TEST.
35--     GJD 11/15/95  REMOVED ADA 83 INCOMPATIBILITIES.
36--     PWN 04/11/96  Restored subtests in Ada95 legal format.
37
38WITH REPORT; USE REPORT;
39
40PROCEDURE C34014P IS
41
42     PACKAGE P IS
43          TYPE T IS RANGE -100 .. 100;
44          FUNCTION "+" (X : T) RETURN T;
45     END P;
46     USE P;
47
48     PACKAGE BODY P IS
49          FUNCTION "+" (X : T) RETURN T IS
50          BEGIN
51               RETURN X + T (IDENT_INT (1));
52          END "+";
53     END P;
54
55BEGIN
56     TEST ("C34014P", "CHECK THAT A DERIVED OPERATOR IS VISIBLE " &
57                      "AND FURTHER DERIVABLE UNDER APPROPRIATE " &
58                      "CIRCUMSTANCES.  CHECK WHEN THE DERIVED " &
59                      "OPERATOR IS IMPLICITLY DECLARED IN THE " &
60                      "VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC " &
61                      "OPERATOR IS LATER DECLARED EXPLICITLY IN " &
62                      "THE PRIVATE PART");
63
64     -----------------------------------------------------------------
65
66     COMMENT ("NEW OPERATOR DECLARED BY SUBPROGRAM DECLARATION");
67
68     DECLARE
69
70          PACKAGE Q IS
71               TYPE QT IS NEW T;
72               X : QT := +0;
73          PRIVATE
74               FUNCTION "+" (Y : QT) RETURN QT;
75               TYPE QR IS
76                    RECORD
77                         C : QT := +0;
78                    END RECORD;
79               TYPE QS IS NEW QT;
80          END Q;
81          USE Q;
82
83          PACKAGE BODY Q IS
84               FUNCTION "+" (Y : QT) RETURN QT IS
85               BEGIN
86                    RETURN Y + QT (IDENT_INT (2));
87               END "+";
88
89               PACKAGE R IS
90                    Y : QR;
91                    Z : QS := +0;
92               END R;
93               USE R;
94          BEGIN
95               IF X /= 1 THEN
96                    FAILED ("OLD OPERATOR NOT VISIBLE - SUBPROG " &
97                            "DECL - 1");
98               END IF;
99
100               IF Y.C /= 2 THEN
101                    FAILED ("NEW OPERATOR NOT VISIBLE - SUBPROG " &
102                            "DECL");
103               END IF;
104
105               IF Z /= 2 THEN
106                   FAILED ("OLD OPERATOR NOT DERIVED - SUBPROG " &
107                            "DECL - 1");
108               END IF;
109          END Q;
110
111          PACKAGE R IS
112               Y : QT := +0;
113               TYPE RT IS NEW QT;
114               Z : RT := +0;
115          END R;
116          USE R;
117
118     BEGIN
119          IF Y /= 1 THEN
120               FAILED ("OLD OPERATOR NOT VISIBLE - SUBPROG DECL - 2");
121          END IF;
122
123          IF Z /= 1 THEN
124               FAILED ("OLD OPERATOR NOT DERIVED - SUBPROG DECL - 2");
125          END IF;
126     END;
127
128     -----------------------------------------------------------------
129
130     COMMENT ("NEW OPERATOR DECLARED BY RENAMING");
131
132     DECLARE
133
134          PACKAGE Q IS
135               TYPE QT IS NEW T;
136               X : QT := +0;
137          PRIVATE
138               FUNCTION G (X : QT) RETURN QT;
139               FUNCTION "+" (Y : QT) RETURN QT RENAMES G;
140               TYPE QR IS
141                    RECORD
142                         C : QT := +0;
143                    END RECORD;
144               TYPE QS IS NEW QT;
145          END Q;
146          USE Q;
147
148          PACKAGE BODY Q IS
149               FUNCTION G (X : QT) RETURN QT IS
150               BEGIN
151                    RETURN X + QT (IDENT_INT (2));
152               END G;
153
154               PACKAGE R IS
155                    Y : QR;
156                    Z : QS := +0;
157               END R;
158               USE R;
159          BEGIN
160               IF X /= 1 THEN
161                    FAILED ("OLD OPERATOR NOT VISIBLE - RENAMING - " &
162                            "1");
163               END IF;
164
165               IF Y.C /= 2 THEN
166                    FAILED ("NEW OPERATOR NOT VISIBLE - RENAMING");
167               END IF;
168
169           IF Z /= 2 THEN
170                FAILED ("OLD OPERATOR NOT DERIVED - RENAMING - " &
171                            "1");
172           END IF;
173          END Q;
174
175          PACKAGE R IS
176               Y : QT := +0;
177               TYPE RT IS NEW QT;
178               Z : RT := +0;
179          END R;
180          USE R;
181
182     BEGIN
183          IF Y /= 1 THEN
184               FAILED ("OLD OPERATOR NOT VISIBLE - RENAMING - 2");
185          END IF;
186
187          IF Z /= 1 THEN
188               FAILED ("OLD OPERATOR NOT DERIVED - RENAMING - 2");
189          END IF;
190     END;
191
192     -----------------------------------------------------------------
193
194     COMMENT ("NEW OPERATOR DECLARED BY GENERIC INSTANTIATION");
195
196     DECLARE
197
198          GENERIC
199               TYPE T IS RANGE <>;
200          FUNCTION G (Y : T) RETURN T;
201
202          FUNCTION G (Y : T) RETURN T IS
203          BEGIN
204               RETURN Y + T (IDENT_INT (2));
205          END G;
206
207          PACKAGE Q IS
208               TYPE QT IS NEW T;
209               X : QT := +0;
210          PRIVATE
211               FUNCTION "+" IS NEW G (QT);
212               W : QT := +0;
213               TYPE QS IS NEW QT;
214               Z : QS := +0;
215          END Q;
216          USE Q;
217
218          PACKAGE BODY Q IS
219          BEGIN
220               IF X /= 1 THEN
221                    FAILED ("OLD OPERATOR NOT VISIBLE - " &
222                            "INSTANTIATION - 1");
223               END IF;
224
225               IF W /= 2 THEN
226                    FAILED ("NEW OPERATOR NOT VISIBLE - " &
227                            "INSTANTIATION");
228               END IF;
229
230               IF Z /= 2 THEN
231                    FAILED ("OLD OPERATOR NOT DERIVED - " &
232                            "INSTANTIATION - 1");
233               END IF;
234          END Q;
235
236          PACKAGE R IS
237               Y : QT := +0;
238               TYPE RT IS NEW QT;
239               Z : RT := +0;
240          END R;
241          USE R;
242
243     BEGIN
244          IF Y /= 1 THEN
245               FAILED ("OLD OPERATOR NOT VISIBLE - INSTANTIATION - " &
246                       "2");
247          END IF;
248
249          IF Z /= 1 THEN
250               FAILED ("OLD OPERATOR NOT DERIVED - INSTANTIATION - " &
251                       "2");
252          END IF;
253     END;
254
255     -----------------------------------------------------------------
256
257     RESULT;
258END C34014P;
259