URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-old/] [gcc-4.2.2/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [cc/] [cc51d01.a] - Rev 154
Go to most recent revision | Compare with Previous | Blame | View Log
-- CC51D01.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, in an instance, each implicit declaration of a user-defined
-- subprogram of a formal private extension declares a view of the
-- corresponding primitive subprogram of the ancestor, and that if the
-- tag in a call is statically determined to be that of the formal type,
-- the body executed will be that corresponding to the actual type.
--
-- Check subprograms declared within a generic formal package. Check for
-- the case where the actual type passed to the formal private extension
-- is a specific tagged type. Check for several types in the same class.
--
--
-- TEST DESCRIPTION:
-- Declare a list abstraction in a generic package which manages lists of
-- elements of any nonlimited type (foundation code). Declare a package
-- which declares a tagged type and a type derived from it. Declare an
-- operation for the root tagged type and override it for the derived
-- type. Derive a type from this derived type, but do not override the
-- operation. Declare a generic subprogram which operates on lists of
-- elements of tagged types. Provide the generic subprogram with two
-- formal parameters: (1) a formal derived tagged type which represents a
-- list element type, and (2) a generic formal package with the list
-- abstraction package as template. Use the formal derived type as the
-- generic formal actual part for the formal package. Within the generic
-- subprogram, call the operation of the root tagged type. In the main
-- program, instantiate the generic list package and the generic
-- subprogram with the root tagged type and each derivative, then call
-- each instance with an object of the appropriate type.
--
-- TEST FILES:
-- The following files comprise this test:
--
-- FC51D00.A
-- -> CC51D01.A
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 04 Jan 95 SAIC Moved declaration of type Ranked_ID_Type from
-- main subprogram to package CC51D01_0. Removed
-- case passing class-wide actual to instance.
-- Updated test description and modified comments.
--
--!
package CC51D01_0 is -- This package simulates support for a personnel
-- database.
type SSN_Type is new String (1 .. 9);
type Blind_ID_Type is tagged record -- Root type of
SSN : SSN_Type; -- class.
-- ... Other components.
end record;
procedure Update_ID (Item : in out Blind_ID_Type); -- Parent operation.
-- ... Other operations.
type Name_Type is new String (1 .. 9);
type Named_ID_Type is new Blind_ID_Type with record -- Direct derivative
Name : Name_Type := "Doe "; -- of root type.
-- ... Other components.
end record;
-- Inherits Update_ID from parent.
procedure Update_ID (Item : in out Named_ID_Type); -- Overrides parent's
-- implementation.
type Ranked_ID_Type is new Named_ID_Type with record
Level : Integer := 0; -- Indirect derivative
-- ... Other components. -- of root type.
end record;
-- Inherits Update_ID from parent.
end CC51D01_0;
--==================================================================--
package body CC51D01_0 is
-- The implementations of Update_ID are purely artificial; the validity of
-- their implementations in the context of the abstraction is irrelevant to
-- the feature being tested.
procedure Update_ID (Item : in out Blind_ID_Type) is
begin
Item.SSN := "111223333";
end Update_ID;
procedure Update_ID (Item : in out Named_ID_Type) is
begin
Item.SSN := "444556666";
-- ... Other stuff.
end Update_ID;
end CC51D01_0;
--==================================================================--
-- --
-- Formal package used here. --
-- --
with FC51D00; -- Generic list abstraction.
with CC51D01_0; -- Tagged type declarations.
generic -- This procedure simulates a generic operation for types
-- in the class rooted at Blind_ID_Type.
type Elem_Type is new CC51D01_0.Blind_ID_Type with private;
with package List_Mgr is new FC51D00 (Elem_Type);
procedure CC51D01_1 (L : in out List_Mgr.List_Type; E : in Elem_Type);
--==================================================================--
-- The implementation of CC51D01_1 is purely artificial; the validity
-- of its implementation in the context of the abstraction is irrelevant
-- to the feature being tested.
--
-- The expected behavior here is as follows: for each actual type corresponding
-- to Elem_Type, the call to Update_ID should invoke the actual type's
-- implementation, which updates the object's SSN field. Write_Element then
-- adds the object to the list.
procedure CC51D01_1 (L : in out List_Mgr.List_Type; E : in Elem_Type) is
Element : Elem_Type := E; -- Can't update IN parameter.
begin
Update_ID (Element); -- Executes actual type's version.
List_Mgr.Write_Element (1, L, Element); -- Executes actual type's version.
end CC51D01_1;
--==================================================================--
with FC51D00; -- Generic list abstraction.
with CC51D01_0; -- Tagged type declarations.
with CC51D01_1; -- Generic operation.
with Report;
procedure CC51D01 is
use CC51D01_0; -- All types & ops
-- directly visible.
-- Begin test code declarations: -----------------------
TC_Expected_1 : Blind_ID_Type := (SSN => "111223333");
TC_Expected_2 : Named_ID_Type := ("444556666", "Doe ");
TC_Expected_3 : Ranked_ID_Type := ("444556666", "Doe ", 0);
TC_Initial_1 : Blind_ID_Type := (SSN => "777889999");
TC_Initial_2 : Named_ID_Type := ("777889999", "Doe ");
TC_Initial_3 : Ranked_ID_Type := ("777889999", "Doe ", 0);
-- End test code declarations. -------------------------
-- Begin instantiations and list declarations: ---------
-- At this point in an application, the generic list package would be
-- instantiated for one of the visible tagged types. Next, the generic
-- subprogram would be instantiated for the same tagged type and the
-- preceding list package instance.
--
-- In order to cover all the important cases, this test instantiates several
-- packages and subprograms (probably more than would typically appear
-- in user code).
-- Support for lists of blind IDs:
package Blind_Lists is new FC51D00 (Blind_ID_Type);
procedure Update_and_Write is new CC51D01_1 (Blind_ID_Type, Blind_Lists);
Blind_List : Blind_Lists.List_Type;
-- Support for lists of named IDs:
package Named_Lists is new FC51D00 (Named_ID_Type);
procedure Update_and_Write is new -- Overloads subprog
CC51D01_1 (Elem_Type => Named_ID_Type, -- for Blind_ID_Type.
List_Mgr => Named_Lists);
Named_List : Named_Lists.List_Type;
-- Support for lists of ranked IDs:
package Ranked_Lists is new FC51D00 (Ranked_ID_Type);
procedure Update_and_Write is new -- Overloads.
CC51D01_1 (Elem_Type => Ranked_ID_Type,
List_Mgr => Ranked_Lists);
Ranked_List : Ranked_Lists.List_Type;
-- End instantiations and list declarations. -----------
begin
Report.Test ("CC51D01", "Formal private extension, specific tagged " &
"type actual: body of primitive subprogram executed is " &
"that of actual type. Check for subprograms declared in " &
"a formal package");
Update_and_Write (Blind_List, TC_Initial_1);
if (Blind_Lists.View_Element (1, Blind_List) /= TC_Expected_1) then
Report.Failed ("Wrong result for root tagged type");
end if;
Update_and_Write (Named_List, TC_Initial_2);
if (Named_Lists.View_Element (1, Named_List) /= TC_Expected_2) then
Report.Failed ("Wrong result for type derived directly from root");
end if;
Update_and_Write (Ranked_List, TC_Initial_3);
if (Ranked_Lists.View_Element (1, Ranked_List) /= TC_Expected_3) then
Report.Failed ("Wrong result for type derived indirectly from root");
end if;
Report.Result;
end CC51D01;
Go to most recent revision | Compare with Previous | Blame | View Log