Avoid a crash on error.

Fix bug041.

5 files changed, 73 insertions, 91 deletions

diff --git a/src/vhdl/errorout.adb b/src/vhdl/errorout.adb
index 81f572345..9728fae20 100644
--- a/src/vhdl/errorout.adb
+++ b/src/vhdl/errorout.adb
@@ -1100,14 +1100,11 @@ package body Errorout is
         (Origin, "(" & Disp_Node (Callee) & " is defined here)", Callee);
    end Error_Pure;
 
-   procedure Error_Not_Match (Expr: Iir; A_Type: Iir; Loc : Iir)
+   procedure Error_Not_Match (Expr: Iir; A_Type: Iir)
    is
    begin
       Error_Msg_Sem ("can't match " & Disp_Node (Expr) & " with type "
-                     & Disp_Node (A_Type), Loc);
-      if Loc /= Expr then
-         Error_Msg_Sem ("(location of " & Disp_Node (Expr) & ")", Expr);
-      end if;
+                     & Disp_Node (A_Type), Expr);
    end Error_Not_Match;
 
    function Get_Mode_Name (Mode : Iir_Mode) return String is
diff --git a/src/vhdl/errorout.ads b/src/vhdl/errorout.ads
index 9dd70d2cf..ab7b3fcc2 100644
--- a/src/vhdl/errorout.ads
+++ b/src/vhdl/errorout.ads
@@ -125,8 +125,8 @@ package Errorout is
      (Origin : Report_Origin; Caller : Iir; Callee : Iir; Loc : Iir);
 
    --  Report an error message as type of EXPR does not match A_TYPE.
-   --  Location is LOC.
-   procedure Error_Not_Match (Expr: Iir; A_Type: Iir; Loc : Iir);
+   --  Location is EXPR.
+   procedure Error_Not_Match (Expr: Iir; A_Type: Iir);
 
    --  Disp interface mode MODE.
    function Get_Mode_Name (Mode : Iir_Mode) return String;
diff --git a/src/vhdl/sem_expr.adb b/src/vhdl/sem_expr.adb
index 415662a9f..050c17680 100644
--- a/src/vhdl/sem_expr.adb
+++ b/src/vhdl/sem_expr.adb
@@ -33,28 +33,6 @@ with Xrefs; use Xrefs;
 
 package body Sem_Expr is
 
-   procedure Not_Match (Expr: Iir; A_Type: Iir)
-   is
-      pragma Inline (Not_Match);
-   begin
-      Error_Not_Match (Expr, A_Type, Expr);
-   end Not_Match;
-
---    procedure Not_Match (Expr: Iir; Type1: Iir; Type2: Iir) is
---    begin
---       Error_Msg_Sem
---         ("can't match '" & Disp_Node (Expr) & "' with type '"
---          & Disp_Node (Type1) & "' or type '" & Disp_Node (Type2) & "'",
---          Expr);
---    end Not_Match;
-
---    procedure Overloaded (Expr: Iir) is
---    begin
---       Error_Msg_Sem
---         ("cant resolve overloaded identifier '" & Get_String (Expr) & "'",
---          Expr);
---    end Overloaded;
-
    -- Replace type of TARGET by A_TYPE.
    -- If TARGET has already a type, it must be an overload list, and in this
    -- case, this list is freed, or it must be A_TYPE.
@@ -760,7 +738,7 @@ package body Sem_Expr is
             if A_Type /= Null_Iir
               and then Get_Base_Type (Res_Type) /= Get_Base_Type (A_Type)
             then
-               Not_Match (Expr, A_Type);
+               Error_Not_Match (Expr, A_Type);
                return Null_Iir;
             end if;
 
@@ -1482,7 +1460,7 @@ package body Sem_Expr is
          end if;
       end if;
       if Res = Null_Iir then
-         Not_Match (Expr, A_Type);
+         Error_Not_Match (Expr, A_Type);
          return Null_Iir;
       end if;
 
@@ -2631,7 +2609,7 @@ package body Sem_Expr is
          Name1 : Iir;
       begin
          if Are_Types_Compatible (Range_Type, Sub_Type) = Not_Compatible then
-            Not_Match (Name, Sub_Type);
+            Error_Not_Match (Name, Sub_Type);
             return False;
          end if;
 
@@ -3741,7 +3719,7 @@ package body Sem_Expr is
                   Error_Msg_Sem ("expected type is not an access type", Expr);
                end if;
             else
