3 -- Grant of Unlimited Rights
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
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.
26 -- FOUNDATION DESCRIPTION:
27 -- This foundation provides the basis for testing package
28 -- System.Storage_Pools. It provides simple implementations of
29 -- Allocate and Deallocate that have the side effect of calling
30 -- TCTouch.Touch when they are called.
33 -- 02 JUN 95 SAIC Initial version
34 -- 05 APR 96 SAIC Fixed header for 2.1
35 -- 02 JUL 98 EDS Swapped Pool.Avail change with overflow check
38 ---------------------------------------------------------------- FDB0A00
41 with System
.Storage_Pools
;
42 with System
.Storage_Elements
;
45 type Stack_Heap
( Water_Line
: System
.Storage_Elements
.Storage_Count
)
46 is new System
.Storage_Pools
.Root_Storage_Pool
with private;
49 Pool
: in out Stack_Heap
;
50 Storage_Address
: out System
.Address
;
51 Size_In_Storage_Elements
: in System
.Storage_Elements
.Storage_Count
;
52 Alignment
: in System
.Storage_Elements
.Storage_Count
);
55 Pool
: in out Stack_Heap
;
56 Storage_Address
: in System
.Address
;
57 Size_In_Storage_Elements
: in System
.Storage_Elements
.Storage_Count
;
58 Alignment
: in System
.Storage_Elements
.Storage_Count
);
60 function Storage_Size
( Pool
: in Stack_Heap
)
61 return System
.Storage_Elements
.Storage_Count
;
63 function TC_Largest_Request
return System
.Storage_Elements
.Storage_Count
;
65 Pool_Overflow
: exception;
69 type Data_Array
is array(System
.Storage_Elements
.Storage_Count
range <>)
70 of System
.Storage_Elements
.Storage_Element
;
72 type Stack_Heap
( Water_Line
: System
.Storage_Elements
.Storage_Count
)
73 is new System
.Storage_Pools
.Root_Storage_Pool
with record
74 Data
: Data_Array
(1..Water_Line
);
75 Avail
: System
.Storage_Elements
.Storage_Count
:= 1;
80 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
83 package body FDB0A00
is
85 Largest_Request_On_Record
: System
.Storage_Elements
.Storage_Count
:= 0;
88 Pool
: in out Stack_Heap
;
89 Storage_Address
: out System
.Address
;
90 Size_In_Storage_Elements
: in System
.Storage_Elements
.Storage_Count
;
91 Alignment
: in System
.Storage_Elements
.Storage_Count
) is
92 use type System
.Storage_Elements
.Storage_Offset
;
94 TCTouch
.Touch
('A'); --------------------------------------------------- A
96 -- set the pointer to the next correctly aligned available address
97 Pool
.Avail
:= Pool
.Avail
98 + (Alignment
- (Pool
.Data
(Pool
.Avail
)'Address mod Alignment
));
100 -- check for overflow
101 if Pool
.Avail
+ Size_In_Storage_Elements
> Pool
.Water_Line
then
105 -- set the resulting address to that address
106 Storage_Address
:= Pool
.Data
(Pool
.Avail
)'Address;
108 -- update the housekeeping
109 Pool
.Avail
:= Pool
.Avail
+ Size_In_Storage_Elements
;
110 Largest_Request_On_Record
111 := System
.Storage_Elements
.Storage_Count
'Max(Largest_Request_On_Record
,
112 Size_In_Storage_Elements
);
114 when Constraint_Error
=> raise Pool_Overflow
; -- in case I missed an edge
117 procedure Deallocate
(
118 Pool
: in out Stack_Heap
;
119 Storage_Address
: in System
.Address
;
120 Size_In_Storage_Elements
: in System
.Storage_Elements
.Storage_Count
;
121 Alignment
: in System
.Storage_Elements
.Storage_Count
) is
123 TCTouch
.Touch
('D'); --------------------------------------------------- D
125 -- for the purposes of validation, the simplest possible implementation
126 -- of Deallocate is shown below:
132 function Storage_Size
( Pool
: in Stack_Heap
)
133 return System
.Storage_Elements
.Storage_Count
is
135 TCTouch
.Touch
('S'); --------------------------------------------------- S
136 return Pool
.Water_Line
;
139 function TC_Largest_Request
return System
.Storage_Elements
.Storage_Count
is
141 return Largest_Request_On_Record
;
142 end TC_Largest_Request
;