| -- 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; |
