cc50a02.a

来自「linux下编程用 编译软件」· A 代码 · 共 228 行

-- CC50A02.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 a nonlimited tagged type may be passed as an actual to a
--      formal (non-tagged) private type. Check that if the formal type has
--      an unknown discriminant part, a class-wide type may also be passed as
--      an actual.
--
-- TEST DESCRIPTION:
--      A generic package declares a formal private type and defines a
--      stack abstraction. Stacks are modeled as singly linked lists of
--      pointers to elements. Pointers are used because the elements may
--      be unconstrained.
--
--      A generic testing procedure pushes an item onto a stack, then views
--      the item on top of the stack.
--
--      The formal private type has an unknown discriminant part, and
--      is thus indefinite. This allows both definite and indefinite types
--      (including class-wide types) to be passed as actuals. For tagged types,
--      definite implies nondiscriminated, and indefinite implies discriminated
--      (with known/unknown discriminants). 
--
-- TEST FILES:
--      The following files comprise this test:
--
--         FC50A00.A
--      -> CC50A02.A
--
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--      10 Nov 95   SAIC    ACVC 2.0.1 fixes: Removed use of formal package
--                          exception name in exception choice.
--
--!

generic        -- Generic stack abstraction.
   type Item (<>) is private;                   -- Formal private type.
package CC50A02_0 is

   type Stack is private;

   procedure Push     (I : in Item; S : in out Stack);
   function  View_Top (S : Stack) return Item;

   -- ...Other stack operations...

   Stack_Empty : exception;

private

   type Item_Ptr is access Item;

   type Stack_Item;
   type Stack_Ptr is access Stack_Item;

   type Stack_Item is record
      Item : Item_Ptr;
      Next : Stack_Ptr;
   end record;

   type Stack is record
      Top  : Stack_Ptr := null;
      Size : Natural   := 0;
   end record;

end CC50A02_0;


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


package body CC50A02_0 is

   -- Link NewItem in at the top of the stack.

   procedure Push (I : in Item; S : in out Stack) is
      NewItem : Item_Ptr  := new Item'(I);
      Element : Stack_Ptr := new Stack_Item'(Item => NewItem, Next => S.Top);
   begin
      S.Top   := Element;
      S.Size  := S.Size + 1;
   end Push;


   -- Return (copy) of top item on stack. Do NOT remove from stack.

   function View_Top (S : Stack) return Item is
   begin
      if S.Top = null then
         raise Stack_Empty;
      else
         return S.Top.Item.all;
      end if;
   end View_Top;

end CC50A02_0;


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


-- The formal package Stacker below is needed to gain access to the
-- appropriate version of the "generic" type Stack. It is provided with an
-- explicit actual part in order to restrict the packages that can be passed
-- as actuals to those which have been instantiated with the same actuals
-- which this generic procedure has been instantiated with.

with CC50A02_0;  -- Generic stack abstraction.
generic
   type Item_Type (<>) is private;       -- Formal private type.
   with package Stacker is new CC50A02_0 (Item_Type);
procedure CC50A02_1 (S : in out Stacker.Stack; I : in Item_Type);


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

--
-- This generic procedure performs all of the testing of the
-- stack abstraction.
--

with Report;
procedure CC50A02_1 (S : in out Stacker.Stack; I : in Item_Type) is
begin
   Stacker.Push (I, S);                    -- Push onto empty stack.

   -- Calls to View_Top must initialize a declared object of type Item_Type
   -- because the type may be unconstrained.

   declare
      Buffer : Item_Type := Stacker.View_Top (S);
   begin
      if Buffer /= I then
         Report.Failed ("   Expected item not on stack");
      end if;
   exception
      when Constraint_Error =>
         Report.Failed ("   Unexpected error: Tags of pushed and popped " &
                        "items don't match");
   end;


exception
   when others =>
      Report.Failed ("   Unexpected error: Item not pushed onto stack");
end CC50A02_1;


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


with FC50A00;   -- Tagged (actual) type declarations.
with CC50A02_0; -- Generic stack abstraction.
with CC50A02_1; -- Generic stack testing procedure.

with Report;
procedure CC50A02 is

   --
   -- Pass a nondiscriminated tagged actual:
   --

   package   Count_Stacks  is new CC50A02_0 (FC50A00.Count_Type);
   procedure TC_Count_Test is new CC50A02_1 (FC50A00.Count_Type,
                                             Count_Stacks);
   Count_Stack : Count_Stacks.Stack;


   --
   -- Pass a discriminated tagged actual:
   --
 
   package   Person_Stacks  is new CC50A02_0 (FC50A00.Person_Type);
   procedure TC_Person_Test is new CC50A02_1 (FC50A00.Person_Type,
                                              Person_Stacks);
   Person_Stack : Person_Stacks.Stack;


   --
   -- Pass a class-wide actual:
   --
 
   package   People_Stacks  is new CC50A02_0 (FC50A00.Person_Type'Class);
   procedure TC_People_Test is new CC50A02_1 (FC50A00.Person_Type'Class,
                                              People_Stacks);
   People_Stack : People_Stacks.Stack;

begin
   Report.Test ("CC50A02", "Check that tagged actuals may be passed " &
                "to a formal (nontagged) private type");

   Report.Comment ("Testing definite tagged type..");
   TC_Count_Test  (Count_Stack,  FC50A00.TC_Count_Item);

   Report.Comment ("Testing indefinite tagged type..");
   TC_Person_Test (Person_Stack, FC50A00.TC_Person_Item);

   Report.Comment ("Testing class-wide type..");
   TC_People_Test (People_Stack, FC50A00.TC_VIPerson_Item);

   Report.Result;
end CC50A02;