diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c6/c640001.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/c6/c640001.a | 334 |
1 files changed, 0 insertions, 334 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c6/c640001.a b/gcc/testsuite/ada/acats/tests/c6/c640001.a deleted file mode 100644 index 8e259162e17..00000000000 --- a/gcc/testsuite/ada/acats/tests/c6/c640001.a +++ /dev/null @@ -1,334 +0,0 @@ --- C640001.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 the prefix of a subprogram call with an actual parameter --- part may be an implicit dereference of an access-to-subprogram value. --- Check that, for an access-to-subprogram type whose designated profile --- contains parameters of a tagged generic formal type, an access-to- --- subprogram value may designate dispatching and non-dispatching --- operations, and that dereferences of such a value call the appropriate --- subprogram. --- --- TEST DESCRIPTION: --- The test declares a tagged type (Table) with a dispatching operation --- (Clear), as well as a derivative (Table2) which overrides that --- operation. A subprogram with the same name and profile as Clear is --- declared in a separate package -- it is therefore not a dispatching --- operation of Table. For the purposes of the test, each version of Clear --- modifies the components of its parameter in a unique way. --- --- Additionally, an operation (Reset) of type Table is declared which --- makes a re-dispatching call to Clear, i.e., --- --- procedure Reset (A: in out Table) is --- begin --- ... --- Clear (Table'Class(A)); -- Re-dispatch based on tag of actual. --- ... --- end Reset; --- --- An access-to-subprogram type is declared within a generic package, --- with a designated profile which declares a parameter of a generic --- formal tagged private type. --- --- The generic is instantiated with type Table. The instance defines an --- array of access-to-subprogram values (which represents a table of --- operations to be performed sequentially on a single operand). --- Access values designating the dispatching version of Clear, the --- non-dispatching version of Clear, and Reset (which re-dispatches to --- Clear) are placed in this array. --- --- In the instance, each subprogram in the array is called by implicitly --- dereferencing the corresponding access value. For the dispatching and --- non-dispatching versions of Clear, the actual parameter passed is of --- type Table. For Reset, the actual parameter passed is a view conversion --- of an object of type Table2 to type Table, i.e., Table(Table2_Obj). --- Since the tag of the operand never changes, the call to Clear within --- Reset should execute Table2's version of Clear. --- --- The main program verifies that the appropriate version of Clear is --- called in each case, by checking that the components of the actual are --- updated as expected. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -package C640001_0 is - - -- Data type artificial for testing purposes. - - Row_Len : constant := 10; - - T : constant Boolean := True; - F : constant Boolean := False; - - type Row_Type is array (1 .. Row_Len) of Boolean; - - function Is_True (A : in Row_Type) return Boolean; - function Is_False (A : in Row_Type) return Boolean; - - - Init : constant Row_Type := (T, F, T, F, T, F, T, F, T, F); - - type Table is tagged record -- Tagged type. - Row1 : Row_Type := Init; - Row2 : Row_Type := Init; - end record; - - procedure Clear (A : in out Table); -- Dispatching operation. - - procedure Reset (A : in out Table); -- Re-dispatching operation. - - -- ...Other operations. - - - type Table2 is new Table with null record; -- Extension of Table (but - -- structurally identical). - - procedure Clear (A : in out Table2); -- Overrides parent's op. - - -- ...Other operations. - - -end C640001_0; - - - --===================================================================-- - - -package body C640001_0 is - - function Is_True (A : in Row_Type) return Boolean is - begin - for I in A'Range loop - if A(I) /= True then -- Return true if all elements - return False; -- of A are True. - end if; - end loop; - return True; - end Is_True; - - - function Is_False (A : in Row_Type) return Boolean is - begin - return A = Row_Type'(others => False); -- Return true if all elements - end Is_False; -- of A are False. - - - procedure Clear (A : in out Table) is - begin - for I in Row_Type'Range loop -- This version of Clear sets - A.Row1(I) := False; -- the elements of Row1 only - end loop; -- to False. - end Clear; - - - procedure Reset (A : in out Table) is - begin - Clear (Table'Class(A)); -- Redispatch to appropriate - -- ... Other "reset" activities. -- version of Clear. - end Reset; - - - procedure Clear (A : in out Table2) is - begin - for I in Row_Type'Range loop -- This version of Clear sets - A.Row1(I) := True; -- the elements of Row1 only - end loop; -- to True. - end Clear; - - -end C640001_0; - - - --===================================================================-- - - -with C640001_0; -package C640001_1 is - - procedure Clear (T : in out C640001_0.Table); -- Non-dispatching operation. - -end C640001_1; - - - --===================================================================-- - - -package body C640001_1 is - - procedure Clear (T : in out C640001_0.Table) is - begin - for I in C640001_0.Row_Type'Range loop -- This version of Clear sets - T.Row2(I) := True; -- the elements of Row2 only - end loop; -- to True. - end Clear; - -end C640001_1; - - - --===================================================================-- - - --- This unit represents a support package for table-driven processing of --- data objects. Process_Operand performs a set of operations are performed --- sequentially on a single operand. Note that parameters are provided to --- specify which subset of operations in the operations table are to be --- performed (ordinarily these might be omitted, but the test requires that --- each operation be called individually for a single operand). - -generic - type Tag is tagged private; -package C640001_2 is - - type Proc_Ptr is access procedure (P: in out Tag); - - type Op_List is private; - - procedure Add_Op (Op : in Proc_Ptr; -- Add operation to - List : in out Op_List); -- to list of ops. - - procedure Process_Operand (Operand : in out Tag; -- Execute a subset - List : in Op_List; -- of a list of - First_Op : in Positive; -- operations using - Last_Op : in Positive); -- a given operand. - - -- ...Other operations. - -private - type Op_Array is array (1 .. 3) of Proc_Ptr; - - type Op_List is record - Top : Natural := 0; - Ops : Op_Array; - end record; -end C640001_2; - - - --===================================================================-- - - -package body C640001_2 is - - procedure Add_Op (Op : in Proc_Ptr; - List : in out Op_List) is - begin - List.Top := List.Top + 1; -- Artificial; no Constraint_Error protection. - List.Ops(List.Top) := Op; - end Add_Op; - - - procedure Process_Operand (Operand : in out Tag; - List : in Op_List; - First_Op : in Positive; - Last_Op : in Positive) is - begin - for I in First_Op .. Last_Op loop - List.Ops(I)(Operand); -- Implicit dereference of an - end loop; -- access-to-subprogram value. - end Process_Operand; - -end C640001_2; - - - --===================================================================-- - - -with C640001_0; -with C640001_1; -with C640001_2; - -with Report; -procedure C640001 is - - package Table_Support is new C640001_2 (C640001_0.Table); - - Sub_Ptr : Table_Support.Proc_Ptr; - My_List : Table_Support.Op_List; - My_Table1 : C640001_0.Table; -- Initial values of both Row1 & - -- Row2 are (T,F,T,F,T,F,T,F,T,F). - My_Table2 : C640001_0.Table2; -- Initial values of both Row1 & - -- Row2 are (T,F,T,F,T,F,T,F,T,F). -begin - Report.Test ("C640001", "Check that, for an access-to-subprogram type " & - "whose designated profile contains parameters " & - "of a tagged generic formal type, an access-" & - "to-subprogram value may designate dispatching " & - "and non-dispatching operations"); - - -- - -- Add subprogram access values to list: - -- - - Sub_Ptr := C640001_0.Clear'Access; -- Designates dispatching op. - Table_Support.Add_Op (Sub_Ptr, My_List); -- (1st operation on My_List). - - Sub_Ptr := C640001_1.Clear'Access; -- Designates non-dispatching op. - Table_Support.Add_Op (Sub_Ptr, My_List); -- (2nd operation on My_List). - - Sub_Ptr := C640001_0.Reset'Access; -- Designates re-dispatching op. - Table_Support.Add_Op (Sub_Ptr, My_List); -- (3rd operation on My_List). - - - -- - -- Call dispatching operation: - -- - - Table_Support.Process_Operand (My_Table1, My_List, 1, 1); -- Call 1st op. - - if not C640001_0.Is_False (My_Table1.Row1) then - Report.Failed ("Wrong result after calling dispatching operation"); - end if; - - - -- - -- Call non-dispatching operation: - -- - - Table_Support.Process_Operand (My_Table1, My_List, 2, 2); -- Call 2nd op. - - if not C640001_0.Is_True (My_Table1.Row2) then - Report.Failed ("Wrong result after calling non-dispatching operation"); - end if; - - - -- - -- Call re-dispatching operation: - -- - - Table_Support.Process_Operand (C640001_0.Table(My_Table2), -- View conv. - My_List, 3, 3); -- Call 3rd op. - - if not C640001_0.Is_True (My_Table2.Row1) then - Report.Failed ("Wrong result after calling re-dispatching operation"); - end if; - - - Report.Result; -end C640001; |