Add a python script to automatically generate disp_tree.

1 files changed, 104 insertions, 30 deletions

diff --git a/sem_names.adb b/sem_names.adb
index 113a7cde3..17353cdef 100644
--- a/sem_names.adb
+++ b/sem_names.adb
@@ -73,16 +73,19 @@ package body Sem_Names is
 
    -- Create an overload list.
    -- must be destroyed with free_iir.
-   function Get_Overload_List return Iir_Overload_List is
+   function Get_Overload_List return Iir_Overload_List
+   is
+      Res : Iir;
    begin
-      return Create_Iir (Iir_Kind_Overload_List);
+      Res := Create_Iir (Iir_Kind_Overload_List);
+      return Res;
    end Get_Overload_List;
 
    function Create_Overload_List (List : Iir_List) return Iir_Overload_List
    is
       Res : Iir_Overload_List;
    begin
-      Res := Create_Iir (Iir_Kind_Overload_List);
+      Res := Get_Overload_List;
       Set_Overload_List (Res, List);
       return Res;
    end Create_Overload_List;
@@ -218,12 +221,16 @@ package body Sem_Names is
             when Iir_Kind_Function_Call
               | Iir_Kind_Indexed_Name
               | Iir_Kind_Selected_Element =>
-               --  FIXME: recursion ?
+               Sem_Name_Free (Get_Prefix (El));
+               Free_Iir (El);
+            when Iir_Kind_Attribute_Name =>
                Free_Iir (El);
             when Iir_Kinds_Function_Declaration
               | Iir_Kinds_Procedure_Declaration
               | Iir_Kind_Enumeration_Literal =>
                null;
+            when Iir_Kinds_Denoting_Name =>
+               null;
             when others =>
                Error_Kind ("sem_name_free", El);
          end case;
@@ -251,6 +258,20 @@ package body Sem_Names is
       end if;
    end Sem_Name_Free_Result;
 
+   procedure Free_Parenthesis_Name (Name : Iir; Res : Iir)
+   is
+      Chain, Next_Chain : Iir;
+   begin
+      pragma Assert (Get_Kind (Res) /= Iir_Kind_Function_Call);
+      Chain := Get_Association_Chain (Name);
+      while Chain /= Null_Iir loop
+         Next_Chain := Get_Chain (Chain);
+         Free_Iir (Chain);
+         Chain := Next_Chain;
+      end loop;
+      Free_Iir (Name);
+   end Free_Parenthesis_Name;
+
    --  Find all named declaration whose identifier is ID in DECL_LIST and
    --  return it.
    --  The result can be NULL (if no such declaration exist),
@@ -576,7 +597,6 @@ package body Sem_Names is
       Staticness : Iir_Staticness;
       Prefix_Rng : Iir;
    begin
-      --  Set a type to the prefix.
       Set_Base_Name (Name, Get_Base_Name (Prefix));
 
       --  LRM93 §6.5: the prefix of an indexed name must be appropriate
@@ -696,6 +716,7 @@ package body Sem_Names is
         (Expr_Type, Min (Get_Type_Staticness (Prefix_Type),
                          Get_Type_Staticness (Slice_Type)));
       Set_Type (Name, Expr_Type);
+      Set_Slice_Subtype (Name, Expr_Type);
       Set_Index_Constraint_Flag (Expr_Type, True);
       Set_Constraint_State (Expr_Type, Fully_Constrained);
       if Is_Signal_Object (Prefix) then
@@ -891,7 +912,8 @@ package body Sem_Names is
       Set_Expr_Staticness (Attr, Staticness);
    end Finish_Sem_Array_Attribute;
 
-   procedure Finish_Sem_Scalar_Type_Attribute (Attr : Iir; Param : Iir)
+   procedure Finish_Sem_Scalar_Type_Attribute
+     (Attr_Name : Iir; Attr : Iir; Param : Iir)
    is
       Prefix : Iir;
       Prefix_Type : Iir;
@@ -913,6 +935,7 @@ package body Sem_Names is
          Prefix := Sem_Type_Mark (Prefix);
       end if;
       Set_Prefix (Attr, Prefix);
+      Free_Iir (Attr_Name);
       Prefix_Type := Get_Type (Prefix);
       Prefix_Bt := Get_Base_Type (Prefix_Type);
 
@@ -978,6 +1001,7 @@ package body Sem_Names is
       Prefix_Name := Get_Prefix (Attr_Name);
       Prefix := Finish_Sem_Name (Prefix_Name, Get_Prefix (Attr));
       Set_Prefix (Attr, Prefix);
