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