Rework parse of object interface, add elocations.

6 files changed, 154 insertions, 30 deletions

diff --git a/src/vhdl/elocations.adb b/src/vhdl/elocations.adb
index b4466d42a..9ba4f8325 100644
--- a/src/vhdl/elocations.adb
+++ b/src/vhdl/elocations.adb
@@ -130,6 +130,14 @@ package body Elocations is
       Elocations_Table.Table (Idx .. Idx + Len - 1) := (others => No_Location);
    end Create_Elocations;
 
+   procedure Delete_Elocations (N : Iir) is
+   begin
+      --  Clear the corresponding index.
+      Elocations_Index_Table.Table (N) := No_Location_Index;
+
+      --  FIXME: keep free slots in chained list ?
+   end Delete_Elocations;
+
    generic
       Off : Location_Index_Type;
    function Get_FieldX (N : Iir) return Location_Type;
@@ -410,10 +418,6 @@ package body Elocations is
            | Iir_Kind_Variable_Declaration
            | Iir_Kind_Constant_Declaration
            | Iir_Kind_Iterator_Declaration
-           | Iir_Kind_Interface_Constant_Declaration
-           | Iir_Kind_Interface_Variable_Declaration
-           | Iir_Kind_Interface_Signal_Declaration
-           | Iir_Kind_Interface_File_Declaration
            | Iir_Kind_Interface_Type_Declaration
            | Iir_Kind_Interface_Package_Declaration
            | Iir_Kind_Parenthesis_Expression
@@ -431,6 +435,10 @@ package body Elocations is
            | Iir_Kind_Case_Statement =>
             return Format_L2;
          when Iir_Kind_Package_Instantiation_Declaration
+           | Iir_Kind_Interface_Constant_Declaration
+           | Iir_Kind_Interface_Variable_Declaration
+           | Iir_Kind_Interface_Signal_Declaration
+           | Iir_Kind_Interface_File_Declaration
            | Iir_Kind_If_Generate_Statement
            | Iir_Kind_For_Generate_Statement
            | Iir_Kind_Component_Instantiation_Statement
@@ -667,4 +675,36 @@ package body Elocations is
       Set_Field1 (N, Loc);
    end Set_Arrow_Location;
 
+   function Get_Colon_Location (N : Iir) return Location_Type is
+   begin
+      pragma Assert (N /= Null_Iir);
+      pragma Assert (Has_Colon_Location (Get_Kind (N)),
+                     "no field Colon_Location");
+      return Get_Field2 (N);
+   end Get_Colon_Location;
+
+   procedure Set_Colon_Location (N : Iir; Loc : Location_Type) is
+   begin
+      pragma Assert (N /= Null_Iir);
+      pragma Assert (Has_Colon_Location (Get_Kind (N)),
+                     "no field Colon_Location");
+      Set_Field2 (N, Loc);
+   end Set_Colon_Location;
+
+   function Get_Assign_Location (N : Iir) return Location_Type is
+   begin
+      pragma Assert (N /= Null_Iir);
+      pragma Assert (Has_Assign_Location (Get_Kind (N)),
+                     "no field Assign_Location");
+      return Get_Field3 (N);
+   end Get_Assign_Location;
+
+   procedure Set_Assign_Location (N : Iir; Loc : Location_Type) is
+   begin
+      pragma Assert (N /= Null_Iir);
+      pragma Assert (Has_Assign_Location (Get_Kind (N)),
+                     "no field Assign_Location");
+      Set_Field3 (N, Loc);
+   end Set_Assign_Location;
+
 end Elocations;
diff --git a/src/vhdl/elocations.adb.in b/src/vhdl/elocations.adb.in
index 5b9ef84ba..95a73dd54 100644
--- a/src/vhdl/elocations.adb.in
+++ b/src/vhdl/elocations.adb.in
@@ -130,6 +130,14 @@ package body Elocations is
       Elocations_Table.Table (Idx .. Idx + Len - 1) := (others => No_Location);
    end Create_Elocations;
 
+   procedure Delete_Elocations (N : Iir) is
+   begin
+      --  Clear the corresponding index.
+      Elocations_Index_Table.Table (N) := No_Location_Index;
+
+      --  FIXME: keep free slots in chained list ?
+   end Delete_Elocations;
+
    generic
       Off : Location_Index_Type;
    function Get_FieldX (N : Iir) return Location_Type;
diff --git a/src/vhdl/elocations.ads b/src/vhdl/elocations.ads
index 629d6707f..82450debd 100644
--- a/src/vhdl/elocations.ads
+++ b/src/vhdl/elocations.ads
@@ -215,12 +215,16 @@ package Elocations is
 
    -- Iir_Kind_Subnature_Declaration (None)
 