-               Not_Match (Expr, A_Type);
+               Error_Not_Match (Expr, A_Type);
             end if;
             return Null_Iir;
          end if;
@@ -3762,7 +3740,7 @@ package body Sem_Expr is
       if A_Type /= Null_Iir
         and then Are_Types_Compatible (A_Type, N_Type) = Not_Compatible
       then
-         Not_Match (Expr, A_Type);
+         Error_Not_Match (Expr, A_Type);
          return Null_Iir;
       end if;
       Res := Sem_Expression (Get_Expression (Expr), N_Type);
@@ -4090,7 +4068,7 @@ package body Sem_Expr is
               and then Are_Basetypes_Compatible
               (A_Type, Get_Base_Type (Get_Type (Expr))) = Not_Compatible
             then
-               Not_Match (Expr, A_Type);
+               Error_Not_Match (Expr, A_Type);
                return Null_Iir;
             end if;
             return Expr;
@@ -4104,7 +4082,7 @@ package body Sem_Expr is
                Set_Type (Expr, A_Type);
                return Expr;
             else
-               Not_Match (Expr, A_Type);
+               Error_Not_Match (Expr, A_Type);
                return Null_Iir;
             end if;
 
@@ -4117,7 +4095,7 @@ package body Sem_Expr is
                Set_Type (Expr, A_Type);
                return Expr;
             else
-               Not_Match (Expr, A_Type);
+               Error_Not_Match (Expr, A_Type);
                return Null_Iir;
             end if;
 
@@ -4132,7 +4110,7 @@ package body Sem_Expr is
                   return Null_Iir;
                end if;
                if A_Type /= Null_Iir and then Get_Type (Res) /= A_Type then
-                  Not_Match (Res, A_Type);
+                  Error_Not_Match (Res, A_Type);
                   return Null_Iir;
                end if;
                return Res;
@@ -4148,7 +4126,7 @@ package body Sem_Expr is
             end if;
 
             if not Is_String_Literal_Type (A_Type, Expr) then
-               Not_Match (Expr, A_Type);
+               Error_Not_Match (Expr, A_Type);
                return Null_Iir;
             else
                Replace_Type (Expr, A_Type);
@@ -4209,6 +4187,10 @@ package body Sem_Expr is
               (Disp_Node (Expr) & " cannot be used as an expression", Expr);
             return Null_Iir;
 
+         when Iir_Kind_Error =>
+            -- Always ok.
+            return Expr;
+
          when others =>
             Error_Kind ("sem_expression_ov", Expr);
             return Null_Iir;
@@ -4383,7 +4365,7 @@ package body Sem_Expr is
          when Iir_Kind_String_Literal8 =>
             if Atype_Defined then
                if not Is_String_Literal_Type (Atype, Expr) then
-                  Not_Match (Expr, Atype);
+                  Error_Not_Match (Expr, Atype);
                   Set_Type (Expr, Error_Type);
                else
                   Set_Type (Expr, Atype);
@@ -4398,7 +4380,7 @@ package body Sem_Expr is
          when Iir_Kind_Null_Literal =>
             if Atype_Defined then
                if not Is_Null_Literal_Type (Atype) then
-                  Not_Match (Expr, Atype);
+                  Error_Not_Match (Expr, Atype);
                   Set_Type (Expr, Error_Type);
                else
                   Set_Type (Expr, Atype);
@@ -4414,7 +4396,7 @@ package body Sem_Expr is
            | Iir_Kind_Allocator_By_Subtype =>
             if Atype_Defined then
                if not Is_Null_Literal_Type (Atype) then
-                  Not_Match (Expr, Atype);
+                  Error_Not_Match (Expr, Atype);
                   Set_Type (Expr, Error_Type);
                else
                   return Sem_Allocator (Expr, Atype);
@@ -4462,7 +4444,7 @@ package body Sem_Expr is
                   if Atype in Iir_Wildcard_Types then
                      --  Analyze without known type.
                      Res := Sem_Expression_Ov (Expr, Null_Iir);
-                     if Res = Null_Iir then
+                     if Res = Null_Iir or else Is_Error (Res) then
                         Set_Type (Expr, Error_Type);
                         return Expr;
                      end if;
@@ -4474,7 +4456,7 @@ package body Sem_Expr is
 
                      if Res_Type = Null_Iir then
                         --  No matching type.  This is an error.
