parse/sem: be more tolerant of parse errors.

8 files changed, 93 insertions, 69 deletions

diff --git a/src/ghdldrv/ghdlcomp.adb b/src/ghdldrv/ghdlcomp.adb
index 0a1b7bac1..1a6aea6d6 100644
--- a/src/ghdldrv/ghdlcomp.adb
+++ b/src/ghdldrv/ghdlcomp.adb
@@ -449,7 +449,12 @@ package body Ghdlcomp is
                raise Compilation_Error;
             end if;
 
-            Free_Iir (Design_File);
+            if New_Design_File = Design_File then
+               pragma Assert (Flags.Flag_Force_Analysis);
+               null;
+            else
+               Free_Iir (Design_File);
+            end if;
 
             --  Do late analysis checks.
             if New_Design_File /= Null_Iir then
diff --git a/src/libraries.adb b/src/libraries.adb
index 243256059..dd70b615a 100644
--- a/src/libraries.adb
+++ b/src/libraries.adb
@@ -1056,6 +1056,11 @@ package body Libraries is
          end if;
       end;
 
+      if Unit_Id = Null_Identifier then
+         pragma Assert (Flags.Flag_Force_Analysis);
+         return;
+      end if;
+
       --  Try to find a design unit with the same name in the work library.
       Id := Get_Hash_Id_For_Unit (Unit);
       Design_Unit := Unit_Hash_Table (Id);
diff --git a/src/vhdl/parse.adb b/src/vhdl/parse.adb
index 5178bfe75..0b4294c1b 100644
--- a/src/vhdl/parse.adb
+++ b/src/vhdl/parse.adb
@@ -1013,7 +1013,9 @@ package body Parse is
                   Prefix := String_To_Operator_Symbol (Prefix);
                end if;
 