+      Free_Iir (Attr_Name);
 
       if Parameter = Null_Iir then
          return;
@@ -1074,6 +1098,7 @@ package body Sem_Names is
    function Sem_Type_Conversion (Loc : Iir; Type_Mark : Iir; Actual : Iir)
                                 return Iir
    is
+      Conv_Type : constant Iir := Get_Type (Type_Mark);
       Conv: Iir_Type_Conversion;
       Expr: Iir;
       Staticness : Iir_Staticness;
@@ -1081,7 +1106,7 @@ package body Sem_Names is
       Conv := Create_Iir (Iir_Kind_Type_Conversion);
       Location_Copy (Conv, Loc);
       Set_Type_Mark (Conv, Type_Mark);
-      Set_Type (Conv, Get_Type (Type_Mark));
+      Set_Type (Conv, Conv_Type);
       Set_Expression (Conv, Actual);
 
       --  Default staticness in case of error.
@@ -1128,12 +1153,25 @@ package body Sem_Names is
       --      expression.
       if Expr /= Null_Iir then
          Staticness := Get_Expr_Staticness (Expr);
+
+         --  If the type mark is not locally static, the expression cannot
+         --  be locally static.  This was clarified in VHDL 08, but a type
+         --  mark that denotes an unconstrained array type, does not prevent
+         --  the expression from being static.
+         if Get_Kind (Conv_Type) not in Iir_Kinds_Array_Type_Definition
+           or else Get_Constraint_State (Conv_Type) = Fully_Constrained
+         then
+            Staticness := Min (Staticness, Get_Type_Staticness (Conv_Type));
+         end if;
+
+         --  LRM87 7.4 Static Expressions
+         --  A type conversion is not a locally static expression.
          if Flags.Vhdl_Std = Vhdl_87 then
             Staticness := Min (Globally, Staticness);
          end if;
          Set_Expr_Staticness (Conv, Staticness);
 
-         if not Are_Types_Closely_Related (Get_Type (Conv), Get_Type (Expr))
+         if not Are_Types_Closely_Related (Conv_Type, Get_Type (Expr))
          then
             --  FIXME: should explain why the types are not closely related.
             Error_Msg_Sem
@@ -1380,7 +1418,7 @@ package body Sem_Names is
          when Iir_Kind_Type_Conversion =>
             pragma Assert (Get_Kind (Name) = Iir_Kind_Parenthesis_Name);
             Set_Type_Mark (Res, Sem_Type_Mark (Get_Prefix (Name)));
-            --  FIXME: free name
+            Free_Parenthesis_Name (Name, Res);
             return Res;
          when Iir_Kind_Indexed_Name
            | Iir_Kind_Selected_Element
@@ -1400,7 +1438,7 @@ package body Sem_Names is
                   Prefix := Finish_Sem_Name
                     (Get_Prefix (Name), Get_Implementation (Res));
                   Finish_Sem_Function_Call (Res, Prefix);
-                  --  FIXME: free name
+                  Free_Iir (Name);
                when Iir_Kinds_Denoting_Name =>
                   Prefix := Finish_Sem_Name (Name, Get_Implementation (Res));
                   Finish_Sem_Function_Call (Res, Prefix);
@@ -1412,12 +1450,20 @@ package body Sem_Names is
             if Get_Parameter (Res) = Null_Iir then
                Finish_Sem_Array_Attribute (Name, Res, Null_Iir);
             end if;
+            if Get_Kind (Name) = Iir_Kind_Attribute_Name then
+               Free_Iir (Name);
+            else
+               Free_Iir (Get_Prefix (Name));
+               Free_Parenthesis_Name (Name, Res);
+            end if;
             return Res;
          when Iir_Kinds_Scalar_Type_Attribute
            | Iir_Kind_Image_Attribute
            | Iir_Kind_Value_Attribute =>
             if Get_Parameter (Res) = Null_Iir then
-               Finish_Sem_Scalar_Type_Attribute (Res, Null_Iir);
+               Finish_Sem_Scalar_Type_Attribute (Name, Res, Null_Iir);
+            else
+               Free_Parenthesis_Name (Name, Res);
             end if;
             return Res;
          when Iir_Kinds_Signal_Value_Attribute =>
@@ -1425,15 +1471,19 @@ package body Sem_Names is
          when Iir_Kinds_Signal_Attribute =>
             if Get_Parameter (Res) = Null_Iir then
                Finish_Sem_Signal_Attribute (Name, Res, Null_Iir);
