1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                   G N A T . D Y N A M I C _ T A B L E S                  --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--           Copyright (C) 2000-2003 Ada Core Technologies, Inc.            --
10--                                                                          --
11-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12-- terms of the  GNU General Public License as published  by the Free Soft- --
13-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
14-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
17-- for  more details.  You should have  received  a copy of the GNU General --
18-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
19-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
20-- MA 02111-1307, USA.                                                      --
21--                                                                          --
22-- As a special exception,  if other files  instantiate  generics from this --
23-- unit, or you link  this unit with other files  to produce an executable, --
24-- this  unit  does not  by itself cause  the resulting  executable  to  be --
25-- covered  by the  GNU  General  Public  License.  This exception does not --
26-- however invalidate  any other reasons why  the executable file  might be --
27-- covered by the  GNU Public License.                                      --
28--                                                                          --
29-- GNAT was originally developed  by the GNAT team at  New York University. --
30-- Extensive contributions were provided by Ada Core Technologies Inc.      --
31--                                                                          --
32------------------------------------------------------------------------------
33
34with GNAT.Heap_Sort_G;
35with System;        use System;
36with System.Memory; use System.Memory;
37
38with Unchecked_Conversion;
39
40package body GNAT.Dynamic_Tables is
41
42   Min : constant Integer := Integer (Table_Low_Bound);
43   --  Subscript of the minimum entry in the currently allocated table
44
45   -----------------------
46   -- Local Subprograms --
47   -----------------------
48
49   procedure Reallocate (T : in out Instance);
50   --  Reallocate the existing table according to the current value stored
51   --  in Max. Works correctly to do an initial allocation if the table
52   --  is currently null.
53
54   function To_Address is new Unchecked_Conversion (Table_Ptr, Address);
55   function To_Pointer is new Unchecked_Conversion (Address, Table_Ptr);
56
57   --------------
58   -- Allocate --
59   --------------
60
61   procedure Allocate
62     (T   : in out Instance;
63      Num : Integer := 1)
64   is
65   begin
66      T.P.Last_Val := T.P.Last_Val + Num;
67
68      if T.P.Last_Val > T.P.Max then
69         Reallocate (T);
70      end if;
71   end Allocate;
72
73   ------------
74   -- Append --
75   ------------
76
77   procedure Append (T : in out Instance; New_Val : Table_Component_Type) is
78   begin
79      Increment_Last (T);
80      T.Table (Table_Index_Type (T.P.Last_Val)) := New_Val;
81   end Append;
82
83   --------------------
84   -- Decrement_Last --
85   --------------------
86
87   procedure Decrement_Last (T : in out Instance) is
88   begin
89      T.P.Last_Val := T.P.Last_Val - 1;
90   end Decrement_Last;
91
92   --------------
93   -- For_Each --
94   --------------
95
96   procedure For_Each (Table : Instance) is
97      Quit : Boolean := False;
98   begin
99      for Index in Table_Low_Bound .. Table_Index_Type (Table.P.Last_Val) loop
100         Action (Index, Table.Table (Index), Quit);
101         exit when Quit;
102      end loop;
103   end For_Each;
104
105   ----------
106   -- Free --
107   ----------
108
109   procedure Free (T : in out Instance) is
110   begin
111      Free (To_Address (T.Table));
112      T.Table := null;
113      T.P.Length := 0;
114   end Free;
115
116   --------------------
117   -- Increment_Last --
118   --------------------
119
120   procedure Increment_Last (T : in out Instance) is
121   begin
122      T.P.Last_Val := T.P.Last_Val + 1;
123
124      if T.P.Last_Val > T.P.Max then
125         Reallocate (T);
126      end if;
127   end Increment_Last;
128
129   ----------
130   -- Init --
131   ----------
132
133   procedure Init (T : in out Instance) is
134      Old_Length : constant Integer := T.P.Length;
135
136   begin
137      T.P.Last_Val := Min - 1;
138      T.P.Max      := Min + Table_Initial - 1;
139      T.P.Length   := T.P.Max - Min + 1;
140
141      --  If table is same size as before (happens when table is never
142      --  expanded which is a common case), then simply reuse it. Note
143      --  that this also means that an explicit Init call right after
144      --  the implicit one in the package body is harmless.
145
146      if Old_Length = T.P.Length then
147         return;
148
149      --  Otherwise we can use Reallocate to get a table of the right size.
150      --  Note that Reallocate works fine to allocate a table of the right
151      --  initial size when it is first allocated.
152
153      else
154         Reallocate (T);
155      end if;
156   end Init;
157
158   ----------
159   -- Last --
160   ----------
161
162   function Last (T : in Instance) return Table_Index_Type is
163   begin
164      return Table_Index_Type (T.P.Last_Val);
165   end Last;
166
167   ----------------
168   -- Reallocate --
169   ----------------
170
171   procedure Reallocate (T : in out Instance) is
172      New_Length : Integer;
173      New_Size   : size_t;
174
175   begin
176      if T.P.Max < T.P.Last_Val then
177         while T.P.Max < T.P.Last_Val loop
178            New_Length := T.P.Length * (100 + Table_Increment) / 100;
179
180            if New_Length > T.P.Length then
181               T.P.Length := New_Length;
182            else
183               T.P.Length := T.P.Length + 1;
184            end if;
185
186            T.P.Max := Min + T.P.Length - 1;
187         end loop;
188      end if;
189
190      New_Size :=
191        size_t ((T.P.Max - Min + 1) *
192                (Table_Type'Component_Size / Storage_Unit));
193
194      if T.Table = null then
195         T.Table := To_Pointer (Alloc (New_Size));
196
197      elsif New_Size > 0 then
198         T.Table :=
199           To_Pointer (Realloc (Ptr  => To_Address (T.Table),
200                                Size => New_Size));
201      end if;
202
203      if T.P.Length /= 0 and then T.Table = null then
204         raise Storage_Error;
205      end if;
206   end Reallocate;
207
208   -------------
209   -- Release --
210   -------------
211
212   procedure Release (T : in out Instance) is
213   begin
214      T.P.Length := T.P.Last_Val - Integer (Table_Low_Bound) + 1;
215      T.P.Max    := T.P.Last_Val;
216      Reallocate (T);
217   end Release;
218
219   --------------
220   -- Set_Item --
221   --------------
222
223   procedure Set_Item
224     (T     : in out Instance;
225      Index : Table_Index_Type;
226      Item  : Table_Component_Type)
227   is
228   begin
229      if Integer (Index) > T.P.Last_Val then
230         Set_Last (T, Index);
231      end if;
232
233      T.Table (Index) := Item;
234   end Set_Item;
235
236   --------------
237   -- Set_Last --
238   --------------
239
240   procedure Set_Last (T : in out Instance; New_Val : Table_Index_Type) is
241   begin
242      if Integer (New_Val) < T.P.Last_Val then
243         T.P.Last_Val := Integer (New_Val);
244
245      else
246         T.P.Last_Val := Integer (New_Val);
247
248         if T.P.Last_Val > T.P.Max then
249            Reallocate (T);
250         end if;
251      end if;
252   end Set_Last;
253
254   ----------------
255   -- Sort_Table --
256   ----------------
257
258   procedure Sort_Table (Table : in out Instance) is
259
260      Temp : Table_Component_Type;
261      --  A temporary position to simulate index 0
262
263      --  Local subprograms
264
265      function Index_Of (Idx : Natural) return Table_Index_Type;
266      --  Apply Natural to indexs of the table
267
268      function Lower_Than (Op1, Op2 : Natural) return Boolean;
269      --  Compare two components
270
271      procedure Move (From : Natural; To : Natural);
272      --  Move one component
273
274      package Heap_Sort is new GNAT.Heap_Sort_G (Move, Lower_Than);
275
276      --------------
277      -- Index_Of --
278      --------------
279
280      function Index_Of (Idx : Natural) return Table_Index_Type is
281      begin
282         return First + Table_Index_Type (Idx) - 1;
283      end Index_Of;
284
285      ----------
286      -- Move --
287      ----------
288
289      procedure Move (From : Natural; To : Natural) is
290      begin
291         if From = 0 then
292            Table.Table (Index_Of (To)) := Temp;
293
294         elsif To = 0 then
295            Temp := Table.Table (Index_Of (From));
296
297         else
298            Table.Table (Index_Of (To)) :=
299              Table.Table (Index_Of (From));
300         end if;
301      end Move;
302
303      ----------------
304      -- Lower_Than --
305      ----------------
306
307      function Lower_Than (Op1, Op2 : Natural) return Boolean is
308      begin
309         if Op1 = 0 then
310            return Lt (Temp, Table.Table (Index_Of (Op2)));
311
312         elsif Op2 = 0 then
313            return Lt (Table.Table (Index_Of (Op1)), Temp);
314
315         else
316            return
317              Lt (Table.Table (Index_Of (Op1)),
318                   Table.Table (Index_Of (Op2)));
319         end if;
320      end Lower_Than;
321
322   --  Start of processing for Sort_Table
323
324   begin
325
326      Heap_Sort.Sort (Natural (Last (Table) - First) + 1);
327
328   end Sort_Table;
329
330end GNAT.Dynamic_Tables;
331