| -- C731001.A |
| -- |
| -- Grant of Unlimited Rights |
| -- |
| -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and |
| -- F08630-91-C-0015, the U.S. Government obtained unlimited rights in the |
| -- software and documentation contained herein. Unlimited rights are |
| -- defined in DFAR 252.227-7013(a)(19). By making this public release, |
| -- the Government intends to confer upon all recipients unlimited rights |
| -- equal to those held by the Government. These rights include rights to |
| -- use, duplicate, release or disclose the released technical data and |
| -- computer software in whole or in part, in any manner and for any purpose |
| -- whatsoever, and to have or permit others to do so. |
| -- |
| -- DISCLAIMER |
| -- |
| -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR |
| -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED |
| -- WARRANTY AS TO ANY MATTER WHATSOVER, INCLUDING THE CONDITIONS OF THE |
| -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE |
| -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A |
| -- PARTICULAR PURPOSE OF SAID MATERIAL. |
| --* |
| -- |
| -- OBJECTIVE |
| -- Check that inherited operations can be overridden, even when they are |
| -- inherited in a body. |
| -- The test cases here are inspired by the AARM examples given in |
| -- the discussion of AARM-7.3.1(7.a-7.v). |
| -- This discussion was confirmed by AI95-00035. |
| -- |
| -- TEST DESCRIPTION |
| -- See AARM-7.3.1. |
| -- |
| -- CHANGE HISTORY: |
| -- 29 JUN 1999 RAD Initial Version |
| -- 23 SEP 1999 RLB Improved comments, renamed, issued. |
| -- 20 AUG 2001 RLB Corrected 'verbose' flag. |
| -- |
| --! |
| |
| with Report; use Report; pragma Elaborate_All(Report); |
| package C731001_1 is |
| pragma Elaborate_Body; |
| private |
| procedure Check_String(X, Y: String); |
| function Check_String(X, Y: String) return String; |
| -- This one is a function, so we can call it in package specs. |
| end C731001_1; |
| |
| package body C731001_1 is |
| |
| Verbose: Boolean := False; |
| |
| procedure Check_String(X, Y: String) is |
| begin |
| if Verbose then |
| Comment("""" & X & """ = """ & Y & """?"); |
| end if; |
| if X /= Y then |
| Failed("""" & X & """ should be """ & Y & """"); |
| end if; |
| end Check_String; |
| |
| function Check_String(X, Y: String) return String is |
| begin |
| Check_String(X, Y); |
| return X; |
| end Check_String; |
| |
| end C731001_1; |
| |
| private package C731001_1.Parent is |
| |
| procedure Call_Main; |
| |
| type Root is tagged null record; |
| subtype Renames_Root is Root; |
| subtype Root_Class is Renames_Root'Class; |
| function Make return Root; |
| function Op1(X: Root) return String; |
| function Call_Op2(X: Root'Class) return String; |
| private |
| function Op2(X: Root) return String; |
| end C731001_1.Parent; |
| |
| procedure C731001_1.Parent.Main; |
| |
| with C731001_1.Parent.Main; |
| package body C731001_1.Parent is |
| |
| procedure Call_Main is |
| begin |
| Main; |
| end Call_Main; |
| |
| function Make return Root is |
| Result: Root; |
| begin |
| return Result; |
| end Make; |
| |
| function Op1(X: Root) return String is |
| begin |
| return "Parent.Op1 body"; |
| end Op1; |
| |
| function Op2(X: Root) return String is |
| begin |
| return "Parent.Op2 body"; |
| end Op2; |
| |
| function Call_Op2(X: Root'Class) return String is |
| begin |
| return Op2(X); |
| end Call_Op2; |
| |
| begin |
| |
| Check_String(Op1(Root'(Make)), "Parent.Op1 body"); |
| Check_String(Op1(Root_Class(Root'(Make))), "Parent.Op1 body"); |
| |
| Check_String(Op2(Root'(Make)), "Parent.Op2 body"); |
| Check_String(Op2(Root_Class(Root'(Make))), "Parent.Op2 body"); |
| |
| end C731001_1.Parent; |
| |
| with C731001_1.Parent; use C731001_1.Parent; |
| private package C731001_1.Unrelated is |
| |
| type T2 is new Root with null record; |
| subtype T2_Class is T2'Class; |
| function Make return T2; |
| function Op2(X: T2) return String; |
| end C731001_1.Unrelated; |
| |
| with C731001_1.Parent; use C731001_1.Parent; |
| pragma Elaborate(C731001_1.Parent); |
| package body C731001_1.Unrelated is |
| |
| function Make return T2 is |
| Result: T2; |
| begin |
| return Result; |
| end Make; |
| |
| function Op2(X: T2) return String is |
| begin |
| return "Unrelated.Op2 body"; |
| end Op2; |
| begin |
| |
| Check_String(Op1(T2'(Make)), "Parent.Op1 body"); |
| Check_String(Op1(T2_Class(T2'(Make))), "Parent.Op1 body"); |
| Check_String(Op1(Root_Class(T2'(Make))), "Parent.Op1 body"); |
| |
| Check_String(Op2(T2'(Make)), "Unrelated.Op2 body"); |
| Check_String(Op2(T2_Class(T2'(Make))), "Unrelated.Op2 body"); |
| Check_String(Call_Op2(T2'(Make)), "Parent.Op2 body"); |
| Check_String(Call_Op2(T2_Class(T2'(Make))), "Parent.Op2 body"); |
| Check_String(Call_Op2(Root_Class(T2'(Make))), "Parent.Op2 body"); |
| |
| end C731001_1.Unrelated; |
| |
| package C731001_1.Parent.Child is |
| pragma Elaborate_Body; |
| |
| type T3 is new Root with null record; |
| subtype T3_Class is T3'Class; |
| function Make return T3; |
| |
| T3_Obj: T3; |
| T3_Class_Obj: T3_Class := T3_Obj; |
| T3_Root_Class_Obj: Root_Class := T3_Obj; |
| |
| X3: constant String := |
| Check_String(Op1(T3_Obj), "Parent.Op1 body") & |
| Check_String(Op1(T3_Class_Obj), "Parent.Op1 body") & |
| Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body") & |
| |
| Check_String(Call_Op2(T3_Obj), "Parent.Op2 body") & |
| Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body") & |
| Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body"); |
| |
| package Nested is |
| type T4 is new Root with null record; |
| subtype T4_Class is T4'Class; |
| function Make return T4; |
| |
| T4_Obj: T4; |
| T4_Class_Obj: T4_Class := T4_Obj; |
| T4_Root_Class_Obj: Root_Class := T4_Obj; |
| |
| X4: constant String := |
| Check_String(Op1(T4_Obj), "Parent.Op1 body") & |
| Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") & |
| Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") & |
| |
| Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") & |
| Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") & |
| Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body"); |
| |
| private |
| |
| XX4: constant String := |
| Check_String(Op1(T4_Obj), "Parent.Op1 body") & |
| Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") & |
| Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") & |
| |
| Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") & |
| Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") & |
| Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body"); |
| |
| end Nested; |
| |
| use Nested; |
| |
| XXX4: constant String := |
| Check_String(Op1(T4_Obj), "Parent.Op1 body") & |
| Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") & |
| Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") & |
| |
| Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") & |
| Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") & |
| Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body"); |
| |
| private |
| |
| XX3: constant String := |
| Check_String(Op1(T3_Obj), "Parent.Op1 body") & |
| Check_String(Op1(T3_Class_Obj), "Parent.Op1 body") & |
| Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body") & |
| |
| Check_String(Call_Op2(T3_Obj), "Parent.Op2 body") & |
| Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body") & |
| Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body") & |
| |
| Check_String(Op2(T3_Obj), "Parent.Op2 body") & |
| Check_String(Op2(T3_Class_Obj), "Parent.Op2 body") & |
| Check_String(Op2(T3_Root_Class_Obj), "Parent.Op2 body"); |
| |
| XXXX4: constant String := |
| Check_String(Op1(T4_Obj), "Parent.Op1 body") & |
| Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") & |
| Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") & |
| |
| Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") & |
| Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") & |
| Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") & |
| |
| Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body"); |
| |
| end C731001_1.Parent.Child; |
| |
| with C731001_1.Unrelated; use C731001_1.Unrelated; |
| pragma Elaborate(C731001_1.Unrelated); |
| package body C731001_1.Parent.Child is |
| |
| XXX3: constant String := |
| Check_String(Op1(T3_Obj), "Parent.Op1 body") & |
| Check_String(Op1(T3_Class_Obj), "Parent.Op1 body") & |
| Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body") & |
| |
| Check_String(Call_Op2(T3_Obj), "Parent.Op2 body") & |
| Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body") & |
| Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body") & |
| |
| Check_String(Op2(T3_Obj), "Parent.Op2 body") & |
| Check_String(Op2(T3_Class_Obj), "Parent.Op2 body") & |
| Check_String(Op2(T3_Root_Class_Obj), "Parent.Op2 body"); |
| |
| XXXXX4: constant String := |
| Check_String(Op1(T4_Obj), "Parent.Op1 body") & |
| Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") & |
| Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") & |
| |
| Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") & |
| Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") & |
| Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") & |
| |
| Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body"); |
| |
| function Make return T3 is |
| Result: T3; |
| begin |
| return Result; |
| end Make; |
| |
| package body Nested is |
| function Make return T4 is |
| Result: T4; |
| begin |
| return Result; |
| end Make; |
| |
| XXXXXX4: constant String := |
| Check_String(Op1(T4_Obj), "Parent.Op1 body") & |
| Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") & |
| Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") & |
| |
| Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") & |
| Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") & |
| Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") & |
| |
| Check_String(Op2(T4_Obj), "Parent.Op2 body") & |
| Check_String(Op2(T4_Class_Obj), "Parent.Op2 body") & |
| Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body"); |
| |
| end Nested; |
| |
| type T5 is new T2 with null record; |
| subtype T5_Class is T5'Class; |
| function Make return T5; |
| |
| function Make return T5 is |
| Result: T5; |
| begin |
| return Result; |
| end Make; |
| |
| XXXXXXX4: constant String := |
| Check_String(Op1(T4_Obj), "Parent.Op1 body") & |
| Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") & |
| Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") & |
| |
| Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") & |
| Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") & |
| Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") & |
| |
| Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body"); |
| |
| end C731001_1.Parent.Child; |
| |
| procedure C731001_1.Main; |
| |
| with C731001_1.Parent; |
| procedure C731001_1.Main is |
| begin |
| C731001_1.Parent.Call_Main; |
| end C731001_1.Main; |
| |
| with C731001_1.Parent.Child; |
| use C731001_1.Parent; |
| use C731001_1.Parent.Child; |
| use C731001_1.Parent.Child.Nested; |
| with C731001_1.Unrelated; use C731001_1.Unrelated; |
| procedure C731001_1.Parent.Main is |
| |
| Root_Obj: Root := Make; |
| Root_Class_Obj: Root_Class := Root'(Make); |
| |
| T2_Obj: T2 := Make; |
| T2_Class_Obj: T2_Class := T2_Obj; |
| T2_Root_Class_Obj: Root_Class := T2_Class_Obj; |
| |
| T3_Obj: T3 := Make; |
| T3_Class_Obj: T3_Class := T3_Obj; |
| T3_Root_Class_Obj: Root_Class := T3_Obj; |
| |
| T4_Obj: T4 := Make; |
| T4_Class_Obj: T4_Class := T4_Obj; |
| T4_Root_Class_Obj: Root_Class := T4_Obj; |
| |
| begin |
| Test("C731001_1", "Check that inherited operations can be overridden, even" |
| & " when they are inherited in a body"); |
| |
| Check_String(Op1(Root_Obj), "Parent.Op1 body"); |
| Check_String(Op1(Root_Class_Obj), "Parent.Op1 body"); |
| |
| Check_String(Call_Op2(Root_Obj), "Parent.Op2 body"); |
| Check_String(Call_Op2(Root_Class_Obj), "Parent.Op2 body"); |
| |
| Check_String(Op1(T2_Obj), "Parent.Op1 body"); |
| Check_String(Op1(T2_Class_Obj), "Parent.Op1 body"); |
| Check_String(Op1(T2_Root_Class_Obj), "Parent.Op1 body"); |
| |
| Check_String(Op2(T2_Obj), "Unrelated.Op2 body"); |
| Check_String(Op2(T2_Class_Obj), "Unrelated.Op2 body"); |
| Check_String(Call_Op2(T2_Obj), "Parent.Op2 body"); |
| Check_String(Call_Op2(T2_Class_Obj), "Parent.Op2 body"); |
| Check_String(Call_Op2(T2_Root_Class_Obj), "Parent.Op2 body"); |
| |
| Check_String(Op1(T3_Obj), "Parent.Op1 body"); |
| Check_String(Op1(T3_Class_Obj), "Parent.Op1 body"); |
| Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body"); |
| |
| Check_String(Call_Op2(T3_Obj), "Parent.Op2 body"); |
| Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body"); |
| Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body"); |
| |
| Check_String(Op1(T4_Obj), "Parent.Op1 body"); |
| Check_String(Op1(T4_Class_Obj), "Parent.Op1 body"); |
| Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body"); |
| |
| Check_String(Call_Op2(T4_Obj), "Parent.Op2 body"); |
| Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body"); |
| Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body"); |
| |
| Result; |
| end C731001_1.Parent.Main; |
| |
| with C731001_1.Main; |
| procedure C731001 is |
| begin |
| C731001_1.Main; |
| end C731001; |