+            else
+               Free_Parenthesis_Name (Name, Res);
             end if;
             return Res;
          when Iir_Kinds_Type_Attribute =>
+            Free_Iir (Name);
             return Res;
          when Iir_Kind_Base_Attribute =>
             return Res;
          when Iir_Kind_Simple_Name_Attribute
            | Iir_Kind_Path_Name_Attribute
            | Iir_Kind_Instance_Name_Attribute =>
+            Free_Iir (Name);
             return Res;
          when Iir_Kind_Psl_Expression =>
             return Res;
@@ -1456,17 +1506,22 @@ package body Sem_Names is
       case Get_Kind (Res) is
          when Iir_Kind_Indexed_Name =>
             Finish_Sem_Indexed_Name (Res);
+            Free_Parenthesis_Name (Name, Res);
          when Iir_Kind_Slice_Name =>
             Finish_Sem_Slice_Name (Res);
+            Free_Parenthesis_Name (Name, Res);
          when Iir_Kind_Selected_Element =>
             Xref_Ref (Res, Get_Selected_Element (Res));
             Set_Name_Staticness (Res, Get_Name_Staticness (Prefix));
             Set_Expr_Staticness (Res, Get_Expr_Staticness (Prefix));
             Set_Base_Name (Res, Get_Base_Name (Prefix));
+            Free_Iir (Name);
          when Iir_Kind_Dereference =>
+            pragma Assert (Get_Kind (Name) = Iir_Kind_Selected_By_All_Name);
             Finish_Sem_Dereference (Res);
+            Free_Iir (Name);
          when Iir_Kinds_Signal_Value_Attribute =>
-            null;
+            Sem_Name_Free_Result (Name, Res);
          when others =>
             Error_Kind ("finish_sem_name(2)", Res);
       end case;
@@ -1995,6 +2050,7 @@ package body Sem_Names is
          when others =>
             raise Internal_Error;
       end case;
+      Free_Parenthesis_Name (Name, Res);
       return Res;
    end Sem_Index_Specification;
 
@@ -2038,8 +2094,7 @@ package body Sem_Names is
 
          --  Extract type of prefix, handle possible implicit deference.
          Base_Type := Get_Base_Type (Get_Type (Sub_Name));
-         if Get_Kind (Base_Type) = Iir_Kind_Access_Type_Definition
-         then
+         if Get_Kind (Base_Type) = Iir_Kind_Access_Type_Definition then
             Ptr_Type := Base_Type;
             Base_Type := Get_Base_Type (Get_Designated_Type (Base_Type));
          else
@@ -2267,7 +2322,7 @@ package body Sem_Names is
                Add_Result
                  (Res, Sem_As_Indexed_Or_Slice_Name (Prefix, True));
             elsif Actual /= Null_Iir then
-               Finish_Sem_Scalar_Type_Attribute (Prefix, Actual);
+               Finish_Sem_Scalar_Type_Attribute (Prefix_Name, Prefix, Actual);
                Set_Named_Entity (Name, Prefix);
                return;
             else
@@ -2445,7 +2500,7 @@ package body Sem_Names is
       --  attributes 'simple_name, 'path_name, or 'instance_name.
       if Get_Kind (Prefix) = Iir_Kind_Object_Alias_Declaration then
          --  GHDL: according to 4.3.3, the name cannot be an alias.
-         Prefix := Get_Name (Prefix);
+         Prefix := Strip_Denoting_Name (Get_Name (Prefix));
       end if;
 
       --  LRM93 6.6
@@ -2746,7 +2801,7 @@ package body Sem_Names is
          when Iir_Kind_Range_Array_Attribute
            | Iir_Kind_Reverse_Range_Array_Attribute =>
             --  For names such as pfx'Range'Left.
-            Finish_Sem_Array_Attribute (Prefix_Name, Prefix, Null_Iir);
+            --  Finish_Sem_Array_Attribute (Prefix_Name, Prefix, Null_Iir);
             Prefix_Type := Get_Type (Prefix);
          when Iir_Kind_Process_Statement =>
             Error_Msg_Sem
@@ -2775,7 +2830,12 @@ package body Sem_Names is
             return Error_Mark;
       end case;
 
-      Res_Type := Prefix_Type;
+      --  Type of the attribute.  This is correct unless there is a parameter,
+      --  and furthermore 'range and 'reverse_range has to be handled
+      --  specially because the result is a range and not a value.
+      Res_Type := Get_Index_Type (Get_Index_Subtype_List (Prefix_Type), 0);
+
+      --  Create the node for the attribute.
       case Get_Identifier (Attr) is
          when Name_Left =>
             Res := Create_Iir (Iir_Kind_Left_Array_Attribute);
