elocations: add more 'is' locations.

6 files changed, 138 insertions, 44 deletions

diff --git a/src/vhdl/elocations.adb b/src/vhdl/elocations.adb
index 6ee8d0c2f..b4466d42a 100644
--- a/src/vhdl/elocations.adb
+++ b/src/vhdl/elocations.adb
@@ -29,7 +29,9 @@ package body Elocations is
       Format_L1,
       Format_L2,
       Format_L3,
-      Format_L5
+      Format_L4,
+      Format_L5,
+      Format_L6
      );
 
    -- Common fields are:
@@ -48,6 +50,12 @@ package body Elocations is
    --   Field2 : Location_Type
    --   Field3 : Location_Type
 
+   -- Fields of Format_L4:
+   --   Field1 : Location_Type
+   --   Field2 : Location_Type
+   --   Field3 : Location_Type
+   --   Field4 : Location_Type
+
    -- Fields of Format_L5:
    --   Field1 : Location_Type
    --   Field2 : Location_Type
@@ -55,6 +63,14 @@ package body Elocations is
    --   Field4 : Location_Type
    --   Field5 : Location_Type
 
+   -- Fields of Format_L6:
+   --   Field1 : Location_Type
+   --   Field2 : Location_Type
+   --   Field3 : Location_Type
+   --   Field4 : Location_Type
+   --   Field5 : Location_Type
+   --   Field6 : Location_Type
+
    function Get_Format (Kind : Iir_Kind) return Format_Type;
 
    type Location_Index_Type is new Types.Nat32;
@@ -100,8 +116,12 @@ package body Elocations is
             Len := 2;
          when Format_L3 =>
             Len := 3;
+         when Format_L4 =>
+            Len := 4;
          when Format_L5 =>
             Len := 5;
+         when Format_L6 =>
+            Len := 6;
       end case;
 
       Idx := Elocations_Table.Last + 1;
@@ -153,6 +173,9 @@ package body Elocations is
    function Get_Field5 is new Get_FieldX (5);
    procedure Set_Field5 is new Set_FieldX (5);
 
+   function Get_Field6 is new Get_FieldX (6);
+   procedure Set_Field6 is new Set_FieldX (6);
+
    --  Subprograms
    function Get_Format (Kind : Iir_Kind) return Format_Type is
    begin
@@ -401,8 +424,6 @@ package body Elocations is
          when Iir_Kind_Protected_Type_Declaration
            | Iir_Kind_Record_Type_Definition
            | Iir_Kind_Protected_Type_Body
-           | Iir_Kind_Type_Declaration
-           | Iir_Kind_Subtype_Declaration
            | Iir_Kind_Configuration_Declaration
            | Iir_Kind_Context_Declaration
            | Iir_Kind_Package_Declaration
@@ -410,12 +431,6 @@ package body Elocations is
            | Iir_Kind_Case_Statement =>
             return Format_L2;
          when Iir_Kind_Package_Instantiation_Declaration
-           | Iir_Kind_Architecture_Body
-           | Iir_Kind_Function_Body
-           | Iir_Kind_Procedure_Body
-           | Iir_Kind_Sensitized_Process_Statement
-           | Iir_Kind_Process_Statement
-           | Iir_Kind_Block_Statement
            | Iir_Kind_If_Generate_Statement
            | Iir_Kind_For_Generate_Statement
            | Iir_Kind_Component_Instantiation_Statement
@@ -426,11 +441,21 @@ package body Elocations is
            | Iir_Kind_If_Statement
            | Iir_Kind_Elsif =>
             return Format_L3;
+         when Iir_Kind_Type_Declaration
+           | Iir_Kind_Subtype_Declaration
+           | Iir_Kind_Architecture_Body
+           | Iir_Kind_Function_Body
+           | Iir_Kind_Procedure_Body
+           | Iir_Kind_Sensitized_Process_Statement
+           | Iir_Kind_Process_Statement
+           | Iir_Kind_Block_Statement =>
+            return Format_L4;
+         when Iir_Kind_Package_Header =>
+            return Format_L5;
          when Iir_Kind_Block_Header
            | Iir_Kind_Entity_Declaration
