| -- CC54001.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 general access-to-constant type may be passed as an |
| -- actual to a generic formal access-to-constant type. |
| -- |
| -- TEST DESCRIPTION: |
| -- The generic implements a stack of access objects as an array. The |
| -- designated type of the formal access type is itself a formal private |
| -- type declared in the same generic formal part. |
| -- |
| -- The generic is instantiated with an unconstrained subtype of String, |
| -- which results in a stack which can accommodate strings of varying |
| -- lengths (ragged array). Furthermore, the access objects to be pushed |
| -- onto the stack are created both statically and dynamically, utilizing |
| -- allocators and the 'Access attribute. |
| -- |
| -- |
| -- CHANGE HISTORY: |
| -- 06 Dec 94 SAIC ACVC 2.0 |
| -- 10 Apr 96 SAIC ACVC 2.1: Added pragma Elaborate to context clause |
| -- preceding CC54001_1. |
| -- |
| --! |
| |
| generic |
| Size : in Positive; |
| type Element_Type (<>) is private; |
| type Element_Ptr is access constant Element_Type; |
| package CC54001_0 is -- Generic stack of pointers. |
| |
| type Stack_Type is private; |
| |
| procedure Push (Stack : in out Stack_Type; |
| Elem_Ptr : in Element_Ptr); |
| |
| procedure Pop (Stack : in out Stack_Type; |
| Elem_Ptr : out Element_Ptr); |
| |
| -- ... Other operations. |
| |
| private |
| |
| subtype Index is Positive range 1 .. (Size + 1); |
| type Stack_Type is array (Index) of Element_Ptr; -- Last element unused. |
| |
| Top : Index := 1; |
| |
| end CC54001_0; |
| |
| |
| --===================================================================-- |
| |
| |
| package body CC54001_0 is |
| |
| procedure Push (Stack : in out Stack_Type; |
| Elem_Ptr : in Element_Ptr) is |
| begin |
| Stack(Top) := Elem_Ptr; |
| Top := Top + 1; -- Artificial: no Constraint_Error protection. |
| end Push; |
| |
| |
| procedure Pop (Stack : in out Stack_Type; |
| Elem_Ptr : out Element_Ptr) is |
| begin |
| Top := Top - 1; -- Artificial: no Constraint_Error protection. |
| Elem_Ptr := Stack(Top); |
| end Pop; |
| |
| end CC54001_0; |
| |
| |
| --===================================================================-- |
| |
| |
| with CC54001_0; -- Generic stack of pointers. |
| pragma Elaborate (CC54001_0); |
| |
| package CC54001_1 is |
| |
| subtype Message is String; |
| type Message_Ptr is access constant Message; |
| |
| Message_Count : constant := 4; |
| |
| Message_0 : aliased constant Message := "Hello"; |
| Message_1 : aliased constant Message := "Doctor"; |
| Message_2 : aliased constant Message := "Name"; |
| Message_3 : aliased constant Message := "Continue"; |
| |
| |
| package Stack_of_Messages is new CC54001_0 |
| (Element_Type => Message, |
| Element_Ptr => Message_Ptr, |
| Size => Message_Count); |
| |
| Message_Stack : Stack_Of_Messages.Stack_Type; |
| |
| |
| procedure Create_Message_Stack; |
| |
| end CC54001_1; |
| |
| |
| --===================================================================-- |
| |
| |
| package body CC54001_1 is |
| |
| procedure Create_Message_Stack is |
| -- Push access objects onto stack. Note that some are statically |
| -- allocated, and some are dynamically allocated (using an aliased |
| -- object to initialize). |
| begin |
| Stack_Of_Messages.Push (Message_Stack, Message_0'Access); -- Static. |
| Stack_Of_Messages.Push (Message_Stack, |
| new Message'(Message_1)); -- Dynamic. |
| Stack_Of_Messages.Push (Message_Stack, Message_2'Access); -- Static. |
| Stack_Of_Messages.Push (Message_Stack, -- Dynamic. |
| new Message'(Message_3)); |
| end Create_Message_Stack; |
| |
| end CC54001_1; |
| |
| |
| --===================================================================-- |
| |
| |
| with CC54001_1; |
| |
| with Report; |
| procedure CC54001 is |
| |
| package Messages renames CC54001_1.Stack_Of_Messages; |
| |
| Msg0, Msg1, Msg2, Msg3 : CC54001_1.Message_Ptr; |
| |
| begin |
| Report.Test ("CC54001", "Check that a general access-to-constant type " & |
| "may be passed as an actual to a generic formal " & |
| "access-to-constant type"); |
| |
| CC54001_1.Create_Message_Stack; |
| |
| Messages.Pop (CC54001_1.Message_Stack, Msg3); -- Pop items off stack in the |
| Messages.Pop (CC54001_1.Message_Stack, Msg2); -- reverse order that they |
| Messages.Pop (CC54001_1.Message_Stack, Msg1); -- were pushed. |
| Messages.Pop (CC54001_1.Message_Stack, Msg0); |
| |
| if Msg0.all /= CC54001_1.Message_0 or else |
| Msg1.all /= CC54001_1.Message_1 or else |
| Msg2.all /= CC54001_1.Message_2 or else |
| Msg3.all /= CC54001_1.Message_3 |
| then |
| Report.Failed ("Items popped off of stack do not match those pushed"); |
| end if; |
| |
| Report.Result; |
| end CC54001; |