@@ -3032,6 +3092,7 @@ package body Sem_Names is
       Prefix_Name : constant Iir := Get_Prefix (Attr);
       Prefix: Iir;
       Res : Iir;
+      Attr_Type : Iir;
    begin
       Prefix := Get_Named_Entity (Prefix_Name);
       Set_Prefix (Attr, Finish_Sem_Name (Prefix_Name, Prefix));
@@ -3088,21 +3149,22 @@ package body Sem_Names is
             Res := Create_Iir (Iir_Kind_Simple_Name_Attribute);
             Eval_Simple_Name (Get_Identifier (Prefix));
             Set_Simple_Name_Identifier (Res, Name_Table.Get_Identifier);
-            Set_Type (Res, Create_Unidim_Array_By_Length
-                      (String_Type_Definition,
-                       Iir_Int64 (Name_Table.Name_Length),
-                       Attr));
+            Attr_Type := Create_Unidim_Array_By_Length
+              (String_Type_Definition,
+               Iir_Int64 (Name_Table.Name_Length),
+               Attr);
+            Set_Simple_Name_Subtype (Res, Attr_Type);
             Set_Expr_Staticness (Res, Locally);
 
          when Name_Path_Name =>
             Res := Create_Iir (Iir_Kind_Path_Name_Attribute);
             Set_Expr_Staticness (Res, Globally);
-            Set_Type (Res, String_Type_Definition);
+            Attr_Type := String_Type_Definition;
 
          when Name_Instance_Name =>
             Res := Create_Iir (Iir_Kind_Instance_Name_Attribute);
             Set_Expr_Staticness (Res, Globally);
-            Set_Type (Res, String_Type_Definition);
+            Attr_Type := String_Type_Definition;
 
          when others =>
             raise Internal_Error;
@@ -3110,6 +3172,7 @@ package body Sem_Names is
 
       Location_Copy (Res, Attr);
       Set_Prefix (Res, Prefix_Name);
+      Set_Type (Res, Attr_Type);
       return Res;
    end Sem_Name_Attribute;
 
@@ -3441,10 +3504,17 @@ package body Sem_Names is
                Disp_Overload_List (Get_Overload_List (Res), Name);
                return Null_Iir;
             else
+               --  Free results
                Sem_Name_Free_Result (Expr, Res);
+
+               Ret_Type := Get_Type (Name);
+               if Ret_Type /= Null_Iir then
+                  pragma Assert (Is_Overload_List (Ret_Type));
+                  Free_Overload_List (Ret_Type);
+               end if;
+
                Set_Named_Entity (Name, Res);
                Res := Finish_Sem_Name (Name);
-               Expr := Get_Named_Entity (Name);
                --  Fall through.
             end if;
          else
@@ -3463,7 +3533,7 @@ package body Sem_Names is
          end if;
       end if;
 
-      --  NAME has only one meaning, which is EXPR.
+      --  NAME has only one meaning, which is RES.
       case Get_Kind (Res) is
          when Iir_Kind_Simple_Name
            | Iir_Kind_Character_Literal
@@ -3548,6 +3618,12 @@ package body Sem_Names is
             if Get_Parameter (Expr) = Null_Iir then
                Finish_Sem_Array_Attribute (Name, Expr, Null_Iir);
             end if;
+            if Get_Kind (Name) = Iir_Kind_Attribute_Name then
+               Free_Iir (Name);
+            else
+               Free_Iir (Get_Prefix (Name));
+               Free_Parenthesis_Name (Name, Expr);
+            end if;
             return Expr;
          when others =>
             Error_Msg_Sem ("name " & Disp_Node (Name)
@@ -3556,8 +3632,7 @@ package body Sem_Names is
       end case;
    end Name_To_Range;
 
-   function Is_Object_Name (Name : Iir) return Boolean
-   is
+   function Is_Object_Name (Name : Iir) return Boolean is
    begin
       case Get_Kind (Name) is
          when Iir_Kind_Object_Alias_Declaration
@@ -3588,8 +3663,7 @@ package body Sem_Names is
       end case;
    end Is_Object_Name;
 
-   function Name_To_Object (Name : Iir) return Iir
-   is
+   function Name_To_Object (Name : Iir) return Iir is
    begin
       case Get_Kind (Name) is
          when Iir_Kind_Object_Alias_Declaration