-           | Iir_Kind_Package_Header
            | Iir_Kind_Component_Declaration =>
-            return Format_L5;
+            return Format_L6;
       end case;
    end Get_Format;
 
@@ -487,7 +512,7 @@ package body Elocations is
       pragma Assert (N /= Null_Iir);
       pragma Assert (Has_Is_Location (Get_Kind (N)),
                      "no field Is_Location");
-      return Get_Field2 (N);
+      return Get_Field4 (N);
    end Get_Is_Location;
 
    procedure Set_Is_Location (N : Iir; Loc : Location_Type) is
@@ -495,7 +520,7 @@ package body Elocations is
       pragma Assert (N /= Null_Iir);
       pragma Assert (Has_Is_Location (Get_Kind (N)),
                      "no field Is_Location");
-      Set_Field2 (N, Loc);
+      Set_Field4 (N, Loc);
    end Set_Is_Location;
 
    function Get_Begin_Location (N : Iir) return Location_Type is
@@ -567,7 +592,7 @@ package body Elocations is
       pragma Assert (N /= Null_Iir);
       pragma Assert (Has_Generic_Location (Get_Kind (N)),
                      "no field Generic_Location");
-      return Get_Field4 (N);
+      return Get_Field5 (N);
    end Get_Generic_Location;
 
    procedure Set_Generic_Location (N : Iir; Loc : Location_Type) is
@@ -575,7 +600,7 @@ package body Elocations is
       pragma Assert (N /= Null_Iir);
       pragma Assert (Has_Generic_Location (Get_Kind (N)),
                      "no field Generic_Location");
-      Set_Field4 (N, Loc);
+      Set_Field5 (N, Loc);
    end Set_Generic_Location;
 
    function Get_Port_Location (N : Iir) return Location_Type is
@@ -583,7 +608,7 @@ package body Elocations is
       pragma Assert (N /= Null_Iir);
       pragma Assert (Has_Port_Location (Get_Kind (N)),
                      "no field Port_Location");
-      return Get_Field5 (N);
+      return Get_Field6 (N);
    end Get_Port_Location;
 
    procedure Set_Port_Location (N : Iir; Loc : Location_Type) is
@@ -591,7 +616,7 @@ package body Elocations is
       pragma Assert (N /= Null_Iir);
       pragma Assert (Has_Port_Location (Get_Kind (N)),
                      "no field Port_Location");
-      Set_Field5 (N, Loc);
+      Set_Field6 (N, Loc);
    end Set_Port_Location;
 
    function Get_Generic_Map_Location (N : Iir) return Location_Type is
diff --git a/src/vhdl/elocations.adb.in b/src/vhdl/elocations.adb.in
index c4c8403b0..5b9ef84ba 100644
--- a/src/vhdl/elocations.adb.in
+++ b/src/vhdl/elocations.adb.in
@@ -29,7 +29,9 @@ package body Elocations is
       Format_L1,
       Format_L2,
       Format_L3,
-      Format_L5
+      Format_L4,
+      Format_L5,
+      Format_L6
      );
 
    -- Common fields are:
@@ -48,6 +50,12 @@ package body Elocations is
    --   Field2 : Location_Type
    --   Field3 : Location_Type
 
+   -- Fields of Format_L4:
+   --   Field1 : Location_Type
+   --   Field2 : Location_Type
+   --   Field3 : Location_Type
+   --   Field4 : Location_Type
+
    -- Fields of Format_L5:
    --   Field1 : Location_Type
    --   Field2 : Location_Type
@@ -55,6 +63,14 @@ package body Elocations is
    --   Field4 : Location_Type
    --   Field5 : Location_Type
 
+   -- Fields of Format_L6:
+   --   Field1 : Location_Type
+   --   Field2 : Location_Type
+   --   Field3 : Location_Type
+   --   Field4 : Location_Type
+   --   Field5 : Location_Type
+   --   Field6 : Location_Type
+
    function Get_Format (Kind : Iir_Kind) return Format_Type;
 
    type Location_Index_Type is new Types.Nat32;
