1-- C731001.A
2--
3--                             Grant of Unlimited Rights
4--
5--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and
6--     F08630-91-C-0015, the U.S. Government obtained unlimited rights in the
7--     software and documentation contained herein.  Unlimited rights are
8--     defined in DFAR 252.227-7013(a)(19).  By making this public release,
9--     the Government intends to confer upon all recipients unlimited rights
10--     equal to those held by the Government.  These rights include rights to
11--     use, duplicate, release or disclose the released technical data and
12--     computer software in whole or in part, in any manner and for any purpose
13--     whatsoever, and to have or permit others to do so.
14--
15--                                    DISCLAIMER
16--
17--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
18--     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
19--     WARRANTY AS TO ANY MATTER WHATSOVER, INCLUDING THE CONDITIONS OF THE
20--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
21--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
22--     PARTICULAR PURPOSE OF SAID MATERIAL.
23--*
24--
25-- OBJECTIVE
26--     Check that inherited operations can be overridden, even when they are
27--     inherited in a body.
28--     The test cases here are inspired by the AARM examples given in
29--     the discussion of AARM-7.3.1(7.a-7.v).
30--     This discussion was confirmed by AI95-00035.
31--
32-- TEST DESCRIPTION
33--     See AARM-7.3.1.
34--
35-- CHANGE HISTORY:
36--      29 JUN 1999   RAD   Initial Version
37--      23 SEP 1999   RLB   Improved comments, renamed, issued.
38--      20 AUG 2001   RLB   Corrected 'verbose' flag.
39--
40--!
41
42with Report; use Report; pragma Elaborate_All(Report);
43package C731001_1 is
44    pragma Elaborate_Body;
45private
46    procedure Check_String(X, Y: String);
47    function Check_String(X, Y: String) return String;
48        -- This one is a function, so we can call it in package specs.
49end C731001_1;
50
51package body C731001_1 is
52
53    Verbose: Boolean := False;
54
55    procedure Check_String(X, Y: String) is
56    begin
57        if Verbose then
58            Comment("""" & X & """ = """ & Y & """?");
59        end if;
60        if X /= Y then
61            Failed("""" & X & """ should be """ & Y & """");
62        end if;
63    end Check_String;
64
65    function Check_String(X, Y: String) return String is
66    begin
67        Check_String(X, Y);
68        return X;
69    end Check_String;
70
71end C731001_1;
72
73private package C731001_1.Parent is
74
75    procedure Call_Main;
76
77    type Root is tagged null record;
78    subtype Renames_Root is Root;
79    subtype Root_Class is Renames_Root'Class;
80    function Make return Root;
81    function Op1(X: Root) return String;
82    function Call_Op2(X: Root'Class) return String;
83private
84    function Op2(X: Root) return String;
85end C731001_1.Parent;
86
87procedure C731001_1.Parent.Main;
88
89with C731001_1.Parent.Main;
90package body C731001_1.Parent is
91
92    procedure Call_Main is
93    begin
94        Main;
95    end Call_Main;
96
97    function Make return Root is
98        Result: Root;
99    begin
100        return Result;
101    end Make;
102
103    function Op1(X: Root) return String is
104    begin
105        return "Parent.Op1 body";
106    end Op1;
107
108    function Op2(X: Root) return String is
109    begin
110        return "Parent.Op2 body";
111    end Op2;
112
113    function Call_Op2(X: Root'Class) return String is
114    begin
115        return Op2(X);
116    end Call_Op2;
117
118begin
119
120    Check_String(Op1(Root'(Make)), "Parent.Op1 body");
121    Check_String(Op1(Root_Class(Root'(Make))), "Parent.Op1 body");
122
123    Check_String(Op2(Root'(Make)), "Parent.Op2 body");
124    Check_String(Op2(Root_Class(Root'(Make))), "Parent.Op2 body");
125
126end C731001_1.Parent;
127
128with C731001_1.Parent; use C731001_1.Parent;
129private package C731001_1.Unrelated is
130
131    type T2 is new Root with null record;
132    subtype T2_Class is T2'Class;
133    function Make return T2;
134    function Op2(X: T2) return String;
135end C731001_1.Unrelated;
136
137with C731001_1.Parent; use C731001_1.Parent;
138    pragma Elaborate(C731001_1.Parent);
139package body C731001_1.Unrelated is
140
141    function Make return T2 is
142        Result: T2;
143    begin
144        return Result;
145    end Make;
146
147    function Op2(X: T2) return String is
148    begin
149        return "Unrelated.Op2 body";
150    end Op2;
151begin
152
153    Check_String(Op1(T2'(Make)), "Parent.Op1 body");
154    Check_String(Op1(T2_Class(T2'(Make))), "Parent.Op1 body");
155    Check_String(Op1(Root_Class(T2'(Make))), "Parent.Op1 body");
156
157    Check_String(Op2(T2'(Make)), "Unrelated.Op2 body");
158    Check_String(Op2(T2_Class(T2'(Make))), "Unrelated.Op2 body");
159    Check_String(Call_Op2(T2'(Make)), "Parent.Op2 body");
160    Check_String(Call_Op2(T2_Class(T2'(Make))), "Parent.Op2 body");
161    Check_String(Call_Op2(Root_Class(T2'(Make))), "Parent.Op2 body");
162
163end C731001_1.Unrelated;
164
165package C731001_1.Parent.Child is
166    pragma Elaborate_Body;
167
168    type T3 is new Root with null record;
169    subtype T3_Class is T3'Class;
170    function Make return T3;
171
172    T3_Obj: T3;
173    T3_Class_Obj: T3_Class := T3_Obj;
174    T3_Root_Class_Obj: Root_Class := T3_Obj;
175
176    X3: constant String :=
177      Check_String(Op1(T3_Obj), "Parent.Op1 body") &
178      Check_String(Op1(T3_Class_Obj), "Parent.Op1 body") &
179      Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body") &
180
181      Check_String(Call_Op2(T3_Obj), "Parent.Op2 body") &
182      Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body") &
183      Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body");
184
185    package Nested is
186        type T4 is new Root with null record;
187        subtype T4_Class is T4'Class;
188        function Make return T4;
189
190        T4_Obj: T4;
191        T4_Class_Obj: T4_Class := T4_Obj;
192        T4_Root_Class_Obj: Root_Class := T4_Obj;
193
194        X4: constant String :=
195          Check_String(Op1(T4_Obj), "Parent.Op1 body") &
196          Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
197          Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
198
199          Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
200          Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
201          Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body");
202
203    private
204
205        XX4: constant String :=
206          Check_String(Op1(T4_Obj), "Parent.Op1 body") &
207          Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
208          Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
209
210          Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
211          Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
212          Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body");
213
214    end Nested;
215
216    use Nested;
217
218    XXX4: constant String :=
219      Check_String(Op1(T4_Obj), "Parent.Op1 body") &
220      Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
221      Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
222
223      Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
224      Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
225      Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body");
226
227private
228
229    XX3: constant String :=
230      Check_String(Op1(T3_Obj), "Parent.Op1 body") &
231      Check_String(Op1(T3_Class_Obj), "Parent.Op1 body") &
232      Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body") &
233
234      Check_String(Call_Op2(T3_Obj), "Parent.Op2 body") &
235      Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body") &
236      Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body") &
237
238      Check_String(Op2(T3_Obj), "Parent.Op2 body") &
239      Check_String(Op2(T3_Class_Obj), "Parent.Op2 body") &
240      Check_String(Op2(T3_Root_Class_Obj), "Parent.Op2 body");
241
242    XXXX4: constant String :=
243      Check_String(Op1(T4_Obj), "Parent.Op1 body") &
244      Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
245      Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
246
247      Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
248      Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
249      Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") &
250
251      Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body");
252
253end C731001_1.Parent.Child;
254
255with C731001_1.Unrelated; use C731001_1.Unrelated;
256    pragma Elaborate(C731001_1.Unrelated);
257package body C731001_1.Parent.Child is
258
259    XXX3: constant String :=
260      Check_String(Op1(T3_Obj), "Parent.Op1 body") &
261      Check_String(Op1(T3_Class_Obj), "Parent.Op1 body") &
262      Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body") &
263
264      Check_String(Call_Op2(T3_Obj), "Parent.Op2 body") &
265      Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body") &
266      Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body") &
267
268      Check_String(Op2(T3_Obj), "Parent.Op2 body") &
269      Check_String(Op2(T3_Class_Obj), "Parent.Op2 body") &
270      Check_String(Op2(T3_Root_Class_Obj), "Parent.Op2 body");
271
272    XXXXX4: constant String :=
273      Check_String(Op1(T4_Obj), "Parent.Op1 body") &
274      Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
275      Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
276
277      Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
278      Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
279      Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") &
280
281      Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body");
282
283    function Make return T3 is
284        Result: T3;
285    begin
286        return Result;
287    end Make;
288
289    package body Nested is
290        function Make return T4 is
291            Result: T4;
292        begin
293            return Result;
294        end Make;
295
296        XXXXXX4: constant String :=
297          Check_String(Op1(T4_Obj), "Parent.Op1 body") &
298          Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
299          Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
300
301          Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
302          Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
303          Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") &
304
305          Check_String(Op2(T4_Obj), "Parent.Op2 body") &
306          Check_String(Op2(T4_Class_Obj), "Parent.Op2 body") &
307          Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body");
308
309    end Nested;
310
311    type T5 is new T2 with null record;
312    subtype T5_Class is T5'Class;
313    function Make return T5;
314
315    function Make return T5 is
316        Result: T5;
317    begin
318        return Result;
319    end Make;
320
321    XXXXXXX4: constant String :=
322      Check_String(Op1(T4_Obj), "Parent.Op1 body") &
323      Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") &
324      Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") &
325
326      Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") &
327      Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") &
328      Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") &
329
330      Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body");
331
332end C731001_1.Parent.Child;
333
334procedure C731001_1.Main;
335
336with C731001_1.Parent;
337procedure C731001_1.Main is
338begin
339    C731001_1.Parent.Call_Main;
340end C731001_1.Main;
341
342with C731001_1.Parent.Child;
343    use C731001_1.Parent;
344    use C731001_1.Parent.Child;
345    use C731001_1.Parent.Child.Nested;
346with C731001_1.Unrelated; use C731001_1.Unrelated;
347procedure C731001_1.Parent.Main is
348
349    Root_Obj: Root := Make;
350    Root_Class_Obj: Root_Class := Root'(Make);
351
352    T2_Obj: T2 := Make;
353    T2_Class_Obj: T2_Class := T2_Obj;
354    T2_Root_Class_Obj: Root_Class := T2_Class_Obj;
355
356    T3_Obj: T3 := Make;
357    T3_Class_Obj: T3_Class := T3_Obj;
358    T3_Root_Class_Obj: Root_Class := T3_Obj;
359
360    T4_Obj: T4 := Make;
361    T4_Class_Obj: T4_Class := T4_Obj;
362    T4_Root_Class_Obj: Root_Class := T4_Obj;
363
364begin
365    Test("C731001_1", "Check that inherited operations can be overridden, even"
366                    & " when they are inherited in a body");
367
368    Check_String(Op1(Root_Obj), "Parent.Op1 body");
369    Check_String(Op1(Root_Class_Obj), "Parent.Op1 body");
370
371    Check_String(Call_Op2(Root_Obj), "Parent.Op2 body");
372    Check_String(Call_Op2(Root_Class_Obj), "Parent.Op2 body");
373
374    Check_String(Op1(T2_Obj), "Parent.Op1 body");
375    Check_String(Op1(T2_Class_Obj), "Parent.Op1 body");
376    Check_String(Op1(T2_Root_Class_Obj), "Parent.Op1 body");
377
378    Check_String(Op2(T2_Obj), "Unrelated.Op2 body");
379    Check_String(Op2(T2_Class_Obj), "Unrelated.Op2 body");
380    Check_String(Call_Op2(T2_Obj), "Parent.Op2 body");
381    Check_String(Call_Op2(T2_Class_Obj), "Parent.Op2 body");
382    Check_String(Call_Op2(T2_Root_Class_Obj), "Parent.Op2 body");
383
384    Check_String(Op1(T3_Obj), "Parent.Op1 body");
385    Check_String(Op1(T3_Class_Obj), "Parent.Op1 body");
386    Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body");
387
388    Check_String(Call_Op2(T3_Obj), "Parent.Op2 body");
389    Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body");
390    Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body");
391
392    Check_String(Op1(T4_Obj), "Parent.Op1 body");
393    Check_String(Op1(T4_Class_Obj), "Parent.Op1 body");
394    Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body");
395
396    Check_String(Call_Op2(T4_Obj), "Parent.Op2 body");
397    Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body");
398    Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body");
399
400    Result;
401end C731001_1.Parent.Main;
402
403with C731001_1.Main;
404procedure C731001 is
405begin
406    C731001_1.Main;
407end C731001;
408