llvm-gcc-4.0/gcc/testsuite/ada/acats/tests/ca/ca11020.a

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