-                        Not_Match (Expr, Atype);
+                        Error_Not_Match (Expr, Atype);
                         Set_Type (Expr, Error_Type);
                      elsif Is_Defined_Type (Res_Type) then
                         --  Known and defined matching type.
@@ -4548,7 +4530,7 @@ package body Sem_Expr is
          if A_Type /= Null_Iir
            and then Are_Types_Compatible (Expr_Type, A_Type) = Not_Compatible
          then
-            Not_Match (Expr, A_Type);
+            Error_Not_Match (Expr, A_Type);
             return Null_Iir;
          end if;
          return Expr;
@@ -4569,7 +4551,7 @@ package body Sem_Expr is
                Res := Sem_Expression_Ov (Expr, Null_Iir);
             else
                if not Is_String_Literal_Type (A_Type, Expr) then
-                  Not_Match (Expr, A_Type);
+                  Error_Not_Match (Expr, A_Type);
                   return Null_Iir;
                end if;
                Set_Type (Expr, A_Type);
diff --git a/src/vhdl/sem_names.adb b/src/vhdl/sem_names.adb
index 0dc768059..421eaeb11 100644
--- a/src/vhdl/sem_names.adb
+++ b/src/vhdl/sem_names.adb
@@ -46,6 +46,10 @@ package body Sem_Names is
 
    procedure Error_Overload (Expr: Iir) is
    begin
+      if Is_Error (Expr) then
+         --  Avoid error storm.
+         return;
+      end if;
       Error_Msg_Sem ("can't resolve overload for " & Disp_Node (Expr), Expr);
    end Error_Overload;
 
@@ -3610,7 +3614,7 @@ package body Sem_Names is
 
    --  Convert name EXPR to an expression (ie, create function call).
    --  A_TYPE is the expected type of the expression.
-   --  Returns NULL_IIR in case of error.
+   --  Returns an Error node in case of error.
    function Name_To_Expression (Name : Iir; A_Type : Iir) return Iir
    is
       Ret_Type : Iir;
@@ -3623,10 +3627,10 @@ package body Sem_Names is
    begin
       Expr := Get_Named_Entity (Name);
       if Get_Kind (Expr) = Iir_Kind_Error then
-         return Null_Iir;
+         return Expr;
       end if;
       if Check_Is_Expression (Expr, Name) = Null_Iir then
-         return Null_Iir;
+         return Create_Error_Expr (Name, A_Type);
       end if;
 
       --  Note: EXPR may contain procedure names...
@@ -3635,7 +3639,7 @@ package body Sem_Names is
       if Expr = Null_Iir then
          Error_Msg_Sem ("procedure name " & Disp_Node (Name)
                         & " cannot be used as expression", Name);
-         return Null_Iir;
+         return Create_Error_Expr (Name, A_Type);
       end if;
 
       if not Is_Overload_List (Expr) then
@@ -3644,13 +3648,13 @@ package body Sem_Names is
          if A_Type /= Null_Iir then
             Res_Type := Get_Type (Res);
             if Res_Type = Null_Iir then
-               return Null_Iir;
+               return Create_Error_Expr (Res, A_Type);
             end if;
             if Are_Basetypes_Compatible (Get_Base_Type (Res_Type), A_Type)
               = Not_Compatible
             then
-               Error_Not_Match (Res, A_Type, Name);
-               return Null_Iir;
+               Error_Not_Match (Res, A_Type);
+               return Create_Error_Expr (Res, A_Type);
             end if;
             --  Fall through.
          end if;
@@ -3672,8 +3676,8 @@ package body Sem_Names is
                end if;
             end loop;
             if Res = Null_Iir then
-               Error_Not_Match (Name, A_Type, Name);
-               return Null_Iir;
+               Error_Not_Match (Name, A_Type);
+               return Create_Error_Expr (Name, A_Type);
             elsif Is_Overload_List (Res) then
                Res1 := Extract_Call_Without_Implicit_Conversion (Res);
                if Res1 /= Null_Iir then
@@ -3683,7 +3687,7 @@ package body Sem_Names is
                   Error_Overload (Name);
                   Disp_Overload_List (Get_Overload_List (Res), Name);
                   Free_Iir (Res);
-                  return Null_Iir;
+                  return Create_Error_Expr (Name, A_Type);
                end if;
             end if;
 
