| -- CC50A01.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 formal parameter of a library-level generic unit may be |
| -- a formal tagged private type. Check that a nonlimited tagged type may |
| -- be passed as an actual. Check that if the formal type is indefinite, |
| -- both indefinite and definite types may be passed as actuals. |
| -- |
| -- TEST DESCRIPTION: |
| -- The generic package declares a formal tagged private type (this can |
| -- be considered the parent "mixin" class). This type is extended in |
| -- the generic to provide support for stacks of items of any nonlimited |
| -- tagged type. Stacks are modeled as singly linked lists, with the list |
| -- nodes being objects of the extended type. |
| -- |
| -- A generic testing procedure pushes items onto a stack, and pops them |
| -- back off, verifying the state of the stack at various points along the |
| -- way. The push and pop routines exercise functionality important to |
| -- tagged types, such as type conversion toward the root of the derivation |
| -- class and extension aggregates. |
| -- |
| -- The formal tagged private type has an unknown discriminant part, and |
| -- is thus indefinite. This allows both definite and indefinite types |
| -- to be passed as actuals. For tagged types, definite implies |
| -- nondiscriminated, and indefinite implies discriminated (with known |
| -- or unknown discriminants). |
| -- |
| -- TEST FILES: |
| -- This test consists of the following files: |
| -- |
| -- FC50A00.A |
| -- -> CC50A01.A |
| -- |
| -- |
| -- CHANGE HISTORY: |
| -- 06 Dec 94 SAIC ACVC 2.0 |
| -- 21 Nov 95 SAIC ACVC 2.0.1 fixes: Moved instantiations of |
| -- BC50A01_0 to library level. |
| -- 11 Aug 96 SAIC ACVC 2.1: Updated prologue. Added pragma |
| -- Elaborate to context clauses for CC50A01_2 & _3. |
| -- |
| --! |
| |
| with FC50A00; -- Tagged (actual) type declarations. |
| generic -- Generic stack abstraction. |
| |
| type Item (<>) is tagged private; -- Formal tagged private type. |
| TC_Default_Value : Item; -- Needed in View_Top (see |
| -- below). |
| package CC50A01_0 is |
| |
| type Stack is private; |
| |
| -- Note that because the actual type corresponding to Item may be |
| -- unconstrained, the functions of removing the top item from the stack and |
| -- returning the value of the top item of the stack have been separated into |
| -- Pop and View_Top, respectively. This is necessary because otherwise the |
| -- returned value would have to be an out parameter of Pop, which would |
| -- require the user (in the unconstrained case) to create an uninitialized |
| -- unconstrained object to serve as the actual, which is illegal. |
| |
| procedure Push (I : in Item; S : in out Stack); |
| procedure Pop (S : in out Stack); |
| function View_Top (S : Stack) return Item; |
| |
| function Size_Of (S : Stack) return Natural; |
| |
| private |
| |
| type Stack_Item; |
| type Stack_Ptr is access Stack_Item; |
| |
| type Stack_Item is new Item with record -- Extends formal type. |
| Next : Stack_Ptr := null; |
| end record; |
| |
| type Stack is record |
| Top : Stack_Ptr := null; |
| Size : Natural := 0; |
| end record; |
| |
| end CC50A01_0; |
| |
| |
| --==================================================================-- |
| |
| |
| package body CC50A01_0 is |
| |
| -- Link NewItem in at the top of the stack (the extension aggregate within |
| -- the allocator initializes the inherited portion of NewItem to equal I, |
| -- and NewItem.Next to point to what S.Top points to). |
| |
| procedure Push (I : in Item; S : in out Stack) is |
| NewItem : Stack_Ptr; |
| begin |
| NewItem := new Stack_Item'(I with S.Top); -- Extension aggregate. |
| S.Top := NewItem; |
| S.Size := S.Size + 1; |
| end Push; |
| |
| |
| -- Remove item from top of stack. This procedure only updates the state of |
| -- the stack; it does not return the value of the popped item. Hence, in |
| -- order to accomplish a "true" pop, both View_Top and Pop must be called |
| -- consecutively. |
| -- |
| -- If the stack is empty, the Pop is ignored (for simplicity; in a true |
| -- application this might be treated as an error condition). |
| |
| procedure Pop (S : in out Stack) is |
| begin |
| if S.Top = null then -- Stack is empty. |
| null; |
| -- Raise exception. |
| else |
| S.Top := S.Top.Next; |
| S.Size := S.Size - 1; |
| -- Deallocate discarded node. |
| end if; |
| end Pop; |
| |
| |
| -- Return the value of the top item on the stack. This procedure only |
| -- returns the value; it does not remove the top item from the stack. |
| -- Hence, in order to accomplish a "true" pop, both View_Top and Pop must |
| -- be called consecutively. |
| -- |
| -- Since items on the stack are of a type (Stack_Item) derived from Item, |
| -- which is a (tagged) private type, type conversion toward the root is the |
| -- only way to get a value of type Item for return to the caller. |
| -- |
| -- If the stack is empty, View_Top returns a pre-specified default value. |
| -- (In a true application, an exception might be raised instead). |
| |
| function View_Top (S : Stack) return Item is |
| begin |
| if S.Top = null then -- Stack is empty. |
| return TC_Default_Value; -- Testing artifice. |
| -- Raise exception. |
| else |
| return Item(S.Top.all); -- Type conversion. |
| end if; |
| end View_Top; |
| |
| |
| function Size_Of (S : Stack) return Natural is |
| begin |
| return (S.Size); |
| end Size_Of; |
| |
| |
| end CC50A01_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 CC50A01_0; -- Generic stack abstraction. |
| generic |
| type Item_Type (<>) is tagged private; -- Formal tagged private type. |
| Default : Item_Type; |
| with package Stacker is new CC50A01_0 (Item_Type, Default); |
| procedure CC50A01_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 CC50A01_1 (S : in out Stacker.Stack; I : in Item_Type) is |
| begin |
| Stacker.Push (I, S); -- Push onto empty stack. |
| Stacker.Push (I, S); -- Push onto nonempty stack. |
| |
| if Stacker.Size_Of (S) /= 2 then |
| Report.Failed (" Wrong stack size after 2 Pushes"); |
| end if; |
| |
| -- Calls to View_Top must initialize a declared object of type Item_Type |
| -- because the type may be unconstrained. |
| |
| declare |
| Buffer1 : Item_Type := Stacker.View_Top (S); |
| begin |
| Stacker.Pop (S); -- Pop item off nonempty stack. |
| if Buffer1 /= I then |
| Report.Failed (" Wrong stack item value after 1st Pop"); |
| end if; |
| end; |
| |
| declare |
| Buffer2 : Item_Type := Stacker.View_Top (S); |
| begin |
| Stacker.Pop (S); -- Pop last item off stack. |
| if Buffer2 /= I then |
| Report.Failed (" Wrong stack item value after 2nd Pop"); |
| end if; |
| end; |
| |
| if Stacker.Size_Of (S) /= 0 then |
| Report.Failed (" Wrong stack size after 2 Pops"); |
| end if; |
| |
| declare |
| Buffer3 : Item_Type := Stacker.View_Top (S); |
| begin |
| if Buffer3 /= Default then |
| Report.Failed (" Wrong result after Pop of empty stack"); |
| end if; |
| Stacker.Pop (S); -- Pop off empty stack. |
| end; |
| |
| end CC50A01_1; |
| |
| |
| --==================================================================-- |
| |
| |
| with FC50A00; |
| |
| with CC50A01_0; |
| pragma Elaborate (CC50A01_0); |
| |
| package CC50A01_2 is new CC50A01_0 (FC50A00.Count_Type, |
| FC50A00.TC_Default_Count); |
| |
| |
| --==================================================================-- |
| |
| |
| with FC50A00; |
| |
| with CC50A01_0; |
| pragma Elaborate (CC50A01_0); |
| |
| package CC50A01_3 is new CC50A01_0 (FC50A00.Person_Type, |
| FC50A00.TC_Default_Person); |
| |
| |
| --==================================================================-- |
| |
| |
| with FC50A00; -- Tagged (actual) type declarations. |
| with CC50A01_0; -- Generic stack abstraction. |
| with CC50A01_1; -- Generic stack testing procedure. |
| with CC50A01_2; |
| with CC50A01_3; |
| |
| with Report; |
| procedure CC50A01 is |
| |
| package Count_Stacks renames CC50A01_2; |
| package Person_Stacks renames CC50A01_3; |
| |
| |
| procedure TC_Count_Test is new CC50A01_1 (FC50A00.Count_Type, |
| FC50A00.TC_Default_Count, |
| Count_Stacks); |
| Count_Stack : Count_Stacks.Stack; |
| |
| |
| procedure TC_Person_Test is new CC50A01_1 (FC50A00.Person_Type, |
| FC50A00.TC_Default_Person, |
| Person_Stacks); |
| Person_Stack : Person_Stacks.Stack; |
| |
| begin |
| Report.Test ("CC50A01", "Check that a formal parameter of a " & |
| "library-level generic unit may be a formal tagged " & |
| "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.Result; |
| end CC50A01; |