@@ -100,8 +116,12 @@ package body Elocations is
             Len := 2;
          when Format_L3 =>
             Len := 3;
+         when Format_L4 =>
+            Len := 4;
          when Format_L5 =>
             Len := 5;
+         when Format_L6 =>
+            Len := 6;
       end case;
 
       Idx := Elocations_Table.Last + 1;
@@ -153,5 +173,8 @@ package body Elocations is
    function Get_Field5 is new Get_FieldX (5);
    procedure Set_Field5 is new Set_FieldX (5);
 
+   function Get_Field6 is new Get_FieldX (6);
+   procedure Set_Field6 is new Set_FieldX (6);
+
    --  Subprograms
 end Elocations;
diff --git a/src/vhdl/elocations.ads b/src/vhdl/elocations.ads
index b71944b5b..629d6707f 100644
--- a/src/vhdl/elocations.ads
+++ b/src/vhdl/elocations.ads
@@ -88,11 +88,11 @@ package Elocations is
 
    -- Iir_Kind_Disconnection_Specification (None)
 
-   -- Iir_Kind_Block_Header (L5)
+   -- Iir_Kind_Block_Header (L6)
    --
-   --   Get/Set_Generic_Location (Field4)
+   --   Get/Set_Generic_Location (Field5)
    --
-   --   Get/Set_Port_Location (Field5)
+   --   Get/Set_Port_Location (Field6)
    --
    --   Get/Set_Generic_Map_Location (Field3)
    --
@@ -116,24 +116,28 @@ package Elocations is
    --  Declarations --
    -------------------
 
-   -- Iir_Kind_Entity_Declaration (L5)
+   -- Iir_Kind_Entity_Declaration (L6)
    --
    --   Get/Set_Start_Location (Field1)
    --
    --   Get/Set_End_Location (Field2)
    --
-   --   Get/Set_Generic_Location (Field4)
+   --   Get/Set_Generic_Location (Field5)
    --
-   --   Get/Set_Port_Location (Field5)
+   --   Get/Set_Port_Location (Field6)
    --
    --   Get/Set_Begin_Location (Field3)
+   --
+   --   Get/Set_Is_Location (Field4)
 
-   -- Iir_Kind_Architecture_Body (L3)
+   -- Iir_Kind_Architecture_Body (L4)
    --   Get/Set_Start_Location (Field1)
    --
    --   Get/Set_End_Location (Field2)
    --
    --   Get/Set_Begin_Location (Field3)
+   --
+   --   Get/Set_Is_Location (Field4)
 
    -- Iir_Kind_Configuration_Declaration (L2)
    --   Get/Set_Start_Location (Field1)
@@ -142,7 +146,7 @@ package Elocations is
 
    -- Iir_Kind_Package_Header (L5)
    --
-   --   Get/Set_Generic_Location (Field4)
+   --   Get/Set_Generic_Location (Field5)
    --
    --   Get/Set_Generic_Map_Location (Field3)
 
@@ -175,15 +179,15 @@ package Elocations is
 
    -- Iir_Kind_Library_Declaration (None)
 
-   -- Iir_Kind_Component_Declaration (L5)
+   -- Iir_Kind_Component_Declaration (L6)
    --
    --   Get/Set_Start_Location (Field1)
    --
    --   Get/Set_End_Location (Field2)
    --
-   --   Get/Set_Generic_Location (Field4)
+   --   Get/Set_Generic_Location (Field5)
    --
-   --   Get/Set_Port_Location (Field5)
+   --   Get/Set_Port_Location (Field6)
 
    -- Iir_Kind_Object_Alias_Declaration (L1)
    --
@@ -195,17 +199,17 @@ package Elocations is
    --
    --   Get/Set_Start_Location (Field1)
 
-   -- Iir_Kind_Type_Declaration (L2)
+   -- Iir_Kind_Type_Declaration (L4)
    --
    --   Get/Set_Start_Location (Field1)
    --
-   --   Get/Set_Is_Location (Field2)
+   --   Get/Set_Is_Location (Field4)
 
