Add dyn_tables package, rewrite tables using dyn_tables.

4 files changed, 256 insertions, 99 deletions

diff --git a/src/dyn_tables.adb b/src/dyn_tables.adb
new file mode 100644
index 000000000..be733acc8
--- /dev/null
+++ b/src/dyn_tables.adb
@@ -0,0 +1,129 @@
+--  Efficient expandable one dimensional array.
+--  Copyright (C) 2015 - 2016 Tristan Gingold
+--
+--  GHDL is free software; you can redistribute it and/or modify it under
+--  the terms of the GNU General Public License as published by the Free
+--  Software Foundation; either version 2, or (at your option) any later
+--  version.
+--
+--  GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+--  WARRANTY; without even the implied warranty of MERCHANTABILITY or
+--  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+--  for more details.
+--
+--  You should have received a copy of the GNU General Public License
+--  along with GHDL; see the file COPYING.  If not, write to the Free
+--  Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+--  02111-1307, USA.
+
+with Interfaces.C; use Interfaces.C;
+with System;
+
+package body Dyn_Tables is
+   --  Size of an element in storage units (bytes).
+   El_Size : constant size_t :=
+     size_t (Table_Type'Component_Size / System.Storage_Unit);
+
+   --  Expand the table by doubling its size.  The table must have been
+   --  initialized.
+   procedure Expand (T : in out Instance; Num : Natural)
+   is
+      --  For efficiency, directly call realloc.
+      function Crealloc (Ptr : Table_Thin_Ptr; Size : size_t)
+                        return Table_Thin_Ptr;
+      pragma Import (C, Crealloc, "realloc");
+   begin
+      pragma Assert (T.Priv.Length /= 0);
+      pragma Assert (T.Table /= null);
+
+      --  Expand the bound.
+      T.Priv.Last_Pos := T.Priv.Last_Pos + Num;
+
+      --  Check if need to reallocate.
+      if T.Priv.Last_Pos < T.Priv.Length then
+         return;
+      else
+         --  Double the length.
+         loop
+            T.Priv.Length := T.Priv.Length * 2;
+            exit when T.Priv.Length > T.Priv.Last_Pos;
+         end loop;
+      end if;
+
+      --  Realloc and check result.
+      T.Table := Crealloc (T.Table, size_t (T.Priv.Length) * El_Size);
+      if T.Table = null then
+         raise Storage_Error;
+      end if;
+   end Expand;
+
+   procedure Allocate (T : in out Instance; Num : Natural := 1) is
+   begin
+      Expand (T, Num);
+   end Allocate;
+
+   procedure Increment_Last (T : in out Instance) is
+   begin
+      --  Increase by 1.
+      Expand (T, 1);
+   end Increment_Last;
+
+   procedure Decrement_Last (T : in out Instance) is
+   begin
+      T.Priv.Last_Pos := T.Priv.Last_Pos - 1;
+   end Decrement_Last;
+
+   procedure Set_Last (T : in out Instance; Index : Table_Index_Type)
+   is
+      New_Last : constant Natural :=
+        (Table_Index_Type'Pos (Index)
+           - Table_Index_Type'Pos (Table_Low_Bound) + 1);
+   begin
+      if New_Last < T.Priv.Last_Pos then
+         --  Decrease length.
+         T.Priv.Last_Pos := New_Last;
+      else
+         --  Increase length.
+         Expand (T, New_Last - T.Priv.Last_Pos);
+      end if;
+   end Set_Last;
+
+   procedure Init (T : in out Instance)
+   is
+      --  Direct interface to malloc.
+      function Cmalloc (Size : size_t) return Table_Thin_Ptr;
+      pragma Import (C, Cmalloc, "malloc");
+   begin
+      if T.Table = null then
+         --  Allocate memory if not already allocated.
+         T.Priv.Length := Table_Initial;
+         T.Table := Cmalloc (size_t (T.Priv.Length) * El_Size);
+      end if;
+
+      --  Table is initially empty.
+      T.Priv.Last_Pos := 0;
+   end Init;
+
+   function Last (T : Instance) return Table_Index_Type is
+   begin
+      return Table_Index_Type'Val
+        (Table_Index_Type'Pos (Table_Low_Bound) + T.Priv.Last_Pos - 1);
+   end Last;
+
+   procedure Free (T : in out Instance) is
+      --  Direct interface to free.
+      procedure Cfree (Ptr : Table_Thin_Ptr);
+      pragma Import (C, Cfree, "free");
+   begin
+      Cfree (T.Table);
+      T := (Table => null,
+            Priv => (Length => 0,
+                     Last_Pos => 0));
+   end Free;
+
+   procedure Append (T : in out Instance; Val : Table_Component_Type) is
+   begin
+      Increment_Last (T);
+      T.Table (Last (T)) := Val;
+   end Append;
+end Dyn_Tables;
diff --git a/src/dyn_tables.ads b/src/dyn_tables.ads
new file mode 100644
index 000000000..600e2bf85
--- /dev/null
+++ b/src/dyn_tables.ads
@@ -0,0 +1,105 @@
+--  Efficient expandable one dimensional array type.
+--  Copyright (C) 2015 - 2016 Tristan Gingold
+--
+--  GHDL is free software; you can redistribute it and/or modify it under
+--  the terms of the GNU General Public License as published by the Free
+--  Software Foundation; either version 2, or (at your option) any later
+--  version.
+--
+--  GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+--  WARRANTY; without even the implied warranty of MERCHANTABILITY or
+--  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+--  for more details.
+--
+--  You should have received a copy of the GNU General Public License
+--  along with GHDL; see the file COPYING.  If not, write to the Free
+--  Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+--  02111-1307, USA.
+
+--  This package mimics GNAT.Table, but:
+--  - the index type can be any discrete type (in particular a modular type)
+--  - the increment is not used
+--  - the interface is simplified.
+generic
+   --  This package creates:
+   --    array (Table_Index_Type range Table_Low_Bound .. <>)
+   --      of Table_Component_Type;
+   type Table_Component_Type is private;
+   type Table_Index_Type is (<>);
+
+   --  The lowest bound of the array.  Note that Table_Low_Bound shouldn't be
+   --  Table_Index_Type'First, as otherwise Last may raise constraint error
+   --  when the table is empty.
+   Table_Low_Bound : Table_Index_Type;
+
+   --  Initial number of elements.
+   Table_Initial   : Positive;
+
+package Dyn_Tables is
+   --  Ada type for the array.
+   type Table_Type is
+     array (Table_Index_Type range <>) of Table_Component_Type;
+   --  Fat subtype (so that the access is thin).
+   subtype Big_Table_Type is
+     Table_Type (Table_Low_Bound .. Table_Index_Type'Last);
+
+   --  Access type for the vector.  This is a thin pointer so that it is
+   --  compatible with C pointer, as this package uses malloc/realloc/free for
+   --  memory management.
+   type Table_Thin_Ptr is access all Big_Table_Type;
+   pragma Convention (C, Table_Thin_Ptr);
+   for Table_Thin_Ptr'Storage_Size use 0;
+
+   --  Non user visible data.
+   type Instance_Private is private;
+
+   --  Type for the dynamic table.
+   type Instance is record
+      --  Pointer to the table.  Note that the use of a thin pointer to the
+      --  largest array, this implementation bypasses Ada index checks.
+      Table : Table_Thin_Ptr := null;
+
+      --  Private data.
+      Priv : Instance_Private;
+   end record;
+
+   --  Initialize the table.  This is done automatically at elaboration.
+   procedure Init (T : in out Instance);
+
+   --  Logical bounds of the array.
+   First : constant Table_Index_Type := Table_Low_Bound;
+   function Last (T : Instance) return Table_Index_Type;
+   pragma Inline (Last);
+
+   --  Deallocate all the memory.  Makes the array unusable until the next
+   --  call to Init.
+   procedure Free (T : in out Instance);
+
+   --  Increase by 1 the length of the array.  This may allocate memory.
+   procedure Increment_Last (T : in out Instance);
+   pragma Inline (Increment_Last);
+
+   --  Decrease by 1 the length of the array.
+   procedure Decrement_Last (T : in out Instance);
+   pragma Inline (Decrement_Last);
+
+   --  Increase or decrease the length of the array by specifying the upper
+   --  bound.
+   procedure Set_Last (T : in out Instance; Index : Table_Index_Type);
+
+   --  Append VAL to the array.  This always increase the length of the array.
+   procedure Append (T : in out Instance; Val : Table_Component_Type);
+   pragma Inline (Append);
+
+   --  Increase by NUM the length of the array.
+   procedure Allocate (T : in out Instance; Num : Natural := 1);
+
+private
+   type Instance_Private is record
+      --  Number of allocated elements in the table.
+      Length : Natural := 0;
+
+      --  Number of used elements in the table.
+      Last_Pos : Natural := 0;
+   end record;
+end Dyn_Tables;
diff --git a/src/tables.adb b/src/tables.adb
index ca8674269..ef4cc385a 100644
--- a/src/tables.adb
+++ b/src/tables.adb
@@ -16,59 +16,13 @@
 --  Software Foundation, 59 Temple Place - Suite 330, Boston, MA
 --  02111-1307, USA.
 
-with Interfaces.C; use Interfaces.C;
-with System;
-
 package body Tables is
-   --  Number of allocated elements in the table.
-   Length : Natural := 0;
-
-   --  Number of used elements in the table.
-   Last_Pos : Natural := 0;
-
-   --  Size of an element in storage units (bytes).
-   El_Size : constant size_t :=
-     size_t (Table_Type'Component_Size / System.Storage_Unit);
-
-   --  Expand the table by doubling its size.  The table must have been
-   --  initialized.
-   procedure Expand (Num : Natural)
-   is
-      --  For efficiency, directly call realloc.
-      function Crealloc (Ptr : Table_Thin_Ptr; Size : size_t)
-                        return Table_Thin_Ptr;
-      pragma Import (C, Crealloc, "realloc");
-   begin
-      pragma Assert (Length /= 0);
-      pragma Assert (Table /= null);
-
-      --  Expand the bound.
-      Last_Pos := Last_Pos + Num;
-
-      --  Check if need to reallocate.
-      if Last_Pos < Length then
-         return;
-      else
-         --  Double the length.
-         loop
-            Length := Length * 2;
-            exit when Length > Last_Pos;
-         end loop;
-      end if;
-
-      --  Realloc and check result.
-      Table := Crealloc (Table, size_t (Length) * El_Size);
-      if Table = null then
-         raise Storage_Error;
-      end if;
-   end Expand;
-
    function Allocate (Num : Natural := 1) return Table_Index_Type
    is
       Res : constant Table_Index_Type := Table_Index_Type'Val
-        (Table_Index_Type'Pos (Table_Low_Bound) + Last_Pos);
+        (Table_Index_Type'Pos (Last) + 1);
    begin
-      Expand (Num);
+      Dyn_Table.Allocate (T, Num);
 
       return Res;
    end Allocate;
@@ -76,66 +30,37 @@ package body Tables is
    procedure Increment_Last is
    begin
       --  Increase by 1.
-      Expand (1);
+      Dyn_Table.Increment_Last (T);
    end Increment_Last;
 
    procedure Decrement_Last is
    begin
-      Last_Pos := Last_Pos - 1;
+      Dyn_Table.Decrement_Last (T);
    end Decrement_Last;
 
-   procedure Set_Last (Index : Table_Index_Type)
-   is
-      New_Last : constant Natural :=
-        (Table_Index_Type'Pos (Index)
-           - Table_Index_Type'Pos (Table_Low_Bound) + 1);
+   procedure Set_Last (Index : Table_Index_Type) is
    begin
-      if New_Last < Last_Pos then
-         --  Decrease length.
-         Last_Pos := New_Last;
-      else
-         --  Increase length.
-         Expand (New_Last - Last_Pos);
-      end if;
+      Dyn_Table.Set_Last (T, Index);
    end Set_Last;
 
-   procedure Init
-   is
-      --  Direct interface to malloc.
-      function Cmalloc (Size : size_t) return Table_Thin_Ptr;
-      pragma Import (C, Cmalloc, "malloc");
+   procedure Init is
    begin
-      if Table = null then
-         --  Allocate memory if not already allocated.
-         Length := Table_Initial;
-         Table := Cmalloc (size_t (Length) * El_Size);
-      end if;
-
-      --  Table is initially empty.
-      Last_Pos := 0;
+      Dyn_Table.Init (T);
    end Init;
 
    function Last return Table_Index_Type is
    begin
-      return Table_Index_Type'Val
-        (Table_Index_Type'Pos (Table_Low_Bound) + Last_Pos - 1);
+      return Dyn_Table.Last (T);
    end Last;
 
    procedure Free is
-      --  Direct interface to free.
-      procedure Cfree (Ptr : Table_Thin_Ptr);
-      pragma Import (C, Cfree, "free");
    begin
-      Cfree (Table);
-      Table := null;
-      Length := 0;
-      Last_Pos := 0;
+      Dyn_Table.Free (T);
    end Free;
 
    procedure Append (Val : Table_Component_Type) is
    begin
-      Increment_Last;
-      Table (Last) := Val;
+      Dyn_Table.Append (T, Val);
    end Append;
 
 begin
diff --git a/src/tables.ads b/src/tables.ads
index 0b1026646..b7a4b0344 100644
--- a/src/tables.ads
+++ b/src/tables.ads
@@ -20,6 +20,8 @@
 --  - the index type can be any discrete type (in particular a modular type)
 --  - the increment is not used
 --  - the interface is simplified.
+with Dyn_Tables;
+
 generic
    --  This package creates:
    --    array (Table_Index_Type range Table_Low_Bound .. <>)
@@ -35,23 +37,18 @@ generic
    --  Initial number of elements.
    Table_Initial   : Positive;
 package Tables is
-   --  Ada type for the array.
-   type Table_Type is
-     array (Table_Index_Type range <>) of Table_Component_Type;
-   --  Fat subtype (so that the access is thin).
-   subtype Big_Table_Type is
-     Table_Type (Table_Low_Bound .. Table_Index_Type'Last);
+   package Dyn_Table is new Dyn_Tables (Table_Component_Type,
+                                        Table_Index_Type,
+                                        Table_Low_Bound,
+                                        Table_Initial);
+
+   T : Dyn_Table.Instance;
 
-   --  Access type for the vector.  This is a thin pointer so that it is
-   --  compatible with C pointer, as this package uses malloc/realloc/free for
-   --  memory management.
-   type Table_Thin_Ptr is access all Big_Table_Type;
-   pragma Convention (C, Table_Thin_Ptr);
-   for Table_Thin_Ptr'Storage_Size use 0;
+   subtype Table_Type is Dyn_Table.Table_Type;
 
    --  Pointer to the table.  Note that the use of a thin pointer to the
    --  largest array, this implementation bypasses Ada index checks.
-   Table : Table_Thin_Ptr := null;
+   Table : Dyn_Table.Table_Thin_Ptr renames T.Table;
 
    --  Initialize the table.  This is done automatically at elaboration.
    procedure Init;
@@ -84,4 +81,5 @@ package Tables is
    --  Increase by NUM the length of the array, and returns the old value
    --  of Last + 1.
    function Allocate (Num : Natural := 1) return Table_Index_Type;
+   pragma Inline (Allocate);
 end Tables;