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, 334 insertions, 0 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c6/c640001.a b/gcc/testsuite/ada/acats/tests/c6/c640001.a new file mode 100644 index 000000000..8e259162e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c640001.a @@ -0,0 +1,334 @@ +-- 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; |