+               --  Skip '''.
                Scan;
+
                if Current_Token = Tok_Left_Paren then
                   -- A qualified expression.
                   Res := Create_Iir (Iir_Kind_Qualified_Expression);
@@ -1028,7 +1030,7 @@ package body Parse is
                then
                   Expect
                     (Tok_Identifier, "attribute identifier expected after '");
-                  return Res;
+                  return Create_Error_Node (Prefix);
                end if;
                Res := Create_Iir (Iir_Kind_Attribute_Name);
                Set_Identifier (Res, Current_Identifier);
@@ -2334,8 +2336,6 @@ package body Parse is
                Def := Type_Mark;
          end case;
 
-         Append_Element (Index_List, Def);
-
          if First then
             Array_Constrained := Index_Constrained;
             First := False;
@@ -2343,9 +2343,15 @@ package body Parse is
             if Array_Constrained /= Index_Constrained then
                Error_Msg_Parse
                  ("cannot mix constrained and unconstrained index");
+               Def := Create_Error_Node (Def);
             end if;
          end if;
+
+         Append_Element (Index_List, Def);
+
          exit when Current_Token /= Tok_Comma;
+
+         --  Skip ','.
          Scan;
       end loop;
 
@@ -3046,7 +3052,7 @@ package body Parse is
          end if;
          if Current_Token /= Tok_Identifier then
             Error_Msg_Parse ("type mark expected in a subtype indication");
-            return Null_Iir;
+            return Create_Error_Node;
          end if;
          Type_Mark := Parse_Type_Mark (Check_Paren => False);
       end if;
@@ -3641,22 +3647,10 @@ package body Parse is
 
          Sub_Chain_Append (First, Last, Object);
 
-         exit when Current_Token = Tok_Colon;
-         if Current_Token /= Tok_Comma then
-            case Current_Token is
-               when Tok_Assign =>
-                  Error_Msg_Parse ("missing type in " & Disp_Name (Kind));
-                  exit;
-               when others =>
-                  Error_Msg_Parse
-                    ("',' or ':' is expected after identifier in "
-                       & Disp_Name (Kind));
-                  Resync_To_End_Of_Declaration;
-                  return Object;
-            end case;
-         else
-            Scan;
-         end if;
+         exit when Current_Token /= Tok_Comma;
+
+         --  Skip ','.
+         Scan;
          Set_Has_Identifier_List (Object, True);
       end loop;
 
@@ -4022,7 +4016,7 @@ package body Parse is
             Set_Identifier (Res, Scan_To_Operator_Name (Get_Token_Location));
          when others =>
             Error_Msg_Parse ("identifier, character or string expected");
-            return Null_Iir;
+            return Create_Error_Node;
       end case;
       Scan;
       if Current_Token = Tok_Left_Bracket then
@@ -4050,10 +4044,16 @@ package body Parse is
       case Current_Token is
          when Tok_All =>
             Flist := Iir_Flist_All;
+
+            --  Skip 'all'.
             Scan;
+
          when Tok_Others =>
             Flist := Iir_Flist_Others;
+
+            --  Skip 'others'.
             Scan;
+
          when others =>
             List := Create_Iir_List;
             loop
@@ -6254,6 +6254,7 @@ package body Parse is
                when others =>
                   Error_Msg_Parse
                     ("only names are allowed in a sensitivity list");
+                  El := Create_Error_Node (El);
             end case;
             Append_Element (List, El);
          end if;
@@ -6799,15 +6800,7 @@ package body Parse is
          --  Skip 'when'.
          Scan;
 
-         if Current_Token = Tok_Double_Arrow then
-            Error_Msg_Parse ("missing expression in alternative");
-            Assoc := Create_Iir (Iir_Kind_Choice_By_Expression);
-            Set_Location (Assoc, When_Loc);
-            Set_Choice_Position (Assoc, Pos);
-            Pos := Pos + 1;
-         else
-            Parse_Choices (Null_Iir, When_Loc, Pos, Assoc);
-         end if;
+         Parse_Choices (Null_Iir, When_Loc, Pos, Assoc);
 
          --  Skip '=>'.
          Expect_Scan (Tok_Double_Arrow);
@@ -8860,20 +8853,13 @@ package body Parse is
       --  Identifier.
       Scan_Identifier (Res);
 
-      if Current_Token = Tok_Is then
-         Error_Msg_Parse ("architecture identifier is missing");
-
-         --  Skip 'is'.
-         Scan;
-      else
-         --  Skip 'of'.
-         Expect_Scan (Tok_Of);
+      --  Skip 'of'.
+      Expect_Scan (Tok_Of);
 
-         Set_Entity_Name (Res, Parse_Name (False));
+      Set_Entity_Name (Res, Parse_Name (False));
 
-         --  Skip 'is'.
-         Expect_Scan (Tok_Is);
-      end if;
+      --  Skip 'is'.
+      Expect_Scan (Tok_Is);
 
       Parse_Declarative_Part (Res);
 
diff --git a/src/vhdl/sem_decls.adb b/src/vhdl/sem_decls.adb
index 2d7f6086b..6363acc98 100644
--- a/src/vhdl/sem_decls.adb
+++ b/src/vhdl/sem_decls.adb
@@ -1684,15 +1684,19 @@ package body Sem_Decls is
       Xref_Decl (Alias);
 
       Name := Get_Name (Alias);
-      if Get_Kind (Name) = Iir_Kind_Signature then
-         Sig := Name;
-         Name := Get_Signature_Prefix (Sig);
-         Sem_Name (Name);
-         Set_Signature_Prefix (Sig, Name);
-      else
-         Sem_Name (Name);
-         Sig := Null_Iir;
-      end if;
+      case Get_Kind (Name) is
+         when Iir_Kind_Signature =>
+            Sig := Name;
+            Name := Get_Signature_Prefix (Sig);
+            Sem_Name (Name);
+            Set_Signature_Prefix (Sig, Name);
+         when Iir_Kind_Error =>
+            pragma Assert (Flags.Flag_Force_Analysis);
+            return Alias;
+         when others =>
+            Sem_Name (Name);
+            Sig := Null_Iir;
+      end case;
 
       N_Entity := Get_Named_Entity (Name);
       if N_Entity = Error_Mark then
diff --git a/src/vhdl/sem_expr.adb b/src/vhdl/sem_expr.adb
index e49cfcf8f..a9448940a 100644
--- a/src/vhdl/sem_expr.adb
+++ b/src/vhdl/sem_expr.adb
@@ -4028,6 +4028,10 @@ package body Sem_Expr is
          when others =>
             Error_Kind ("sem_physical_literal", Lit);
       end case;
+      if Is_Error (Unit_Name) then
+         return Create_Error_Expr (Res, Error_Mark);
+      end if;
+
       Unit_Name := Sem_Denoting_Name (Unit_Name);
       Unit := Get_Named_Entity (Unit_Name);
       if Get_Kind (Unit) /= Iir_Kind_Unit_Declaration then
@@ -4944,7 +4948,7 @@ package body Sem_Expr is
       Result_Type : Iir;
       Expr_Type : Iir;
    begin
-      if Expr = Null_Iir then
+      if Is_Error (Expr) then
          return;
       end if;
 
diff --git a/src/vhdl/sem_specs.adb b/src/vhdl/sem_specs.adb
index d4713b264..e1584d904 100644
--- a/src/vhdl/sem_specs.adb
+++ b/src/vhdl/sem_specs.adb
@@ -569,6 +569,11 @@ package body Sem_Specs is
       --  beyond the immediate declarative part, such as design unit or
       --  interfaces.
       if Is_Designator then
+         if Is_Error (Name) then
+            pragma Assert (Flags.Flag_Force_Analysis);
+            return True;
+         end if;
+
          --  LRM 5.1  Attribute specification
          --  An attribute specification for an attribute of a design unit
          --  (i.e. an entity declaration, an architecture, a configuration
@@ -823,6 +828,9 @@ package body Sem_Specs is
               (Warnid_Specs, +Spec,
                "attribute specification apply to no named entity");
          end if;
+      elsif List = Null_Iir_Flist then
+         pragma Assert (Flags.Flag_Force_Analysis);
+         null;
       else
          --  o If a list of entity designators is supplied, then the
          --  attribute specification applies to the named entities denoted
@@ -1021,12 +1029,17 @@ package body Sem_Specs is
          for I in Flist_First .. Flist_Last (List) loop
             El := Get_Nth_Element (List, I);
 
-            Sem_Name (El);
-            El := Finish_Sem_Name (El);
-            Set_Nth_Element (List, I, El);
+            if Is_Error (El) then
+               Sig := Null_Iir;
+            else
+               Sem_Name (El);
+               El := Finish_Sem_Name (El);
+               Set_Nth_Element (List, I, El);
+
+               Sig := Get_Named_Entity (El);
+               Sig := Name_To_Object (Sig);
+            end if;
 
-            Sig := Get_Named_Entity (El);
-            Sig := Name_To_Object (Sig);
             if Sig /= Null_Iir then
                Set_Type (El, Get_Type (Sig));
                Prefix := Get_Object_Prefix (Sig);
@@ -1074,7 +1087,9 @@ package body Sem_Specs is
                --  Each signal must be declared in the declarative part
                --  enclosing the disconnection specification.
                --  FIXME: todo.
-            elsif Get_Designated_Entity (El) /= Error_Mark then
+            elsif not Is_Error (El)
+              and then Get_Designated_Entity (El) /= Error_Mark
+            then
                Error_Msg_Sem (+El, "name must designate a signal");
             end if;
          end loop;
@@ -1313,13 +1328,16 @@ package body Sem_Specs is
      (Parent_Stmts : Iir; Spec : Iir; Primary_Entity_Aspect : out Iir)
    is
       function Apply_Component_Specification
-        (Chain : Iir; Check_Applied : Boolean)
-        return Boolean
+        (Chain : Iir; Check_Applied : Boolean) return Boolean
       is
          Comp : constant Iir := Get_Named_Entity (Get_Component_Name (Spec));
          El : Iir;
          Res : Boolean;
       begin
+         if Chain = Null_Iir then
+            return False;
+         end if;
+
          El := Get_Concurrent_Statement_Chain (Chain);
          Res := False;
          while El /= Null_Iir loop
diff --git a/src/vhdl/sem_stmts.adb b/src/vhdl/sem_stmts.adb
index 0f9f029dd..30c0de209 100644
--- a/src/vhdl/sem_stmts.adb
+++ b/src/vhdl/sem_stmts.adb
@@ -1143,9 +1143,15 @@ package body Sem_Stmts is
          -- El is an iir_identifier.
          El := Get_Element (It);
 
-         Sem_Name (El);
+         if Is_Error (El) then
+            pragma Assert (Flags.Flag_Force_Analysis);
+            Res := Error_Mark;
+         else
+            Sem_Name (El);
+
+            Res := Get_Named_Entity (El);
+         end if;
 
-         Res := Get_Named_Entity (El);
          if Res = Error_Mark then
             null;
          elsif Is_Overload_List (Res) or else not Is_Object_Name (Res) then
diff --git a/src/vhdl/sem_types.adb b/src/vhdl/sem_types.adb
index 8de136ac9..4bb4ac2dd 100644
--- a/src/vhdl/sem_types.adb
+++ b/src/vhdl/sem_types.adb
@@ -2311,12 +2311,6 @@ package body Sem_Types is
       Type_Mark: Iir;
       Res : Iir;
    begin
-      if Def = Null_Iir then
-         --  Missing subtype indication.
-         pragma Assert (Flags.Flag_Force_Analysis);
-         return Create_Error_Type (Null_Iir);
-      end if;
-
       --  LRM08 6.3 Subtype declarations
       --
       --  If the subtype indication does not include a constraint, the subtype
@@ -2326,6 +2320,8 @@ package body Sem_Types is
            | Iir_Kind_Attribute_Name =>
             Type_Mark := Sem_Type_Mark (Def, Incomplete);
             return Type_Mark;
+         when Iir_Kind_Error =>
+            return Def;
          when others =>
             null;
       end case;