@@ -3711,7 +3715,7 @@ package body Sem_Names is
                   Error_Overload (Name);
                   Disp_Overload_List (Expr_List, Name);
                   --Free_Iir (Ret_Type);
-                  return Null_Iir;
+                  return Create_Error_Expr (Name, A_Type);
                end if;
             else
                Set_Type (Name, Ret_Type);
diff --git a/src/vhdl/sem_stmts.adb b/src/vhdl/sem_stmts.adb
index 13fcc08d8..c6bbcb332 100644
--- a/src/vhdl/sem_stmts.adb
+++ b/src/vhdl/sem_stmts.adb
@@ -109,7 +109,7 @@ package body Sem_Stmts is
    end Sem_Sequential_Labels;
 
    procedure Fill_Array_From_Aggregate_Associated
-     (Chain : Iir; Nbr : in out Natural; Arr : Iir_Array_Acc)
+     (Chain : Iir; Nbr : in out Natural; Arr : in out Iir_Array)
    is
       El : Iir;
       Ass : Iir;
@@ -121,9 +121,7 @@ package body Sem_Stmts is
             Fill_Array_From_Aggregate_Associated
               (Get_Association_Choices_Chain (Ass), Nbr, Arr);
          else
-            if Arr /= null then
-               Arr (Nbr) := Ass;
-            end if;
+            Arr (Nbr) := Ass;
             Nbr := Nbr + 1;
          end if;
          El := Get_Chain (El);
@@ -177,42 +175,43 @@ package body Sem_Stmts is
    procedure Check_Uniq_Aggregate_Associated
      (Aggr : Iir_Aggregate; Nbr : Natural)
    is
+      Chain : constant Iir := Get_Association_Choices_Chain (Aggr);
+      subtype El_Array_Type is Iir_Array (0 .. Nbr - 1);
+      Name_Arr, Obj_Arr : El_Array_Type;
       Index : Natural;
-      Arr : Iir_Array_Acc;
-      Chain : Iir;
-      V_I, V_J : Iir;
+      El : Iir;
    begin
-      Chain := Get_Association_Choices_Chain (Aggr);
-      --  Count number of associated values, and create the array.
-      --  Already done: use nbr.
-      -- Fill_Array_From_Aggregate_Associated (List, Nbr, null);
-      Arr := new Iir_Array (0 .. Nbr - 1);
       --  Fill the array.
       Index := 0;
-      Fill_Array_From_Aggregate_Associated (Chain, Index, Arr);
-      if Index /= Nbr then
-         --  Should be the same.
-         raise Internal_Error;
-      end if;
-      --  Check each element is uniq.
-      for I in Arr.all'Range loop
-         V_I := Name_To_Object (Arr (I));
-         if Get_Name_Staticness (V_I) = Locally then
-            for J in 0 .. I - 1 loop
-               V_J := Name_To_Object (Arr (J));
-               if Get_Name_Staticness (V_J) = Locally
-                 and then not Is_Disjoint (V_I, V_J)
-               then
-                  Error_Msg_Sem ("target is assigned more than once", Arr (I));
-                  Error_Msg_Sem (" (previous assignment is here)", Arr (J));
-                  Free (Arr);
-                  return;
-               end if;
-            end loop;
+      Fill_Array_From_Aggregate_Associated (Chain, Index, Name_Arr);
+      --  Should be the same.
+      pragma Assert (Index = Nbr);
+
+      --  Replace name with object.  Return now in case of error (not an
+      --  object or not a static name).
+      for I in Name_Arr'Range loop
+         El := Name_To_Object (Name_Arr (I));
+         if El = Null_Iir
+           or else Get_Name_Staticness (El) /= Locally
+         then
+            --  Error...
+            return;
          end if;
+         Obj_Arr (I) := El;
+      end loop;
+
+      --  Check each element is uniq.
+      for I in Name_Arr'Range loop
+         for J in 0 .. I - 1 loop
+            if not Is_Disjoint (Obj_Arr (I), Obj_Arr (J)) then
+               Error_Msg_Sem
+                 ("target is assigned more than once", Name_Arr (I));
+               Error_Msg_Sem
+                 (" (previous assignment is here)", Name_Arr (J));
+               return;
+            end if;
+         end loop;
       end loop;
-      Free (Arr);
-      return;
    end Check_Uniq_Aggregate_Associated;
 
    --  Do checks for the target of an assignment.