diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c7/c731001.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/c7/c731001.a | 407 |
1 files changed, 0 insertions, 407 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c7/c731001.a b/gcc/testsuite/ada/acats/tests/c7/c731001.a deleted file mode 100644 index 0cfce32bc95..00000000000 --- a/gcc/testsuite/ada/acats/tests/c7/c731001.a +++ /dev/null @@ -1,407 +0,0 @@ --- 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; |