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