Subversion Repositories openrisc

-- CC51D02.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 class-wide 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 derivative. Declare an operation

--      for the root tagged type and override it for the derivative. 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 class-wide

--      type for the root tagged type.

--

-- TEST FILES:

--      The following files comprise this test:

--

--         FC51D00.A

--      -> CC51D02.A

--

--

-- CHANGE HISTORY:

--      06 Dec 94   SAIC    ACVC 2.0

--      05 Jan 95   SAIC    Changed types of TC_Expected_1 and TC_Expected_2

--                          from specific to class-wide. Eliminated (illegal)

--                          assignment step prior to comparison of

--                          TC_Expected_X with item on stack.

--

--!

package CC51D02_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.

end CC51D02_0;

     --==================================================================--

package body CC51D02_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 CC51D02_0;

     --==================================================================--

--                           --

-- Formal package used here. --

--                           --

with FC51D00;    -- Generic list abstraction.

with CC51D02_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 CC51D02_0.Blind_ID_Type with private;

   with package List_Mgr is new FC51D00 (Elem_Type);

procedure CC51D02_1 (L : in out List_Mgr.List_Type; E : in Elem_Type);

     --==================================================================--

-- The implementation of CC51D02_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 (based on the tag of the actual), which updates the object's

-- SSN field. Write_Element then adds the object to the list.

procedure CC51D02_1 (L : in out List_Mgr.List_Type; E : in Elem_Type) is

   Element : Elem_Type := E;   -- Can't update IN parameter.

                               -- Initialization of unconstrained variable.

begin

   Update_ID (Element);                    -- Executes actual type's version

                                           -- (for this test, this will be a

                                           -- dispatching call).

   List_Mgr.Write_Element (1, L, Element); -- Executes actual type's version

                                           -- (for this test, this will be a

                                           -- class-wide operation).

end CC51D02_1;

     --==================================================================--

with FC51D00;    -- Generic list abstraction.

with CC51D02_0;  -- Tagged type declarations.

with CC51D02_1;  -- Generic operation.

with Report;

procedure CC51D02 is

   use CC51D02_0;                                        -- All types & ops

                                                         -- directly visible.

   -- Begin test code declarations: -----------------------

   TC_Expected_1 : Blind_ID_Type'Class :=

                   Blind_ID_Type'(SSN => "111223333");

   TC_Expected_2 : Blind_ID_Type'Class :=

                   Named_ID_Type'("444556666", "Doe      ");

   TC_Initial_1  : Blind_ID_Type       := (SSN => "777889999");

   TC_Initial_2  : Named_ID_Type       := ("777889999", "Doe      ");

   TC_Initial_3  : Blind_ID_Type'Class := TC_Initial_2;

   -- End test code declarations. -------------------------

   package ID_Class_Lists is new FC51D00 (Blind_ID_Type'Class);

   procedure Update_and_Write is new CC51D02_1 (Blind_ID_Type'Class,

                                                ID_Class_Lists);

   Blind_List  : ID_Class_Lists.List_Type;

   Named_List  : ID_Class_Lists.List_Type;

   Maimed_List : ID_Class_Lists.List_Type;

begin

   Report.Test ("CC51D02", "Formal private extension, class-wide actual: " &

                "body of primitive subprogram executed is that of actual " &

                "type. Check for subprograms declared in formal package");

   Update_and_Write (Blind_List, TC_Initial_1);    -- Test root type actual.

   if (ID_Class_Lists.View_Element (1, Blind_List) not in Blind_ID_Type) then

      Report.Failed ("Result for root type actual is not in proper class");

   elsif (ID_Class_Lists.View_Element (1, Blind_List) /= TC_Expected_1) then

      Report.Failed ("Wrong result for root type actual");

   end if;

   Update_and_Write (Named_List, TC_Initial_2);    -- Test derived type actual.

   if (ID_Class_Lists.View_Element (1, Named_List) not in Named_ID_Type) then

      Report.Failed ("Result for derived type actual is not in proper class");

   elsif (ID_Class_Lists.View_Element (1, Named_List)/= TC_Expected_2) then

      Report.Failed ("Wrong result for derived type actual");

   end if;

   -- In the subtest below, an object of a class-wide type (TC_Initial_3) is

   -- passed to Update_and_Write. It has been initialized with an object of

   -- type Named_ID_Type, so the result should be identical to

   -- that of the Named_ID_Type subtest (namely TC_Expected_2). Note that

   -- a new list of Named IDs is used (Maimed_List). This is to assure test

   -- validity, since Named_List has already been updated by a previous

   -- subtest.

   Update_and_Write (Maimed_List, TC_Initial_3);   -- Test class-wide actual.

   if (ID_Class_Lists.View_Element (1, Maimed_List) not in Named_ID_Type) then

      Report.Failed ("Result for class-wide actual is not in proper class");

   elsif (ID_Class_Lists.View_Element (1, Maimed_List) /= TC_Expected_2) then

      Report.Failed ("Wrong result for class-wide actual");

   end if;

   Report.Result;

end CC51D02;