1with Ada.Exceptions; 2use Ada.Exceptions; 3 4package body Sequential_Fixed_Block is 5 6 7 function Value_At (Location : System.Address) return SSE.Storage_Offset is 8 begin 9 return Link.To_Pointer (Location).all; 10 end Value_At; 11 12 procedure Place (Value : in SSE.Storage_Offset; 13 Location : in System.Address) is 14 begin 15 Link.To_Pointer (Location).all := Value; 16 end Place; 17 18 19 use type SSE.Storage_Offset; 20 21 22 procedure Allocate (Pool : in out Storage_Pool; 23 Storage_Address : out System.Address; 24 Allocation : in SSE.Storage_Count; 25 Alignment : in SSE.Storage_Count) is 26 begin 27 if Pool.Next_Free /= Null_Pointer then 28 -- at least one is available 29 Storage_Address := Pool.Content (Pool.Next_Free)'Address; 30 Pool.Next_Free := Value_At (Storage_Address); 31 else 32 -- none available 33 raise Storage_Error; 34 end if; 35 end Allocate; 36 37 38 procedure Deallocate (Pool : in out Storage_Pool; 39 Storage_Address : in System.Address; 40 Allocation : in SSE.Storage_Count; 41 Alignment : in SSE.Storage_Count) is 42 begin 43 -- Note: we are not checking to see if previously deallocated! 44 -- place index of next free element into this space (treated as 45 -- a storage_offset value) 46 Place (Pool.Next_Free, Storage_Address); 47 -- update next_free index to indicate this newly-freed space 48 Pool.Next_Free := 49 Storage_Address 50 - Pool.Content'Address 51 + Pool.Content_Alignment_Offset 52 + 1; 53 end Deallocate; 54 55 56 function Storage_Size (Pool : Storage_Pool) return SSE.Storage_Count is 57 begin 58 return Pool.Size; 59 end Storage_Size; 60 61 62 procedure Initialize (Pool : in out Storage_Pool) is 63 Next_Out : SSE.Storage_Offset; 64 begin 65 Pool.Aligned_Element_Size := 66 ((Pool.Element_Size + Pool.Alignment - 1) / Pool.Alignment) 67 * Pool.Alignment; 68 if (SSE.Storage_Offset'Size / System.Storage_Unit) 69 > Pool.Aligned_Element_Size then 70 Raise_Exception 71 (Representation_Error'Identity, 72 "Bookkeeping would overlap allocated elements."); 73 end if; 74 if Pool.Content'Address mod Pool.Alignment /= 0 then 75 -- Content(1) is not properly aligned 76 Pool.Content_Alignment_Offset := 77 Pool.Alignment - (Pool.Content'Address mod Pool.Alignment); 78 else 79 -- Content(1) is aligned properly 80 Pool.Content_Alignment_Offset := 0; 81 end if; 82 Next_Out := Pool.Content'First + Pool.Content_Alignment_Offset; 83 Pool.Next_Free := Null_Pointer; 84 while Next_Out <= Pool.Size - Pool.Aligned_Element_Size + 1 loop 85 Place (Pool.Next_Free, Pool.Content (Next_Out)'Address); 86 Pool.Next_Free := Next_Out; 87 Next_Out := Next_Out + Pool.Aligned_Element_Size; 88 end loop; 89 end Initialize; 90 91 92 function Available_Allocations (Pool : Storage_Pool) return Natural is 93 Result : Natural := 0; 94 Ptr : SSE.Storage_Offset; 95 begin 96 Ptr := Pool.Next_Free; 97 while Ptr /= Null_Pointer loop 98 Result := Result + 1; 99 Ptr := Value_At (Pool.Content (Ptr)'Address); 100 end loop; 101 return Result; 102 end Available_Allocations; 103 104 105 function Empty (Pool : Storage_Pool) return Boolean is 106 begin 107 return Pool.Next_Free = Null_Pointer; 108 end Empty; 109 110 111end Sequential_Fixed_Block; 112