flists is now a generic package, add vhdl-flists

1 files changed, 160 insertions, 0 deletions

diff --git a/src/flists.adb b/src/flists.adb
new file mode 100644
index 000000000..9759163bb
--- /dev/null
+++ b/src/flists.adb
@@ -0,0 +1,160 @@
+--  Fixed-length lists.
+--  Copyright (C) 2017 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 Tables;
+
+package body Flists is
+   --  Index of elements.
+   type El_Index_Type is new Int32;
+
+   --  Describe an flist.
+   type Entry_Type is record
+      --  Index of the first element (in the element table).
+      Els : El_Index_Type;
+
+      --  Length of the list.
+      Len : Nat32;
+   end record;
+
+   --  Flists descriptors.
+   package Flistt is new Tables
+     (Table_Component_Type => Entry_Type,
+      Table_Index_Type => Flist_Type,
+      Table_Low_Bound => 4,
+      Table_Initial => 32);
+
+   --  Table of all elements.
+   package Els is new Tables
+     (Table_Component_Type => El_Type,
+      Table_Index_Type => El_Index_Type,
+      Table_Low_Bound => 0,
+      Table_Initial => 128);
+
+   type Flist_Array is array (Natural range <>) of Flist_Type;
+
+   --  Linked list of free flist.  For length less than the last index, the
+   --  index corresponds to the length.  All free lists whose length is equal
+   --  or greater than the last index are grouped to the last index.
+   Free_Flists : Flist_Array (0 .. 16) := (others => Null_Flist);
+
+   --  Get the chain for a free flist for large length.  It is stored at the
+   --  first element of the list.
+   function Free_Next (Flist : Flist_Type) return Flist_Type is
+   begin
+      return Flist_Type (Els.Table (Flistt.Table (Flist).Els));
+   end Free_Next;
+
+   function Create_Flist (Len : Natural) return Flist_Type
+   is
+      Res : Flist_Type;
+      Prev : Flist_Type;
+      Next : Flist_Type;
+   begin
+      if Len >= Free_Flists'Last then
+         --  Large length.
+         Res := Free_Flists (Free_Flists'Last);
+         Prev := Null_Flist;
+         while Res /= Null_Flist and then Length (Res) /= Len loop
+            Prev := Res;
+            Res := Free_Next (Res);
+         end loop;
+         if Res /= Null_Flist then
+            Next := Free_Next (Res);
+            if Prev = Null_Flist then
+               Free_Flists (Free_Flists'Last) := Next;
+            else
+               Els.Table (Flistt.Table (Prev).Els) := El_Type (Next);
+            end if;
+         end if;
+      else
+         --  Small length.  The Len field contains the next free list.
+         Res := Free_Flists (Len);
+         if Res /= Null_Flist then
+            Free_Flists (Len) := Flist_Type (Flistt.Table (Res).Len);
+            Flistt.Table (Res).Len := Nat32 (Len);
+         elsif Len = 0 then
+            --  Quick case for len = 0.
+            Res := Flistt.Allocate (1);
+            Flistt.Table (Res) := (Els => 0, Len => 0);
+            return Res;
+         end if;
+      end if;
+
+      if Res = Null_Flist then
+         Res := Flistt.Allocate (1);
+         Flistt.Table (Res) := (Els => Els.Allocate (Len),
+                                Len => Nat32 (Len));
+      end if;
+
+      --  Clear the list.
+      declare
+         Idx : constant El_Index_Type := Flistt.Table (Res).Els;
+      begin
+         Els.Table (Idx .. Idx + El_Index_Type (Len) - 1) := (others => 0);
+      end;
+
+      return Res;
+   end Create_Flist;
+
+   procedure Destroy_Flist (Flist : in out Flist_Type)
+   is
+      Len : constant Natural := Length (Flist);
+      Prev : Flist_Type;
+   begin
+      --  Prepend to the array of free flists.
+      if Len >= Free_Flists'Last then
+         Prev := Free_Flists (Free_Flists'Last);
+         Free_Flists (Free_Flists'Last) := Flist;
+
+         Els.Table (Flistt.Table (Flist).Els) := El_Type (Prev);
+      else
+         Prev := Free_Flists (Len);
+         Free_Flists (Len) := Flist;
+
+         Flistt.Table (Flist).Len := Nat32 (Prev);
+      end if;
+
+      Flist := Null_Flist;
+   end Destroy_Flist;
+
+   function Flast (Flist : Flist_Type) return Integer is
+   begin
+      return Integer (Flistt.Table (Flist).Len - 1);
+   end Flast;
+
+   function Length (Flist : Flist_Type) return Natural is
+   begin
+      return Natural (Flistt.Table (Flist).Len);
+   end Length;
+
+   function Get_Nth_Element (Flist : Flist_Type; N : Natural) return El_Type
+   is
+      E : Entry_Type renames Flistt.Table (Flist);
+   begin
+      pragma Assert (N < Natural (E.Len));
+      return Els.Table (E.Els + El_Index_Type (N));
+   end Get_Nth_Element;
+
+   procedure Set_Nth_Element (Flist : Flist_Type; N : Natural; V : El_Type)
+   is
+      E : Entry_Type renames Flistt.Table (Flist);
+   begin
+      pragma Assert (N < Natural (E.Len));
+      Els.Table (E.Els + El_Index_Type (N)) := V;
+   end Set_Nth_Element;
+end Flists;