-   -- Iir_Kind_Interface_Signal_Declaration (L1)
-   -- Iir_Kind_Interface_Constant_Declaration (L1)
-   -- Iir_Kind_Interface_Variable_Declaration (L1)
-   -- Iir_Kind_Interface_File_Declaration (L1)
+   -- Iir_Kind_Interface_Signal_Declaration (L3)
+   -- Iir_Kind_Interface_Constant_Declaration (L3)
+   -- Iir_Kind_Interface_Variable_Declaration (L3)
+   -- Iir_Kind_Interface_File_Declaration (L3)
    --
    --   Get/Set_Start_Location (Field1)
+   --
+   --   Get/Set_Colon_Location (Field2)
+   --
+   --   Get/Set_Assign_Location (Field3)
 
    -- Iir_Kind_Interface_Type_Declaration (L1)
    --
@@ -627,6 +631,10 @@ package 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
@@ -680,4 +688,12 @@ package Elocations is
    --  Field: Field1
    function Get_Arrow_Location (N : Iir) return Location_Type;
    procedure Set_Arrow_Location (N : Iir; Loc : Location_Type);
+
+   --  Field: Field2
+   function Get_Colon_Location (N : Iir) return Location_Type;
+   procedure Set_Colon_Location (N : Iir; Loc : Location_Type);
+
+   --  Field: Field3
+   function Get_Assign_Location (N : Iir) return Location_Type;
+   procedure Set_Assign_Location (N : Iir; Loc : Location_Type);
 end Elocations;
diff --git a/src/vhdl/elocations_meta.adb b/src/vhdl/elocations_meta.adb
index fdc808429..1d66236a5 100644
--- a/src/vhdl/elocations_meta.adb
+++ b/src/vhdl/elocations_meta.adb
@@ -48,6 +48,10 @@ package body Elocations_Meta is
             return "port_map_location";
          when Field_Arrow_Location =>
             return "arrow_location";
+         when Field_Colon_Location =>
+            return "colon_location";
+         when Field_Assign_Location =>
+            return "assign_location";
       end case;
    end Get_Field_Image;
 
@@ -93,6 +97,10 @@ package body Elocations_Meta is
             return Get_Port_Map_Location (N);
          when Field_Arrow_Location =>
             return Get_Arrow_Location (N);
+         when Field_Colon_Location =>
+            return Get_Colon_Location (N);
+         when Field_Assign_Location =>
+            return Get_Assign_Location (N);
          when others =>
             raise Internal_Error;
       end case;
@@ -129,6 +137,10 @@ package body Elocations_Meta is
             Set_Port_Map_Location (N, V);
          when Field_Arrow_Location =>
             Set_Arrow_Location (N, V);
+         when Field_Colon_Location =>
+            Set_Colon_Location (N, V);
+         when Field_Assign_Location =>
+            Set_Assign_Location (N, V);
          when others =>
             raise Internal_Error;
       end case;
@@ -362,6 +374,32 @@ package body Elocations_Meta is
       end case;
    end Has_Arrow_Location;
 
