URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-old/] [gcc-4.2.2/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c6/] [c640001.a] - Rev 154
Go to most recent revision | Compare with Previous | Blame | View Log
-- 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;
Go to most recent revision | Compare with Previous | Blame | View Log