vhdl: add hook on free_node, automatically free

7 files changed, 112 insertions, 29 deletions

diff --git a/src/vhdl/vhdl-elocations.adb b/src/vhdl/vhdl-elocations.adb
index 0ba3d0b0e..8bc68245c 100644
--- a/src/vhdl/vhdl-elocations.adb
+++ b/src/vhdl/vhdl-elocations.adb
@@ -130,14 +130,31 @@ package body Vhdl.Elocations is
       Elocations_Table.Table (Idx .. Idx + Len - 1) := (others => No_Location);
    end Create_Elocations;
 
-   procedure Delete_Elocations (N : Iir) is
+   procedure Delete_Elocations (N : Iir)
+   is
+      use Vhdl.Nodes_Priv;
+      Old : Location_Index_Type;
    begin
+      --  Cannot delete an already deleted location.
+      if N > Elocations_Index_Table.Last then
+         return;
+      end if;
+      Old := Elocations_Index_Table.Table (N);
+      if Old = No_Location_Index then
+         return;
+      end if;
+
       --  Clear the corresponding index.
       Elocations_Index_Table.Table (N) := No_Location_Index;
 
       --  FIXME: keep free slots in chained list ?
    end Delete_Elocations;
 
+   procedure Free_Hook (N : Iir) is
+   begin
+      Delete_Elocations (N);
+   end Free_Hook;
+
    generic
       Off : Location_Index_Type;
    function Get_FieldX (N : Iir) return Location_Type;
@@ -707,4 +724,7 @@ package body Vhdl.Elocations is
       Set_Field3 (N, Loc);
    end Set_Assign_Location;
 
