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