1--  Efficient expandable one dimensional array.
2--  Copyright (C) 2015 - 2016 Tristan Gingold
3--
4--  This program is free software: you can redistribute it and/or modify
5--  it under the terms of the GNU General Public License as published by
6--  the Free Software Foundation, either version 2 of the License, or
7--  (at your option) any later version.
8--
9--  This program is distributed in the hope that it will be useful,
10--  but WITHOUT ANY WARRANTY; without even the implied warranty of
11--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12--  GNU General Public License for more details.
13--
14--  You should have received a copy of the GNU General Public License
15--  along with this program.  If not, see <gnu.org/licenses>.
16
17with Interfaces.C; use Interfaces.C;
18with System;
19
20package body Dyn_Tables is
21   --  Size of an element in storage units (bytes).
22   El_Size : constant size_t :=
23     size_t (Table_Type'Component_Size / System.Storage_Unit);
24
25   --  Expand the table by doubling its size.  The table must have been
26   --  initialized.
27   procedure Expand (T : in out Instance; Num : Unsigned)
28   is
29      --  For efficiency, directly call realloc.
30      function Crealloc (Ptr : Table_Thin_Ptr; Size : size_t)
31                        return Table_Thin_Ptr;
32      pragma Import (C, Crealloc, "realloc");
33
34      New_Len : Unsigned;
35      New_Last : Unsigned;
36   begin
37      pragma Assert (T.Priv.Length /= 0);
38      pragma Assert (T.Table /= null);
39
40      --  Expand the bound.
41      New_Last := T.Priv.Last_Pos + Num;
42      if New_Last < T.Priv.Last_Pos then
43         raise Constraint_Error;
44      end if;
45      T.Priv.Last_Pos := New_Last;
46
47      --  Check if need to reallocate.
48      if T.Priv.Last_Pos < T.Priv.Length then
49         return;
50      end if;
51
52      --  Double the length.
53      loop
54         New_Len := T.Priv.Length * 2;
55
56         --  Check overflow.
57         if New_Len < T.Priv.Length then
58            raise Constraint_Error;
59         end if;
60
61         T.Priv.Length := New_Len;
62         exit when New_Len > T.Priv.Last_Pos;
63      end loop;
64
65      --  Realloc and check result.
66      if size_t (T.Priv.Length) > size_t'Last / El_Size then
67         raise Constraint_Error;
68      end if;
69      T.Table := Crealloc (T.Table, size_t (T.Priv.Length) * El_Size);
70      if T.Table = null then
71         raise Storage_Error;
72      end if;
73   end Expand;
74
75   procedure Allocate (T : in out Instance; Num : Natural := 1) is
76   begin
77      Expand (T, Unsigned (Num));
78   end Allocate;
79
80   procedure Increment_Last (T : in out Instance) is
81   begin
82      --  Increase by 1.
83      Expand (T, 1);
84   end Increment_Last;
85
86   procedure Decrement_Last (T : in out Instance) is
87   begin
88      T.Priv.Last_Pos := T.Priv.Last_Pos - 1;
89   end Decrement_Last;
90
91   procedure Set_Last (T : in out Instance; Index : Table_Index_Type)
92   is
93      New_Last : constant Unsigned :=
94        (Table_Index_Type'Pos (Index)
95           - Table_Index_Type'Pos (Table_Low_Bound) + 1);
96   begin
97      if New_Last < T.Priv.Last_Pos then
98         --  Decrease length.
99         T.Priv.Last_Pos := New_Last;
100      else
101         --  Increase length.
102         Expand (T, New_Last - T.Priv.Last_Pos);
103      end if;
104   end Set_Last;
105
106   procedure Init (T : in out Instance; Table_Initial : Positive)
107   is
108      --  Direct interface to malloc.
109      function Cmalloc (Size : size_t) return Table_Thin_Ptr;
110      pragma Import (C, Cmalloc, "malloc");
111   begin
112      if T.Table = null then
113         --  Allocate memory if not already allocated.
114         T.Priv.Length := Unsigned (Table_Initial);
115         T.Table := Cmalloc (size_t (T.Priv.Length) * El_Size);
116      end if;
117
118      --  Table is initially empty.
119      T.Priv.Last_Pos := 0;
120   end Init;
121
122   function Last (T : Instance) return Table_Index_Type is
123   begin
124      return Table_Index_Type'Val
125        (Table_Index_Type'Pos (Table_Low_Bound)
126           + Unsigned'Pos (T.Priv.Last_Pos) - 1);
127   end Last;
128
129   function Next (T : Instance) return Table_Index_Type is
130   begin
131      return Table_Index_Type'Val
132        (Table_Index_Type'Pos (Table_Low_Bound) + T.Priv.Last_Pos);
133   end Next;
134
135   procedure Free (T : in out Instance) is
136      --  Direct interface to free.
137      procedure Cfree (Ptr : Table_Thin_Ptr);
138      pragma Import (C, Cfree, "free");
139   begin
140      Cfree (T.Table);
141      T := (Table => null,
142            Priv => (Length => 0,
143                     Last_Pos => 0));
144   end Free;
145
146   procedure Append (T : in out Instance; Val : Table_Component_Type) is
147   begin
148      Increment_Last (T);
149      T.Table (Last (T)) := Val;
150   end Append;
151end Dyn_Tables;
152