1-- CC54001.A 2-- 3-- Grant of Unlimited Rights 4-- 5-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, 6-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained 7-- unlimited rights in the software and documentation contained herein. 8-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making 9-- this public release, the Government intends to confer upon all 10-- recipients unlimited rights equal to those held by the Government. 11-- These rights include rights to use, duplicate, release or disclose the 12-- released technical data and computer software in whole or in part, in 13-- any manner and for any purpose whatsoever, and to have or permit others 14-- to do so. 15-- 16-- DISCLAIMER 17-- 18-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR 19-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED 20-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE 21-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE 22-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A 23-- PARTICULAR PURPOSE OF SAID MATERIAL. 24--* 25-- 26-- OBJECTIVE: 27-- Check that a general access-to-constant type may be passed as an 28-- actual to a generic formal access-to-constant type. 29-- 30-- TEST DESCRIPTION: 31-- The generic implements a stack of access objects as an array. The 32-- designated type of the formal access type is itself a formal private 33-- type declared in the same generic formal part. 34-- 35-- The generic is instantiated with an unconstrained subtype of String, 36-- which results in a stack which can accommodate strings of varying 37-- lengths (ragged array). Furthermore, the access objects to be pushed 38-- onto the stack are created both statically and dynamically, utilizing 39-- allocators and the 'Access attribute. 40-- 41-- 42-- CHANGE HISTORY: 43-- 06 Dec 94 SAIC ACVC 2.0 44-- 10 Apr 96 SAIC ACVC 2.1: Added pragma Elaborate to context clause 45-- preceding CC54001_1. 46-- 47--! 48 49generic 50 Size : in Positive; 51 type Element_Type (<>) is private; 52 type Element_Ptr is access constant Element_Type; 53package CC54001_0 is -- Generic stack of pointers. 54 55 type Stack_Type is private; 56 57 procedure Push (Stack : in out Stack_Type; 58 Elem_Ptr : in Element_Ptr); 59 60 procedure Pop (Stack : in out Stack_Type; 61 Elem_Ptr : out Element_Ptr); 62 63 -- ... Other operations. 64 65private 66 67 subtype Index is Positive range 1 .. (Size + 1); 68 type Stack_Type is array (Index) of Element_Ptr; -- Last element unused. 69 70 Top : Index := 1; 71 72end CC54001_0; 73 74 75 --===================================================================-- 76 77 78package body CC54001_0 is 79 80 procedure Push (Stack : in out Stack_Type; 81 Elem_Ptr : in Element_Ptr) is 82 begin 83 Stack(Top) := Elem_Ptr; 84 Top := Top + 1; -- Artificial: no Constraint_Error protection. 85 end Push; 86 87 88 procedure Pop (Stack : in out Stack_Type; 89 Elem_Ptr : out Element_Ptr) is 90 begin 91 Top := Top - 1; -- Artificial: no Constraint_Error protection. 92 Elem_Ptr := Stack(Top); 93 end Pop; 94 95end CC54001_0; 96 97 98 --===================================================================-- 99 100 101with CC54001_0; -- Generic stack of pointers. 102pragma Elaborate (CC54001_0); 103 104package CC54001_1 is 105 106 subtype Message is String; 107 type Message_Ptr is access constant Message; 108 109 Message_Count : constant := 4; 110 111 Message_0 : aliased constant Message := "Hello"; 112 Message_1 : aliased constant Message := "Doctor"; 113 Message_2 : aliased constant Message := "Name"; 114 Message_3 : aliased constant Message := "Continue"; 115 116 117 package Stack_of_Messages is new CC54001_0 118 (Element_Type => Message, 119 Element_Ptr => Message_Ptr, 120 Size => Message_Count); 121 122 Message_Stack : Stack_Of_Messages.Stack_Type; 123 124 125 procedure Create_Message_Stack; 126 127end CC54001_1; 128 129 130 --===================================================================-- 131 132 133package body CC54001_1 is 134 135 procedure Create_Message_Stack is 136 -- Push access objects onto stack. Note that some are statically 137 -- allocated, and some are dynamically allocated (using an aliased 138 -- object to initialize). 139 begin 140 Stack_Of_Messages.Push (Message_Stack, Message_0'Access); -- Static. 141 Stack_Of_Messages.Push (Message_Stack, 142 new Message'(Message_1)); -- Dynamic. 143 Stack_Of_Messages.Push (Message_Stack, Message_2'Access); -- Static. 144 Stack_Of_Messages.Push (Message_Stack, -- Dynamic. 145 new Message'(Message_3)); 146 end Create_Message_Stack; 147 148end CC54001_1; 149 150 151 --===================================================================-- 152 153 154with CC54001_1; 155 156with Report; 157procedure CC54001 is 158 159 package Messages renames CC54001_1.Stack_Of_Messages; 160 161 Msg0, Msg1, Msg2, Msg3 : CC54001_1.Message_Ptr; 162 163begin 164 Report.Test ("CC54001", "Check that a general access-to-constant type " & 165 "may be passed as an actual to a generic formal " & 166 "access-to-constant type"); 167 168 CC54001_1.Create_Message_Stack; 169 170 Messages.Pop (CC54001_1.Message_Stack, Msg3); -- Pop items off stack in the 171 Messages.Pop (CC54001_1.Message_Stack, Msg2); -- reverse order that they 172 Messages.Pop (CC54001_1.Message_Stack, Msg1); -- were pushed. 173 Messages.Pop (CC54001_1.Message_Stack, Msg0); 174 175 if Msg0.all /= CC54001_1.Message_0 or else 176 Msg1.all /= CC54001_1.Message_1 or else 177 Msg2.all /= CC54001_1.Message_2 or else 178 Msg3.all /= CC54001_1.Message_3 179 then 180 Report.Failed ("Items popped off of stack do not match those pushed"); 181 end if; 182 183 Report.Result; 184end CC54001; 185