+   function Has_Colon_Location (K : Iir_Kind) return Boolean is
+   begin
+      case K is
+         when Iir_Kind_Interface_Constant_Declaration
+           | Iir_Kind_Interface_Variable_Declaration
+           | Iir_Kind_Interface_Signal_Declaration
+           | Iir_Kind_Interface_File_Declaration =>
+            return True;
+         when others =>
+            return False;
+      end case;
+   end Has_Colon_Location;
+
+   function Has_Assign_Location (K : Iir_Kind) return Boolean is
+   begin
+      case K is
+         when Iir_Kind_Interface_Constant_Declaration
+           | Iir_Kind_Interface_Variable_Declaration
+           | Iir_Kind_Interface_Signal_Declaration
+           | Iir_Kind_Interface_File_Declaration =>
+            return True;
+         when others =>
+            return False;
+      end case;
+   end Has_Assign_Location;
+
 
    pragma Warnings (On, """others"" choice is redundant");
 end Elocations_Meta;
diff --git a/src/vhdl/elocations_meta.ads b/src/vhdl/elocations_meta.ads
index c2e968248..549951408 100644
--- a/src/vhdl/elocations_meta.ads
+++ b/src/vhdl/elocations_meta.ads
@@ -35,7 +35,9 @@ package Elocations_Meta is
       Field_Port_Location,
       Field_Generic_Map_Location,
       Field_Port_Map_Location,
-      Field_Arrow_Location
+      Field_Arrow_Location,
+      Field_Colon_Location,
+      Field_Assign_Location
      );
    pragma Discard_Names (Fields_Enum);
 
@@ -62,4 +64,6 @@ package Elocations_Meta is
    function Has_Generic_Map_Location (K : Iir_Kind) return Boolean;
    function Has_Port_Map_Location (K : Iir_Kind) return Boolean;
    function Has_Arrow_Location (K : Iir_Kind) return Boolean;
+   function Has_Colon_Location (K : Iir_Kind) return Boolean;
+   function Has_Assign_Location (K : Iir_Kind) return Boolean;
 end Elocations_Meta;
diff --git a/src/vhdl/parse.adb b/src/vhdl/parse.adb
index 5bae26b22..87f65b003 100644
--- a/src/vhdl/parse.adb
+++ b/src/vhdl/parse.adb
@@ -1134,8 +1134,8 @@ package body Parse is
                                                return Iir
    is
       Kind : Iir_Kind;
-      Res, Last : Iir;
-      First, Prev_First : Iir;
+      Last : Iir;
+      First : Iir;
       Inter: Iir;
       Is_Default : Boolean;
       Interface_Mode: Iir_Mode;
@@ -1146,9 +1146,6 @@ package body Parse is
       Has_Mode : Boolean;
       Has_Class : Boolean;
    begin
-      Res := Null_Iir;
-      Last := Null_Iir;
-
       --  LRM08 6.5.2 Interface object declarations
       --  Interface obejcts include interface constants that appear as
       --  generics of a design entity, a component, a block, a package or
@@ -1198,7 +1195,12 @@ package body Parse is
             Kind := Iir_Kind_Interface_Variable_Declaration;
       end case;
 
-      Inter := Create_Iir (Kind);
+      First := Create_Iir (Kind);
+
+      if Flag_Elocations then
+         Create_Elocations (First);
+         Set_Start_Location (First, Get_Token_Location);
+      end if;
 
       if Current_Token = Tok_Identifier then
          Is_Default := True;
@@ -1211,8 +1213,8 @@ package body Parse is
          Scan;
       end if;
 
-      Prev_First := Last;
-      First := Inter;
+      Inter := First;
+      Last := First;
       loop
          if Current_Token /= Tok_Identifier then
             Expect (Tok_Identifier);
@@ -1220,13 +1222,6 @@ package body Parse is
          Set_Identifier (Inter, Current_Identifier);
          Set_Location (Inter);
 
-         if Res = Null_Iir then
-            Res := Inter;
-         else
-            Set_Chain (Last, Inter);
-         end if;
-         Last := Inter;
-
          --  Skip identifier
          Scan;
 
@@ -1237,11 +1232,22 @@ package body Parse is
          Scan;
 
          Inter := Create_Iir (Kind);
+
+         if Flag_Elocations then
+            Create_Elocations (Inter);
+            Set_Start_Location (Inter, Get_Start_Location (First));
+         end if;
+
+         Set_Chain (Last, Inter);
+         Last := Inter;
       end loop;
 
       Expect (Tok_Colon, "':' must follow the interface element identifier");
 
       --  Skip ':'
+      if Flag_Elocations then
+         Set_Colon_Location (First, Get_Token_Location);
+      end if;
       Scan;
 
       --  Parse mode.
@@ -1277,17 +1283,26 @@ package body Parse is
                Location_Copy (N_Interface, O_Interface);
                Set_Identifier (N_Interface,
                                Get_Identifier (O_Interface));
-               if Prev_First = Null_Iir then
-                  Res := N_Interface;
-               else
-                  Set_Chain (Prev_First, N_Interface);
+
+               if Flag_Elocations then
+                  Create_Elocations (N_Interface);
+                  Set_Start_Location
+                    (N_Interface, Get_Start_Location (O_Interface));
+                  Set_Colon_Location
+                    (N_Interface, Get_Colon_Location (O_Interface));
                end if;
-               Prev_First := N_Interface;
+
                if O_Interface = First then
                   First := N_Interface;
+               else
+                  Set_Chain (Last, N_Interface);
                end if;
                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;
@@ -1338,6 +1353,9 @@ package body Parse is
          end if;
 
          --  Skip ':='
+         if Flag_Elocations then
+            Set_Assign_Location (First, Get_Token_Location);
+         end if;
          Scan;
 
          Default_Value := Parse_Expression;
@@ -1366,7 +1384,7 @@ package body Parse is
          Inter := Get_Chain (Inter);
       end loop;
 
-      return Res;
+      return First;
    end Parse_Interface_Object_Declaration;
 
    --  Precond : 'package'