diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c3/c393a03.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/c3/c393a03.a | 242 |
1 files changed, 0 insertions, 242 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c3/c393a03.a b/gcc/testsuite/ada/acats/tests/c3/c393a03.a deleted file mode 100644 index 90106f4bf44..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c393a03.a +++ /dev/null @@ -1,242 +0,0 @@ --- C393A03.A --- --- Grant of Unlimited Rights --- --- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, --- F08630-91-C-0015, and DCA100-97-D-0025, 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 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 a non-abstract primitive subprogram of an abstract --- type can be called as a dispatching operation and that the body --- of this subprogram can make a dispatching call to an abstract --- operation of the corresponding abstract type. --- --- TEST DESCRIPTION: --- This test expands on the class family defined in foundation F393A00 --- by deriving a new abstract type from the root abstract type "Object". --- The subprograms defined for the new abstract type are then --- appropriately overridden, and the test ultimately calls various --- mixtures of these subprograms to check that the dispatching occurs --- correctly. --- --- TEST FILES: --- The following files comprise this test: --- --- F393A00.A (foundation code) --- C393A03.A --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 19 Dec 94 SAIC Removed ARM references from objective text. --- 23 Oct 95 SAIC Fixed bugs for ACVC 2.0.1 --- ---! - -------------------------------------------------------------------- C393A03_0 - -with F393A00_1; -package C393A03_0 is - - type Counting_Object is abstract new F393A00_1.Object with private; - -- inherits Initialize, Swap (abstract) and Create (abstract) - - procedure Bump ( A_Counter: in out Counting_Object ); - procedure Clear( A_Counter: in out Counting_Object ) is abstract; - procedure Zero ( A_Counter: in out Counting_Object ); - function Value( A_Counter: Counting_Object'Class ) return Natural; - -private - - type Counting_Object is abstract new F393A00_1.Object with - record - Tally : Natural :=0; - end record; - -end C393A03_0; - ------------------------------------------------------------------------------ - -with F393A00_0; -package body C393A03_0 is - - procedure Bump ( A_Counter: in out Counting_Object ) is - begin - F393A00_0.TC_Touch('A'); - A_Counter.Tally := A_Counter.Tally +1; - end Bump; - - procedure Zero ( A_Counter: in out Counting_Object ) is - begin - F393A00_0.TC_Touch('B'); - - -- dispatching call to abstract operation of Counting_Object - Clear( Counting_Object'Class(A_Counter) ); - - A_Counter.Tally := 0; - - end Zero; - - function Value( A_Counter: Counting_Object'Class ) return Natural is - begin - F393A00_0.TC_Touch('C'); - return A_Counter.Tally; - end Value; - -end C393A03_0; - -------------------------------------------------------------------- C393A03_1 - -with C393A03_0; -package C393A03_1 is - - type Modular_Object is new C393A03_0.Counting_Object with private; - -- inherits Initialize, Bump, Zero and Value, - -- inherits abstract Swap, Create and Clear - - procedure Swap( A,B: in out Modular_Object ); - procedure Clear( It: in out Modular_Object ); - procedure Set_Max( It : in out Modular_Object; Value : Natural ); - function Create return Modular_Object; - -private - - type Modular_Object is new C393A03_0.Counting_Object with - record - Max_Value : Natural; - end record; - -end C393A03_1; - ------------------------------------------------------------------------------ - -with F393A00_0; -package body C393A03_1 is - - procedure Swap( A,B: in out Modular_Object ) is - T : constant Modular_Object := B; - begin - F393A00_0.TC_Touch('1'); - B := A; - A := T; - end Swap; - - procedure Clear( It: in out Modular_Object ) is - begin - F393A00_0.TC_Touch('2'); - null; - end Clear; - - procedure Set_Max( It : in out Modular_Object; Value : Natural ) is - begin - F393A00_0.TC_Touch('3'); - It.Max_Value := Value; - end Set_Max; - - function Create return Modular_Object is - AMO : Modular_Object; - begin - F393A00_0.TC_Touch('4'); - AMO.Max_Value := Natural'Last; - return AMO; - end Create; - -end C393A03_1; - ---------------------------------------------------------------------- C393A03 - -with Report; -with F393A00_0; -with F393A00_1; -with C393A03_0; -with C393A03_1; -procedure C393A03 is - - A_Thing : C393A03_1.Modular_Object; - Another_Thing : C393A03_1.Modular_Object; - - procedure Initialize( It: in out C393A03_0.Counting_Object'Class ) is - begin - C393A03_0.Initialize( It ); -- dispatch to inherited procedure - end Initialize; - - procedure Bump( It: in out C393A03_0.Counting_Object'Class ) is - begin - C393A03_0.Bump( It ); -- dispatch to non-abstract procedure - end Bump; - - procedure Set_Max( It : in out C393A03_1.Modular_Object'Class; - Val : Natural) is - begin - C393A03_1.Set_Max( It, Val ); -- dispatch to non-abstract procedure - end Set_Max; - - procedure Swap( A, B : in out C393A03_0.Counting_Object'Class ) is - begin - C393A03_0.Swap( A, B ); -- dispatch to inherited abstract procedure - end Swap; - - procedure Zero( It: in out C393A03_0.Counting_Object'Class ) is - begin - C393A03_0.Zero( It ); -- dispatch to non-abstract procedure - end Zero; - -begin -- Main test procedure. - - Report.Test ("C393A03", "Check that a non-abstract primitive subprogram " - & "of an abstract type can be called as a " - & "dispatching operation and that the body of this " - & "subprogram can make a dispatching call to an " - & "abstract operation of the corresponding " - & "abstract type" ); - - A_Thing := C393A03_1.Create; -- Max_Value = Natural'Last - F393A00_0.TC_Validate( "4", "Overridden primitive layer 2"); - - Initialize( A_Thing ); - Initialize( Another_Thing ); - F393A00_0.TC_Validate( "aa", "Non-abstract primitive layer 0"); - - Bump( A_Thing ); -- Tally = 1 - F393A00_0.TC_Validate( "A", "Non-abstract primitive layer 1"); - - Set_Max( A_Thing, 42 ); -- Max_Value = 42 - F393A00_0.TC_Validate( "3", "Non-abstract normal layer 2"); - - if not F393A00_1.Initialized( A_Thing ) then - Report.Failed("Initialize didn't"); - end if; - F393A00_0.TC_Validate( "b", "Class-wide layer 0"); - - Swap( A_Thing, Another_Thing ); - F393A00_0.TC_Validate( "1", "Overridden abstract layer 2"); - - Zero( A_Thing ); - F393A00_0.TC_Validate( "B2", "Non-abstract layer 0, calls dispatch"); - - if C393A03_0.Value( A_Thing ) /= 0 then - Report.Failed("Zero didn't"); - end if; - F393A00_0.TC_Validate( "C", "Class-wide normal layer 2"); - - Report.Result; - -end C393A03; |