ca11019.a

来自「用于进行gcc测试」· A 代码 · 共 307 行

-- CA11019.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 parent package may depend on one of its own
--      private generic children.
--
-- TEST DESCRIPTION:
--      A scenario is created that demonstrates the potential of adding a
--      generic private 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 data collection abstraction in a package. Declare a private
--      generic child of this package which provides parameterized code that
--      have been written once and will be used three times to implement the
--      services of the parent package. In the parent body, instantiate the 
--      private child.  
--
--      In the main program, check that the operations in the parent, 
--      and instance of the private child package perform as expected.  
--
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--      17 Nov 95   SAIC    Update and repair for ACVC 2.0.1
--
--!
  
package CA11019_0 is   
     -- parent

   type Data_Record is tagged private;
   type Data_Collection is private;
   ---
   ---
   subtype Data_1 is integer range 0 .. 100;
   procedure Add_1 (Data : Data_1; To : in out Data_Collection);  
   function Statistical_Op_1 (Data : Data_Collection) return Data_1;
   ---
   subtype Data_2 is integer range -100 .. 1000;
   procedure Add_2 (Data : Data_2; To : in out Data_Collection);
   function Statistical_Op_2 (Data : Data_Collection) return Data_2;
   ---
   subtype Data_3 is integer range -10_000 .. 10_000;
   procedure Add_3 (Data : Data_3; To : in out Data_Collection);  
   function Statistical_Op_3 (Data : Data_Collection) return Data_3;
   ---

private

   type Data_Ptr is access Data_Record'class;
   subtype Sequence_Number is positive range 1 .. 512;

   type Data_Record is tagged 
     record
        Next  : Data_Ptr := null;
        Seq   : Sequence_Number;
     end record;
   ---
   type Data_Collection is 
     record
        First : Data_Ptr := null;
        Last  : Data_Ptr := null;
     end record;
            
end CA11019_0;
 -- parent

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

-- This generic package provides parameterized code that has been
-- written once and will be used three times to implement the services
-- of the parent package.

private
generic   
   type Data_Type is range <>;

package CA11019_0.CA11019_1 is    
     -- parent.child

   type Data_Elem is new Data_Record with
     record
        Value : Data_Type;
     end record;

   Next_Avail_Seq_No : Sequence_Number := 1;

   procedure Sequence (Ptr : Data_Ptr);
    -- the child must be private for this procedure to know details of
    -- the implementation of data collections

   procedure Add (Datum : Data_Type; To : in out Data_Collection);

   function  Op  (Data : Data_Collection) return Data_Type;
    -- op models a complicated operation that whose code can be
    -- used for various data types


end CA11019_0.CA11019_1;
 -- parent.child

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

 
package body CA11019_0.CA11019_1 is    
          -- parent.child

   procedure Sequence (Ptr : Data_Ptr) is
   begin
      Ptr.Seq := Next_Avail_Seq_No;
      Next_Avail_Seq_No := Next_Avail_Seq_No + 1;
   end Sequence;

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

   procedure Add (Datum : Data_Type; To : in out Data_Collection) is
      Ptr : Data_Ptr;
   begin
      if To.First = null then
         -- assign new record with data value to 
         -- to.next <- null;
         To.First := new Data_Elem'(Next  => null,
                                    Value => Datum,
                                    Seq   => 1);
         Sequence (To.First);
         To.Last := To.First;
      else
         -- chase to end of list
         Ptr := To.First;
         while Ptr.Next /= null loop
            Ptr := Ptr.Next;
         end loop;
         -- and add element there
         Ptr.Next := new Data_Elem'(Next  => null,
                                    Value => Datum,
                                    Seq   => 1);
         Sequence (Ptr.Next);
         To.Last := Ptr.Next;
      end if;

   end Add;

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

   function  Op  (Data : Data_Collection) return Data_Type is
      -- for simplicity, just return the maximum of the data set
      Max : Data_Type := Data_Elem( Data.First.all ).Value; 
                              -- assuming non-empty collection
      Ptr : Data_Ptr  := Data.First;

   begin
      -- no error checking
      while Ptr.Next /= null loop
         if Data_Elem( Ptr.Next.all ).Value > Max then
            Max := Data_Elem( Ptr.Next.all ).Value;
         end if;
         Ptr := Ptr.Next;
      end loop;
      return Max;
   end Op;

end CA11019_0.CA11019_1;
 -- parent.child

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

-- parent body depends on private generic child
with CA11019_0.CA11019_1;     -- Private generic child.

pragma Elaborate (CA11019_0.CA11019_1);
package body CA11019_0 is

   -- instantiate the generic child with data types needed by the 
   -- package interface services
   package Data_1_Ops is new CA11019_1
     (Data_Type => Data_1);
 
   package Data_2_Ops is new CA11019_1
     (Data_Type => Data_2);

   package Data_3_Ops is new CA11019_1
     (Data_Type => Data_3);

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

   procedure Add_1 (Data : Data_1; To : in out Data_Collection) is
   begin
      -- maybe do other stuff here
      Data_1_Ops.Add (Data, To);
      -- and here
   end;

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

   function Statistical_Op_1 (Data : Data_Collection) return Data_1 is
   begin
      -- maybe use generic operation(s) in some complicated ways
      -- (but simplified out, for the sake of testing)
      return Data_1_Ops.Op (Data);
   end;

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

   procedure Add_2 (Data : Data_2; To : in out Data_Collection) is
   begin
      Data_2_Ops.Add (Data, To);
   end;

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

   function Statistical_Op_2 (Data : Data_Collection) return Data_2 is
   begin
      return Data_2_Ops.Op (Data);
   end;

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

   procedure Add_3 (Data : Data_3; To : in out Data_Collection) is
   begin
      Data_3_Ops.Add (Data, To);
   end;

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

   function Statistical_Op_3 (Data : Data_Collection) return Data_3 is
   begin
      return Data_3_Ops.Op (Data);
   end;

end CA11019_0;


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

with CA11019_0,
  -- Main,    
  -- Main.Child is private
     Report;

procedure CA11019 is

   package Main renames CA11019_0;

   Col_1,
   Col_2,
   Col_3 : Main.Data_Collection;

begin

   Report.Test ("CA11019", "Check that body of a (non-generic) package " &
                "may depend on its private generic child");

   -- build a data collection

   for I in 1 .. 10 loop
      Main.Add_1 ( Main.Data_1(I), Col_1);
   end loop;

   if Main.Statistical_Op_1 (Col_1) /= 10 then 
      Report.Failed ("Wrong data_1 value returned");
   end if;

   for I in reverse 10 .. 20 loop
      Main.Add_2 ( Main.Data_2(I * 10), Col_2);
   end loop;

   if Main.Statistical_Op_2 (Col_2) /= 200 then 
      Report.Failed ("Wrong data_2 value returned");
   end if;

   for I in 0 .. 10 loop
      Main.Add_3 ( Main.Data_3(I + 5), Col_3);
   end loop;

   if Main.Statistical_Op_3 (Col_3) /= 15 then 
      Report.Failed ("Wrong data_3 value returned");
   end if;

   Report.Result;

end CA11019;