diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/cc/cc50a01.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/cc/cc50a01.a | 313 |
1 files changed, 0 insertions, 313 deletions
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc50a01.a b/gcc/testsuite/ada/acats/tests/cc/cc50a01.a deleted file mode 100644 index 4d5dfdfd50d..00000000000 --- a/gcc/testsuite/ada/acats/tests/cc/cc50a01.a +++ /dev/null @@ -1,313 +0,0 @@ --- 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; |