+
+begin
+   Vhdl.Nodes.Register_Free_Hook (Free_Hook'Access);
 end Vhdl.Elocations;
diff --git a/src/vhdl/vhdl-elocations.adb.in b/src/vhdl/vhdl-elocations.adb.in
index 80fab21ce..164fdb00c 100644
--- a/src/vhdl/vhdl-elocations.adb.in
+++ b/src/vhdl/vhdl-elocations.adb.in
@@ -130,14 +130,31 @@ package body Vhdl.Elocations is
       Elocations_Table.Table (Idx .. Idx + Len - 1) := (others => No_Location);
    end Create_Elocations;
 
-   procedure Delete_Elocations (N : Iir) is
+   procedure Delete_Elocations (N : Iir)
+   is
+      use Vhdl.Nodes_Priv;
+      Old : Location_Index_Type;
    begin
+      --  Cannot delete an already deleted location.
+      if N > Elocations_Index_Table.Last then
+         return;
+      end if;
+      Old := Elocations_Index_Table.Table (N);
+      if Old = No_Location_Index then
+         return;
+      end if;
+
       --  Clear the corresponding index.
       Elocations_Index_Table.Table (N) := No_Location_Index;
 
       --  FIXME: keep free slots in chained list ?
    end Delete_Elocations;
 
+   procedure Free_Hook (N : Iir) is
+   begin
+      Delete_Elocations (N);
+   end Free_Hook;
+
    generic
       Off : Location_Index_Type;
    function Get_FieldX (N : Iir) return Location_Type;
@@ -185,4 +202,7 @@ package body Vhdl.Elocations is
    procedure Set_Field6 is new Set_FieldX (6);
 
    --  Subprograms
+
+begin
+   Vhdl.Nodes.Register_Free_Hook (Free_Hook'Access);
 end Vhdl.Elocations;
diff --git a/src/vhdl/vhdl-elocations.ads b/src/vhdl/vhdl-elocations.ads
index 14c33999f..fa895e111 100644
--- a/src/vhdl/vhdl-elocations.ads
+++ b/src/vhdl/vhdl-elocations.ads
@@ -631,10 +631,6 @@ package Vhdl.Elocations is
    --  Allocate memory to store elocations for node N.  Must be called once.
    procedure Create_Elocations (N : Iir);
 
-   --  Delete locations.  Memory is not yet reclaimed (but doesn't happen
-   --  frequently).
-   procedure Delete_Elocations (N : Iir);
-
    -- General methods.
 
    --  Field: Field1
diff --git a/src/vhdl/vhdl-nodes.adb b/src/vhdl/vhdl-nodes.adb
index 71f1eb722..7a532c113 100644
--- a/src/vhdl/vhdl-nodes.adb
+++ b/src/vhdl/vhdl-nodes.adb
@@ -355,17 +355,40 @@ package body Vhdl.Nodes is
       return Res;
    end Create_Node;
 
-   procedure Free_Node (N : Node_Type)
-   is
+   type Free_Node_Hook_Array is
+     array (Natural range 1 .. 8) of Free_Iir_Hook;
+   Nbr_Free_Hooks : Natural := 0;
+
+   Free_Hooks : Free_Node_Hook_Array;
+
+   procedure Register_Free_Hook (Hook : Free_Iir_Hook) is
    begin
-      if N /= Null_Node then
-         Set_Nkind (N, 0);
-         Set_Field1 (N, Free_Chain);
-         Free_Chain := N;
-         if Nodet.Table (N).Format = Format_Medium then
-            Set_Field1 (N + 1, Free_Chain);
-            Free_Chain := N + 1;
-         end if;
+      if Nbr_Free_Hooks >= Free_Hooks'Last then
+         --  Not enough room in Free_Hooks.
+         raise Internal_Error;
+      end if;
+      Nbr_Free_Hooks := Nbr_Free_Hooks + 1;
+      Free_Hooks (Nbr_Free_Hooks) := Hook;
+   end Register_Free_Hook;
+
+   procedure Free_Node (N : Node_Type) is
+   begin
+      if N = Null_Node then
+         return;
+      end if;
+
+      --  Call hooks.
+      for I in Free_Hooks'First .. Nbr_Free_Hooks loop
+         Free_Hooks (I).all (N);
+      end loop;
+
+      --  Really free the node.
+      Set_Nkind (N, 0);
+      Set_Field1 (N, Free_Chain);
+      Free_Chain := N;
+      if Nodet.Table (N).Format = Format_Medium then
+         Set_Field1 (N + 1, Free_Chain);
+         Free_Chain := N + 1;
       end if;
    end Free_Node;
 
diff --git a/src/vhdl/vhdl-nodes.adb.in b/src/vhdl/vhdl-nodes.adb.in
index 761676b3b..b19174d3f 100644
--- a/src/vhdl/vhdl-nodes.adb.in
+++ b/src/vhdl/vhdl-nodes.adb.in
@@ -355,17 +355,40 @@ package body Vhdl.Nodes is
       return Res;
    end Create_Node;
 
-   procedure Free_Node (N : Node_Type)
-   is
+   type Free_Node_Hook_Array is
+     array (Natural range 1 .. 8) of Free_Iir_Hook;
+   Nbr_Free_Hooks : Natural := 0;
+
+   Free_Hooks : Free_Node_Hook_Array;
+
+   procedure Register_Free_Hook (Hook : Free_Iir_Hook) is
    begin
-      if N /= Null_Node then
-         Set_Nkind (N, 0);
-         Set_Field1 (N, Free_Chain);
-         Free_Chain := N;
-         if Nodet.Table (N).Format = Format_Medium then
-            Set_Field1 (N + 1, Free_Chain);
-            Free_Chain := N + 1;
-         end if;
+      if Nbr_Free_Hooks >= Free_Hooks'Last then
+         --  Not enough room in Free_Hooks.
+         raise Internal_Error;
+      end if;
+      Nbr_Free_Hooks := Nbr_Free_Hooks + 1;
+      Free_Hooks (Nbr_Free_Hooks) := Hook;
+   end Register_Free_Hook;
+
+   procedure Free_Node (N : Node_Type) is
+   begin
+      if N = Null_Node then
+         return;
+      end if;
+
+      --  Call hooks.
+      for I in Free_Hooks'First .. Nbr_Free_Hooks loop
+         Free_Hooks (I).all (N);
+      end loop;
+
+      --  Really free the node.
+      Set_Nkind (N, 0);
+      Set_Field1 (N, Free_Chain);
+      Free_Chain := N;
+      if Nodet.Table (N).Format = Format_Medium then
+         Set_Field1 (N + 1, Free_Chain);
+         Free_Chain := N + 1;
       end if;
    end Free_Node;
 
diff --git a/src/vhdl/vhdl-nodes.ads b/src/vhdl/vhdl-nodes.ads
index 51a147921..d3efa1814 100644
--- a/src/vhdl/vhdl-nodes.ads
+++ b/src/vhdl/vhdl-nodes.ads
@@ -5871,6 +5871,10 @@ package Vhdl.Nodes is
    function Create_Iir_Error return Iir;
    procedure Free_Iir (Target : Iir);
 
+   --  Hooks called when a node is free.
+   type Free_Iir_Hook is access procedure (N : Iir);
+   procedure Register_Free_Hook (Hook : Free_Iir_Hook);
+
    --  Free all and reinit.
    procedure Initialize;
 
diff --git a/src/vhdl/vhdl-parse.adb b/src/vhdl/vhdl-parse.adb
index f111d6cf8..cbf979fb9 100644
--- a/src/vhdl/vhdl-parse.adb
+++ b/src/vhdl/vhdl-parse.adb
@@ -1620,9 +1620,6 @@ package body Vhdl.Parse is
                Last := N_Interface;
 
                Inter := Get_Chain (O_Interface);
-               if Flag_Elocations then
-                  Delete_Elocations (O_Interface);
-               end if;
                Free_Iir (O_Interface);
                O_Interface := Inter;
             end loop;