diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c3/c392014.a')
-rw-r--r-- | gcc/testsuite/ada/acats/tests/c3/c392014.a | 225 |
1 files changed, 0 insertions, 225 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392014.a b/gcc/testsuite/ada/acats/tests/c3/c392014.a deleted file mode 100644 index 89d403eaad3..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c392014.a +++ /dev/null @@ -1,225 +0,0 @@ --- C392014.A --- --- Grant of Unlimited Rights --- --- The Ada Conformity Assessment Authority (ACAA) holds unlimited --- rights in the software and documentation contained herein. Unlimited --- rights are the same as those granted by the U.S. Government for older --- parts of the Ada Conformity Assessment Test Suite, and are defined --- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA --- intends to confer upon all recipients unlimited rights equal to those --- held by the ACAA. 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 WHATSOEVER, 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 objects designated by X'Access (where X is of a class-wide --- type) and new T'Class'(...) are dynamically tagged and can be used in --- dispatching calls. (Defect Report 8652/0010). --- --- CHANGE HISTORY: --- 18 JAN 2001 PHL Initial version --- 15 MAR 2001 RLB Readied for release. - ---! -package C392014_0 is - - type T (D : Integer) is abstract tagged private; - - procedure P (X : access T) is abstract; - function Create (X : Integer) return T'Class; - - Result : Natural := 0; - -private - type T (D : Integer) is abstract tagged null record; -end C392014_0; - -with C392014_0; -package C392014_1 is - type T is new C392014_0.T with private; - function Create (X : Integer) return T'Class; -private - type T is new C392014_0.T with - record - C1 : Integer; - end record; - procedure P (X : access T); -end C392014_1; - -package C392014_1.Child is - type T is new C392014_1.T with private; - procedure P (X : access T); - function Create (X : Integer) return T'Class; -private - type T is new C392014_1.T with - record - C1C : Integer; - end record; -end C392014_1.Child; - -with Report; -use Report; -with C392014_1.Child; -package body C392014_1 is - - procedure P (X : access T) is - begin - C392014_0.Result := C392014_0.Result + X.D + X.C1; - end P; - - function Create (X : Integer) return T'Class is - begin - case X mod Ident_Int (2) is - when 0 => - return C392014_1.Child.Create (X / Ident_Int (2)); - when 1 => - declare - Y : T (D => (X / Ident_Int (2)) mod Ident_Int (20)); - begin - Y.C1 := X / Ident_Int (40); - return T'Class (Y); - end; - when others => - null; - end case; - end Create; - -end C392014_1; - -with C392014_0; -with C392014_1; -package C392014_2 is - type T is new C392014_0.T with private; - function Create (X : Integer) return T'Class; -private - type T is new C392014_1.T with - record - C2 : Integer; - end record; - procedure P (X : access T); -end C392014_2; - -with Report; -use Report; -with C392014_1.Child; -with C392014_2; -package body C392014_0 is - - function Create (X : Integer) return T'Class is - begin - case X mod 3 is - when 0 => - return C392014_1.Create (X / Ident_Int (3)); - when 1 => - return C392014_1.Child.Create (X / Ident_Int (3)); - when 2 => - return C392014_2.Create (X / Ident_Int (3)); - when others => - null; - end case; - end Create; - -end C392014_0; - -with Report; -use Report; -with C392014_0; -package body C392014_1.Child is - - procedure P (X : access T) is - begin - C392014_0.Result := C392014_0.Result + X.D + X.C1 + X.C1C; - end P; - - function Create (X : Integer) return T'Class is - Y : T (D => X mod Ident_Int (20)); - begin - Y.C1 := (X / Ident_Int (20)) mod Ident_Int (20); - Y.C1C := X / Ident_Int (400); - return T'Class (Y); - end Create; - -end C392014_1.Child; - -with Report; -use Report; -package body C392014_2 is - - procedure P (X : access T) is - begin - C392014_0.Result := C392014_0.Result + X.D + X.C2; - end P; - - function Create (X : Integer) return T'Class is - Y : T (D => X mod Ident_Int (20)); - begin - Y.C2 := X / Ident_Int (600); - return T'Class (Y); - end Create; - -end C392014_2; - -with Report; -use Report; -with C392014_0; -with C392014_1.Child; -with C392014_2; -procedure C392014 is - - subtype S0 is C392014_0.T'Class (D => Ident_Int (17)); - subtype S1 is C392014_1.T'Class; - - X0 : aliased C392014_0.T'Class := C392014_0.Create (Ident_Int (5218)); - X1 : aliased C392014_1.T'Class := C392014_1.Create (Ident_Int (8253)); - - Y0 : aliased S0 := C392014_0.Create (Ident_Int (2693)); - Y1 : aliased S1 := C392014_1.Create (Ident_Int (5622)); - - procedure TC_Check (Subtest : String; Expected : Integer) is - begin - if C392014_0.Result = Expected then - Comment ("Subtest " & Subtest & " Passed"); - else - Failed ("Subtest " & Subtest & " Failed"); - end if; - C392014_0.Result := Ident_Int (0); - end TC_Check; - -begin - Test ("C392014", - "Check that objects designated by X'Access " & - "(where X is of a class-wide type) and New T'Class'(...) " & - "are dynamically tagged and can be used in dispatching " & - "calls"); - - C392014_0.P (X0'Access); - TC_Check ("X0'Access", Ident_Int (29)); - C392014_0.P (new C392014_0.T'Class'(C392014_0.Create (Ident_Int (12850)))); - TC_Check ("New C392014_0.T'Class", Ident_Int (27)); - C392014_1.P (X1'Access); - TC_Check ("X1'Access", Ident_Int (212)); - C392014_1.P (new C392014_1.T'Class'(C392014_1.Create (Ident_Int (2031)))); - TC_Check ("New C392014_1.T'Class", Ident_Int (65)); - C392014_0.P (Y0'Access); - TC_Check ("Y0'Access", Ident_Int (18)); - C392014_0.P (new S0'(C392014_0.Create (Ident_Int (6893)))); - TC_Check ("New S0", Ident_Int (20)); - C392014_1.P (Y1'Access); - TC_Check ("Y1'Access", Ident_Int (18)); - C392014_1.P (new S1'(C392014_1.Create (Ident_Int (1861)))); - TC_Check ("New S1", Ident_Int (56)); - - Result; -end C392014; |