Subversion Repositories openrisc_me

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