-   -- Iir_Kind_Subtype_Declaration (L2)
+   -- Iir_Kind_Subtype_Declaration (L4)
    --
    --   Get/Set_Start_Location (Field1)
    --
-   --   Get/Set_Is_Location (Field2)
+   --   Get/Set_Is_Location (Field4)
 
    -- Iir_Kind_Nature_Declaration (None)
 
@@ -231,14 +235,16 @@ package Elocations is
    --
    --   Get/Set_Start_Location (Field1)
 
-   -- Iir_Kind_Function_Body (L3)
-   -- Iir_Kind_Procedure_Body (L3)
+   -- Iir_Kind_Function_Body (L4)
+   -- Iir_Kind_Procedure_Body (L4)
    --
    --   Get/Set_Start_Location (Field1)
    --
    --   Get/Set_End_Location (Field2)
    --
    --   Get/Set_Begin_Location (Field3)
+   --
+   --   Get/Set_Is_Location (Field4)
 
    -- Iir_Kind_Interface_Function_Declaration (None)
    -- Iir_Kind_Interface_Procedure_Declaration (None)
@@ -377,14 +383,16 @@ package Elocations is
    --
    --   Get/Set_Start_Location (Field1)
 
-   -- Iir_Kind_Sensitized_Process_Statement (L3)
-   -- Iir_Kind_Process_Statement (L3)
+   -- Iir_Kind_Sensitized_Process_Statement (L4)
+   -- Iir_Kind_Process_Statement (L4)
    --
    --   Get/Set_Start_Location (Field1)
    --
    --   Get/Set_End_Location (Field2)
    --
    --   Get/Set_Begin_Location (Field3)
+   --
+   --   Get/Set_Is_Location (Field4)
 
    -- Iir_Kind_Concurrent_Assertion_Statement (None)
 
@@ -399,11 +407,13 @@ package Elocations is
    --
    --   Get/Set_Port_Map_Location (Field2)
 
-   -- Iir_Kind_Block_Statement (L3)
+   -- Iir_Kind_Block_Statement (L4)
    --
    --   Get/Set_End_Location (Field2)
    --
    --   Get/Set_Begin_Location (Field3)
+   --
+   --   Get/Set_Is_Location (Field4)
 
    -- Iir_Kind_Generate_Statement_Body (L3)
    --
@@ -631,7 +641,7 @@ package Elocations is
    function Get_End_Location (N : Iir) return Location_Type;
    procedure Set_End_Location (N : Iir; Loc : Location_Type);
 
-   --  Field: Field2
+   --  Field: Field4
    function Get_Is_Location (N : Iir) return Location_Type;
    procedure Set_Is_Location (N : Iir; Loc : Location_Type);
 
@@ -651,11 +661,11 @@ package Elocations is
    function Get_Generate_Location (N : Iir) return Location_Type;
    procedure Set_Generate_Location (N : Iir; Loc : Location_Type);
 
-   --  Field: Field4
+   --  Field: Field5
    function Get_Generic_Location (N : Iir) return Location_Type;
    procedure Set_Generic_Location (N : Iir; Loc : Location_Type);
 
-   --  Field: Field5
+   --  Field: Field6
    function Get_Port_Location (N : Iir) return Location_Type;
    procedure Set_Port_Location (N : Iir; Loc : Location_Type);
 
diff --git a/src/vhdl/elocations_meta.adb b/src/vhdl/elocations_meta.adb
index bcac6d39e..fdc808429 100644
--- a/src/vhdl/elocations_meta.adb
+++ b/src/vhdl/elocations_meta.adb
@@ -233,7 +233,14 @@ package body Elocations_Meta is
    begin
       case K is
          when Iir_Kind_Type_Declaration
-           | Iir_Kind_Subtype_Declaration =>
+           | Iir_Kind_Subtype_Declaration
+           | Iir_Kind_Entity_Declaration
+           | Iir_Kind_Architecture_Body
+           | Iir_Kind_Function_Body
+           | Iir_Kind_Procedure_Body
+           | Iir_Kind_Sensitized_Process_Statement
+           | Iir_Kind_Process_Statement
+           | Iir_Kind_Block_Statement =>
             return True;
          when others =>
             return False;
