Subversion Repositories openrisc

-- CA11020.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 body of the generic parent package can depend on one of

--      its own public generic children.

--

-- TEST DESCRIPTION:

--      A scenario is created that demonstrates the potential of adding a

--      public generic child during code maintenance without distubing a large

--      subsystem.  After child is added to the subsystem, a maintainer

--      decides to take advantage of the new functionality and rewrites

--      the parent's body.

--

--      Declare a bag abstraction in a generic package. Declare a public

--      generic child of this package which adds a generic procedure to the

--      original subsystem.  In the parent body, instantiate the public

--      child.  Then instantiate the procedure as a child instance of the

--      public child instance.

--

--      In the main program, declare an instance of parent.  Check that the

--      operations in both parent and child packages perform as expected.

--

--

-- CHANGE HISTORY:

--      06 Dec 94   SAIC    ACVC 2.0

--

--!

-- Simulates bag application.

generic

   type Element is private;

   with function Image (E : Element) return String;

package CA11020_0 is

   type Bag is limited private;

   procedure Add (E : in Element; To_The_Bag : in out Bag);

   function Bag_Image (B : Bag) return string;

private

   type Node_Type;

   type Bag is access Node_Type;

   type Node_Type is

      record

         The_Element : Element;

         -- Other components in real application, i.e.,

         -- The_Count   : positive;

         Next        : Bag;

      end record;

end CA11020_0;

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

-- More operations on Bag.

generic

-- Parameters go here.

package CA11020_0.CA11020_1 is

   -- ... Other declarations.

   generic                            -- Generic iterator procedure.

      with procedure Use_Element (E : in Element);

   procedure Iterate (B : in Bag);    -- Called once per element in the bag.

   -- ... Various other operations.

end CA11020_0.CA11020_1;

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

package body CA11020_0.CA11020_1 is

   procedure Iterate (B : in Bag) is

   -- Traverse each element in the bag.

      Elem : Bag := B;

   begin

      while Elem /= null loop

         Use_Element (Elem.The_Element);

         Elem := Elem.Next;

      end loop;

   end Iterate;

end CA11020_0.CA11020_1;

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

with CA11020_0.CA11020_1;    -- Public generic child package.

package body CA11020_0 is

   ----------------------------------------------------

   -- Parent's body depends on public generic child. --

   ----------------------------------------------------

   -- Instantiate the public child.

   package MS is new CA11020_1;

   function Bag_Image (B : Bag) return string is

      Buffer : String (1 .. 10_000);

      Last   : Integer := 0;

      -----------------------------------------------------

      -- Will be called by the iterator.

      procedure Append_Image (E : in Element) is

         Im : constant String := Image (E);

      begin  -- Append_Image

         if Last /= 0 then        -- Insert a comma.

            Last := Last + 1;

            Buffer (Last) := ',';

         end if;

         Buffer (Last + 1 .. Last + Im'Length) := Im;

         Last := Last + Im'Length;

      end Append_Image;

      -----------------------------------------------------

      -- Instantiate procedure Iterate as a child of instance MS.

      procedure Append_All is new MS.Iterate (Use_Element => Append_Image);

   begin  -- Bag_Image

      Append_All (B);

      return Buffer (1 .. Last);

   end Bag_Image;

           -----------------------------------------------------

   procedure Add (E : in Element; To_The_Bag : in out Bag) is

      -- Not a real bag addition.

      Index : Bag := To_The_Bag;

   begin

      -- ... Error-checking code omitted for brevity.

      if Index = null then

         To_The_Bag := new Node_Type' (The_Element => E,

                                       Next        => null);

      else

         -- Goto the end of the list.

         while Index.Next /= null loop

            Index := Index.Next;

         end loop;

         -- Add element to the end of the list.

         Index.Next := new Node_Type' (The_Element => E,

                                       Next        => null);

      end if;

   end Add;

end CA11020_0;

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

with CA11020_0;               -- Bag application.

with Report;

procedure CA11020 is

    -- Instantiate the bag application for integer type and attribute

    -- Image.

    package Bag_Of_Integers is new CA11020_0 (Integer, Integer'Image);

    My_Bag : Bag_Of_Integers.Bag;

begin

   Report.Test ("CA11020", "Check that body of the generic parent package " &

                "can depend on one of its own public generic children");

   -- Add 10 consecutive integers to the bag.

   for I in 1 .. 10 loop

      Bag_Of_Integers.Add (I, My_Bag);

   end loop;

   if Bag_Of_Integers.Bag_Image (My_Bag)

      /= " 1, 2, 3, 4, 5, 6, 7, 8, 9, 10" then

         Report.Failed ("Incorrect results");

   end if;

   Report.Result;

end CA11020;