1-- CC50A01.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 formal parameter of a library-level generic unit may be 28-- a formal tagged private type. Check that a nonlimited tagged type may 29-- be passed as an actual. Check that if the formal type is indefinite, 30-- both indefinite and definite types may be passed as actuals. 31-- 32-- TEST DESCRIPTION: 33-- The generic package declares a formal tagged private type (this can 34-- be considered the parent "mixin" class). This type is extended in 35-- the generic to provide support for stacks of items of any nonlimited 36-- tagged type. Stacks are modeled as singly linked lists, with the list 37-- nodes being objects of the extended type. 38-- 39-- A generic testing procedure pushes items onto a stack, and pops them 40-- back off, verifying the state of the stack at various points along the 41-- way. The push and pop routines exercise functionality important to 42-- tagged types, such as type conversion toward the root of the derivation 43-- class and extension aggregates. 44-- 45-- The formal tagged private type has an unknown discriminant part, and 46-- is thus indefinite. This allows both definite and indefinite types 47-- to be passed as actuals. For tagged types, definite implies 48-- nondiscriminated, and indefinite implies discriminated (with known 49-- or unknown discriminants). 50-- 51-- TEST FILES: 52-- This test consists of the following files: 53-- 54-- FC50A00.A 55-- -> CC50A01.A 56-- 57-- 58-- CHANGE HISTORY: 59-- 06 Dec 94 SAIC ACVC 2.0 60-- 21 Nov 95 SAIC ACVC 2.0.1 fixes: Moved instantiations of 61-- BC50A01_0 to library level. 62-- 11 Aug 96 SAIC ACVC 2.1: Updated prologue. Added pragma 63-- Elaborate to context clauses for CC50A01_2 & _3. 64-- 65--! 66 67with FC50A00; -- Tagged (actual) type declarations. 68generic -- Generic stack abstraction. 69 70 type Item (<>) is tagged private; -- Formal tagged private type. 71 TC_Default_Value : Item; -- Needed in View_Top (see 72 -- below). 73package CC50A01_0 is 74 75 type Stack is private; 76 77-- Note that because the actual type corresponding to Item may be 78-- unconstrained, the functions of removing the top item from the stack and 79-- returning the value of the top item of the stack have been separated into 80-- Pop and View_Top, respectively. This is necessary because otherwise the 81-- returned value would have to be an out parameter of Pop, which would 82-- require the user (in the unconstrained case) to create an uninitialized 83-- unconstrained object to serve as the actual, which is illegal. 84 85 procedure Push (I : in Item; S : in out Stack); 86 procedure Pop (S : in out Stack); 87 function View_Top (S : Stack) return Item; 88 89 function Size_Of (S : Stack) return Natural; 90 91private 92 93 type Stack_Item; 94 type Stack_Ptr is access Stack_Item; 95 96 type Stack_Item is new Item with record -- Extends formal type. 97 Next : Stack_Ptr := null; 98 end record; 99 100 type Stack is record 101 Top : Stack_Ptr := null; 102 Size : Natural := 0; 103 end record; 104 105end CC50A01_0; 106 107 108 --==================================================================-- 109 110 111package body CC50A01_0 is 112 113 -- Link NewItem in at the top of the stack (the extension aggregate within 114 -- the allocator initializes the inherited portion of NewItem to equal I, 115 -- and NewItem.Next to point to what S.Top points to). 116 117 procedure Push (I : in Item; S : in out Stack) is 118 NewItem : Stack_Ptr; 119 begin 120 NewItem := new Stack_Item'(I with S.Top); -- Extension aggregate. 121 S.Top := NewItem; 122 S.Size := S.Size + 1; 123 end Push; 124 125 126 -- Remove item from top of stack. This procedure only updates the state of 127 -- the stack; it does not return the value of the popped item. Hence, in 128 -- order to accomplish a "true" pop, both View_Top and Pop must be called 129 -- consecutively. 130 -- 131 -- If the stack is empty, the Pop is ignored (for simplicity; in a true 132 -- application this might be treated as an error condition). 133 134 procedure Pop (S : in out Stack) is 135 begin 136 if S.Top = null then -- Stack is empty. 137 null; 138 -- Raise exception. 139 else 140 S.Top := S.Top.Next; 141 S.Size := S.Size - 1; 142 -- Deallocate discarded node. 143 end if; 144 end Pop; 145 146 147 -- Return the value of the top item on the stack. This procedure only 148 -- returns the value; it does not remove the top item from the stack. 149 -- Hence, in order to accomplish a "true" pop, both View_Top and Pop must 150 -- be called consecutively. 151 -- 152 -- Since items on the stack are of a type (Stack_Item) derived from Item, 153 -- which is a (tagged) private type, type conversion toward the root is the 154 -- only way to get a value of type Item for return to the caller. 155 -- 156 -- If the stack is empty, View_Top returns a pre-specified default value. 157 -- (In a true application, an exception might be raised instead). 158 159 function View_Top (S : Stack) return Item is 160 begin 161 if S.Top = null then -- Stack is empty. 162 return TC_Default_Value; -- Testing artifice. 163 -- Raise exception. 164 else 165 return Item(S.Top.all); -- Type conversion. 166 end if; 167 end View_Top; 168 169 170 function Size_Of (S : Stack) return Natural is 171 begin 172 return (S.Size); 173 end Size_Of; 174 175 176end CC50A01_0; 177 178 179 --==================================================================-- 180 181 182-- The formal package Stacker below is needed to gain access to the 183-- appropriate version of the "generic" type Stack. It is provided with an 184-- explicit actual part in order to restrict the packages that can be passed 185-- as actuals to those which have been instantiated with the same actuals 186-- which this generic procedure has been instantiated with. 187 188with CC50A01_0; -- Generic stack abstraction. 189generic 190 type Item_Type (<>) is tagged private; -- Formal tagged private type. 191 Default : Item_Type; 192 with package Stacker is new CC50A01_0 (Item_Type, Default); 193procedure CC50A01_1 (S : in out Stacker.Stack; I : in Item_Type); 194 195 196 --==================================================================-- 197 198-- 199-- This generic procedure performs all of the testing of the 200-- stack abstraction. 201-- 202 203with Report; 204procedure CC50A01_1 (S : in out Stacker.Stack; I : in Item_Type) is 205begin 206 Stacker.Push (I, S); -- Push onto empty stack. 207 Stacker.Push (I, S); -- Push onto nonempty stack. 208 209 if Stacker.Size_Of (S) /= 2 then 210 Report.Failed (" Wrong stack size after 2 Pushes"); 211 end if; 212 213 -- Calls to View_Top must initialize a declared object of type Item_Type 214 -- because the type may be unconstrained. 215 216 declare 217 Buffer1 : Item_Type := Stacker.View_Top (S); 218 begin 219 Stacker.Pop (S); -- Pop item off nonempty stack. 220 if Buffer1 /= I then 221 Report.Failed (" Wrong stack item value after 1st Pop"); 222 end if; 223 end; 224 225 declare 226 Buffer2 : Item_Type := Stacker.View_Top (S); 227 begin 228 Stacker.Pop (S); -- Pop last item off stack. 229 if Buffer2 /= I then 230 Report.Failed (" Wrong stack item value after 2nd Pop"); 231 end if; 232 end; 233 234 if Stacker.Size_Of (S) /= 0 then 235 Report.Failed (" Wrong stack size after 2 Pops"); 236 end if; 237 238 declare 239 Buffer3 : Item_Type := Stacker.View_Top (S); 240 begin 241 if Buffer3 /= Default then 242 Report.Failed (" Wrong result after Pop of empty stack"); 243 end if; 244 Stacker.Pop (S); -- Pop off empty stack. 245 end; 246 247end CC50A01_1; 248 249 250 --==================================================================-- 251 252 253with FC50A00; 254 255with CC50A01_0; 256pragma Elaborate (CC50A01_0); 257 258package CC50A01_2 is new CC50A01_0 (FC50A00.Count_Type, 259 FC50A00.TC_Default_Count); 260 261 262 --==================================================================-- 263 264 265with FC50A00; 266 267with CC50A01_0; 268pragma Elaborate (CC50A01_0); 269 270package CC50A01_3 is new CC50A01_0 (FC50A00.Person_Type, 271 FC50A00.TC_Default_Person); 272 273 274 --==================================================================-- 275 276 277with FC50A00; -- Tagged (actual) type declarations. 278with CC50A01_0; -- Generic stack abstraction. 279with CC50A01_1; -- Generic stack testing procedure. 280with CC50A01_2; 281with CC50A01_3; 282 283with Report; 284procedure CC50A01 is 285 286 package Count_Stacks renames CC50A01_2; 287 package Person_Stacks renames CC50A01_3; 288 289 290 procedure TC_Count_Test is new CC50A01_1 (FC50A00.Count_Type, 291 FC50A00.TC_Default_Count, 292 Count_Stacks); 293 Count_Stack : Count_Stacks.Stack; 294 295 296 procedure TC_Person_Test is new CC50A01_1 (FC50A00.Person_Type, 297 FC50A00.TC_Default_Person, 298 Person_Stacks); 299 Person_Stack : Person_Stacks.Stack; 300 301begin 302 Report.Test ("CC50A01", "Check that a formal parameter of a " & 303 "library-level generic unit may be a formal tagged " & 304 "private type"); 305 306 Report.Comment ("Testing definite tagged type.."); 307 TC_Count_Test (Count_Stack, FC50A00.TC_Count_Item); 308 309 Report.Comment ("Testing indefinite tagged type.."); 310 TC_Person_Test (Person_Stack, FC50A00.TC_Person_Item); 311 312 Report.Result; 313end CC50A01; 314