diff --git a/src/vhdl/iirs.ads b/src/vhdl/iirs.ads
index e8c4abe14..f7985f6d4 100644
--- a/src/vhdl/iirs.ads
+++ b/src/vhdl/iirs.ads
@@ -2914,6 +2914,16 @@ package Iirs is
    --   Get/Set_Has_Component (Flag5)
 
    -- Iir_Kind_Block_Statement (Medium)
+   --  LRM08 11.2 Block statement
+   --
+   --  block_statement ::=
+   --    block_label :
+   --      BLOCK [ ( guard_condition ) ] [ IS ]
+   --        block_header
+   --        block_declarative_part
+   --      BEGIN
+   --        block_statement_part
+   --      END BLOCK [ block_label ] ;
    --
    --   Get/Set_Parent (Field0)
    --
diff --git a/src/vhdl/parse.adb b/src/vhdl/parse.adb
index 24e62e0d3..5bae26b22 100644
--- a/src/vhdl/parse.adb
+++ b/src/vhdl/parse.adb
@@ -4626,9 +4626,12 @@ package body Parse is
       Parse_Declarative_Part (Res);
 
       if Current_Token = Tok_Begin then
+         Begin_Loc := Get_Token_Location;
          Set_Has_Begin (Res, True);
+
+         --  Skip 'begin'.
          Scan;
-         Begin_Loc := Get_Token_Location;
+
          Parse_Concurrent_Statements (Res);
       else
          Begin_Loc := No_Location;
@@ -4638,7 +4641,9 @@ package body Parse is
       Expect (Tok_End);
       End_Loc := Get_Token_Location;
 
+      --  Skip 'end'.
       Scan;
+
       if Current_Token = Tok_Entity then
          if Flags.Vhdl_Std = Vhdl_87 then
             Error_Msg_Parse ("'entity' keyword not allowed here by vhdl 87");
@@ -6787,7 +6792,7 @@ package body Parse is
       Kind : Iir_Kind;
       Subprg: Iir;
       Subprg_Body : Iir;
-      Start_Loc, Begin_Loc, End_Loc : Location_Type;
+      Start_Loc, Is_Loc, Begin_Loc, End_Loc : Location_Type;
    begin
       --  Create the node.
       Start_Loc := Get_Token_Location;
@@ -6863,6 +6868,7 @@ package body Parse is
       Set_Chain (Subprg, Subprg_Body);
 
       --  Skip 'is'.
+      Is_Loc := Get_Token_Location;
       Expect (Tok_Is);
       Scan;
 
@@ -6883,6 +6889,7 @@ package body Parse is
 
       if Flag_Elocations then
          Create_Elocations (Subprg_Body);
+         Set_Is_Location (Subprg_Body, Is_Loc);
          Set_Begin_Location (Subprg_Body, Begin_Loc);
          Set_End_Location (Subprg_Body, End_Loc);
       end if;
@@ -7497,6 +7504,10 @@ package body Parse is
       Set_Has_Label (Bod, Label /= Null_Identifier);
       End_Loc := No_Location;
 
+      if Flag_Elocations then
+         Create_Elocations (Bod);
+      end if;
+
       --  Check for a block declarative item.
       case Current_Token is
          when
@@ -7544,6 +7555,10 @@ package body Parse is
             Expect (Tok_Begin);
             Set_Has_Begin (Bod, True);
 
+            if Flag_Elocations then
+               Set_Begin_Location (Bod, Get_Token_Location);
+            end if;
+
             --  Skip 'begin'
             Scan;
          when others =>
@@ -7565,6 +7580,10 @@ package body Parse is
       if Vhdl_Std >= Vhdl_08 and then Current_Token /= Tok_Generate then
          --  This is the 'end' of the generate_statement_body.
          Set_Has_End (Bod, True);
+         if Flag_Elocations then
+            Set_End_Location (Bod, End_Loc);
+         end if;
+
          Check_End_Name (Label, Bod);
          Scan_Semi_Colon ("generate statement body");