diff options
| author | Tristan Gingold <tgingold@free.fr> | 2014-07-23 20:13:49 +0200 | 
|---|---|---|
| committer | Tristan Gingold <tgingold@free.fr> | 2014-07-23 20:13:49 +0200 | 
| commit | 777f73f67f0f2d18f73dc223a2d941ece31d0c9e (patch) | |
| tree | d8bf9afda0d08fa40e0a47ec5bcf9356a21ae862 | |
| parent | 694a4d2744f252b326121c37c2271133e0ec535f (diff) | |
| download | ghdl-777f73f67f0f2d18f73dc223a2d941ece31d0c9e.tar.gz ghdl-777f73f67f0f2d18f73dc223a2d941ece31d0c9e.tar.bz2 ghdl-777f73f67f0f2d18f73dc223a2d941ece31d0c9e.zip | |
Add parenthesis_Expression, --reprint and --compare-tokens commands.
| -rw-r--r-- | canon.adb | 3 | ||||
| -rw-r--r-- | disp_tree.adb | 15 | ||||
| -rw-r--r-- | disp_vhdl.adb | 106 | ||||
| -rw-r--r-- | errorout.adb | 4 | ||||
| -rw-r--r-- | evaluation.adb | 25 | ||||
| -rw-r--r-- | iirs.adb | 163 | ||||
| -rw-r--r-- | iirs.ads | 184 | ||||
| -rw-r--r-- | iirs_utils.adb | 7 | ||||
| -rw-r--r-- | libraries.adb | 2 | ||||
| -rw-r--r-- | nodes.adb | 30 | ||||
| -rw-r--r-- | nodes.ads | 18 | ||||
| -rw-r--r-- | parse.adb | 36 | ||||
| -rw-r--r-- | parse.ads | 3 | ||||
| -rw-r--r-- | sem_assocs.adb | 2 | ||||
| -rw-r--r-- | sem_expr.adb | 20 | ||||
| -rw-r--r-- | sem_names.adb | 40 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdllocal.adb | 11 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdllocal.ads | 4 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdlprint.adb | 126 | 
19 files changed, 618 insertions, 181 deletions
| @@ -2526,8 +2526,7 @@ package body Canon is                          Set_Parent (Res, Conf);                          Blk_Spec := Create_Iir (Iir_Kind_Selected_Name);                          Location_Copy (Blk_Spec, Res); -                        Set_Suffix_Identifier -                          (Blk_Spec, Std_Names.Name_Others); +                        Set_Identifier (Blk_Spec, Std_Names.Name_Others);                          Set_Prefix (Blk_Spec, El);                          Set_Block_Specification (Res, Blk_Spec);                          Append (Last_Item, Conf, Res); diff --git a/disp_tree.adb b/disp_tree.adb index a68d2d0ee..8ac5108a6 100644 --- a/disp_tree.adb +++ b/disp_tree.adb @@ -443,7 +443,7 @@ package body Disp_Tree is           when Iir_Kind_Attribute_Name =>              Put ("attribute_name"); -            Disp_Ident (Get_Attribute_Identifier (Tree)); +            Disp_Ident (Get_Identifier (Tree));           when Iir_Kind_Implicit_Function_Declaration =>              Put ("implicit_function_declaration: "); @@ -656,8 +656,6 @@ package body Disp_Tree is                 Header ("context items:");                 Disp_Tree_Chain (Get_Context_Items (Tree), Ntab);              end if; -            Header ("attribute_value_chain:"); -            Disp_Tree_Flat_Chain (Get_Attribute_Value_Chain (Tree), Ntab);              Header ("library unit:");              Disp_Tree (Get_Library_Unit (Tree), Ntab);           when Iir_Kind_Use_Clause => @@ -1712,6 +1710,13 @@ package body Disp_Tree is              Disp_Tree (Get_Method_Object (Tree), Ntab);              Header ("parameters:");              Disp_Tree_Chain (Get_Parameter_Association_Chain (Tree), Ntab); +         when Iir_Kind_Parenthesis_Expression => +            Header ("staticness:", false); +            Disp_Expr_Staticness (Tree); +            Header ("type:"); +            Disp_Tree_Flat (Get_Type (Tree), Ntab); +            Header ("expression:"); +            Disp_Tree (Get_Expression (Tree), Ntab, True);           when Iir_Kind_Qualified_Expression =>              Header ("staticness:", false);              Disp_Expr_Staticness (Tree); @@ -1813,8 +1818,8 @@ package body Disp_Tree is           when Iir_Kind_Selected_Name =>              Header ("prefix:");              Disp_Tree (Get_Prefix (Tree), Ntab, True); -            Header ("suffix_identifier: ", False); -            Disp_Ident (Get_Suffix_Identifier (Tree)); +            Header ("identifier: ", False); +            Disp_Ident (Get_Identifier (Tree));           when Iir_Kind_Attribute_Name =>              Header ("prefix:"); diff --git a/disp_vhdl.adb b/disp_vhdl.adb index a20e3754f..fd571ae98 100644 --- a/disp_vhdl.adb +++ b/disp_vhdl.adb @@ -20,7 +20,7 @@  -- Disp an iir tree.  -- Try to be as pretty as possible, and to keep line numbers and positions  -- of the identifiers. -with Ada.Text_IO; use Ada.Text_IO; +with GNAT.OS_Lib;  with Std_Package;  with Flags; use Flags;  with Errorout; use Errorout; @@ -34,11 +34,25 @@ with PSL.NFAs;  package body Disp_Vhdl is +   subtype Count is Positive; + +   Col : Count := 1; + +   IO_Error : exception; +     --  Disp the name of DECL.     procedure Disp_Name_Of (Decl: Iir); +   --  Indentation for nested declarations and statements.     Indentation: constant Count := 2; +   --  Line length (used to try to have a nice display). +   Line_Length : constant Count := 80; + +   --  If True, display extra parenthesis to make priority of operators +   --  explicit. +   Flag_Parenthesis : constant Boolean := False; +     -- If set, disp after a string literal the type enclosed into brackets.     Disp_String_Literal_Type: constant Boolean := False; @@ -68,6 +82,42 @@ package body Disp_Vhdl is     procedure Disp_Subtype_Indication (Def : Iir; Full_Decl : Boolean := False);     procedure Disp_Parametered_Attribute (Name : String; Expr : Iir); +   procedure Put (Str : String) +   is +      use GNAT.OS_Lib; +      Len : constant Natural := Str'Length; +   begin +      if Write (Standout, Str'Address, Len) /= Len then +         raise IO_Error; +      end if; +      Col := Col + Len; +   end Put; + +   procedure Put (C : Character) is +   begin +      Put ((1 => C)); +   end Put; + +   procedure New_Line is +   begin +      Put (ASCII.LF); +      Col := 1; +   end New_Line; + +   procedure Put_Line (Str : String) is +   begin +      Put (Str); +      New_Line; +   end Put_Line; + +   procedure Set_Col (P : Count) is +   begin +      if Col /= 1 then +         New_Line; +      end if; +      Put ((1 .. P - 1 => ' ')); +   end Set_Col; +     procedure Disp_Ident (Id: Name_Id) is     begin        Put (Name_Table.Image (Id)); @@ -217,7 +267,7 @@ package body Disp_Vhdl is           when Iir_Kind_Selected_Name =>              Disp_Name (Get_Prefix (Name));              Put ("."); -            Disp_Ident (Get_Suffix_Identifier (Name)); +            Disp_Ident (Get_Identifier (Name));           when Iir_Kind_Type_Declaration             | Iir_Kind_Subtype_Declaration             | Iir_Kind_Enumeration_Literal @@ -616,6 +666,9 @@ package body Disp_Vhdl is     begin        if List = Null_Iir_List then           return; +      elsif List = Iir_List_All then +         Put ("all"); +         return;        end if;        for I in Natural loop           El := Get_Nth_Element (List, I); @@ -849,7 +902,9 @@ package body Disp_Vhdl is        end case;        Disp_Name_Of (Inter);        Put (": "); -      Disp_Mode (Get_Mode (Inter)); +      if (Get_Lexical_Layout (Inter) and Iir_Lexical_Has_Mode) /= 0 then +         Disp_Mode (Get_Mode (Inter)); +      end if;        Disp_Type (Get_Type (Inter));        if Get_Kind (Inter) = Iir_Kind_Signal_Interface_Declaration then           Disp_Signal_Kind (Get_Signal_Kind (Inter)); @@ -897,6 +952,21 @@ package body Disp_Vhdl is        Disp_Interface_Chain (Get_Generic_Chain (Parent), ";");     end Disp_Generics; +   procedure Disp_End (Decl : Iir; Name : String) is +   begin +      Put ("end"); +      if Get_End_Has_Reserved_Id (Decl) then +         Put (' '); +         Put (Name); +      end if; +      if Get_End_Has_Identifier (Decl) then +         Put (' '); +         Disp_Name_Of (Decl); +      end if; +      Put (';'); +      New_Line; +   end Disp_End; +     procedure Disp_Entity_Declaration (Decl: Iir_Entity_Declaration) is        Start: Count;     begin @@ -913,13 +983,15 @@ package body Disp_Vhdl is           Disp_Ports (Decl);        end if;        Disp_Declaration_Chain (Decl, Start + Indentation); -      if Get_Concurrent_Statement_Chain (Decl) /= Null_Iir then +      if Get_Has_Begin (Decl) then           Set_Col (Start);           Put_Line ("begin"); +      end if; +      if Get_Concurrent_Statement_Chain (Decl) /= Null_Iir then           Disp_Concurrent_Statement_Chain (Decl, Start + Indentation);        end if;        Set_Col (Start); -      Put_Line ("end entity;"); +      Disp_End (Decl, "entity");     end Disp_Entity_Declaration;     procedure Disp_Component_Declaration (Decl: Iir_Component_Declaration) @@ -968,7 +1040,7 @@ package body Disp_Vhdl is        Put_Line ("begin");        Disp_Concurrent_Statement_Chain (Arch, Start + Indentation);        Set_Col (Start); -      Put_Line ("end;"); +      Disp_End (Arch, "architecture");     end Disp_Architecture_Body;     procedure Disp_Object_Alias_Declaration (Decl: Iir_Object_Alias_Declaration) @@ -1583,11 +1655,15 @@ package body Disp_Vhdl is     procedure Disp_Dyadic_Operator (Expr: Iir) is     begin -      Put ("("); +      if Flag_Parenthesis then +         Put ("("); +      end if;        Disp_Expression (Get_Left (Expr));        Put (' ' & Name_Table.Image (Iirs_Utils.Get_Operator_Name (Expr)) & ' ');        Disp_Expression (Get_Right (Expr)); -      Put (")"); +      if Flag_Parenthesis then +         Put (")"); +      end if;     end Disp_Dyadic_Operator;     procedure Disp_Monadic_Operator (Expr: Iir) is @@ -1803,7 +1879,7 @@ package body Disp_Vhdl is        Set_Col (Start + Indentation);        Disp_Sequential_Statements (Get_Sequential_Statement_Chain (Process));        Set_Col (Start); -      Put_Line ("end process;"); +      Disp_End (Process, "process");     end Disp_Process_Statement;     procedure Disp_Conversion (Conv : Iir) is @@ -1992,8 +2068,8 @@ package body Disp_Vhdl is        Expr : Iir;     begin        Indent := Col; -      if Indent > 70 then -         Indent := 3; +      if Indent > Line_Length - 10 then +         Indent := 2 * Indentation;        end if;        Put ("(");        Assoc := Get_Association_Choices_Chain (Aggr); @@ -2176,6 +2252,10 @@ package body Disp_Vhdl is              Disp_Monadic_Operator (Expr);           when Iir_Kind_Function_Call =>              Disp_Function_Call (Expr); +         when Iir_Kind_Parenthesis_Expression => +            Put ("("); +            Disp_Expression (Get_Expression (Expr)); +            Put (")");           when Iir_Kind_Type_Conversion =>              Disp_Type (Get_Type (Expr));              Put (" ("); @@ -2697,12 +2777,12 @@ package body Disp_Vhdl is           when others =>              Error_Kind ("disp_design_unit2", Decl);        end case; -      New_Line (2); +      New_Line; +      New_Line;     end Disp_Design_Unit;     procedure Disp_Vhdl (An_Iir: Iir) is     begin -      Set_Line_Length (80);        -- Put (Count'Image (Line_Length));        case Get_Kind (An_Iir) is           when Iir_Kind_Design_Unit => diff --git a/errorout.adb b/errorout.adb index 588162bc6..90551fe8b 100644 --- a/errorout.adb +++ b/errorout.adb @@ -479,7 +479,7 @@ package body Errorout is           when Iir_Kind_Procedure_Call =>              return "procedure call";           when Iir_Kind_Selected_Name => -            Name_Table.Image (Get_Suffix_Identifier (Node)); +            Name_Table.Image (Get_Identifier (Node));              return '''                & Name_Table.Name_Buffer (1 .. Name_Table.Name_Length)                & '''; @@ -502,6 +502,8 @@ package body Errorout is              return "operator """                & Name_Table.Image (Iirs_Utils.Get_Operator_Name (Node))                & """"; +         when Iir_Kind_Parenthesis_Expression => +            return "expression";           when Iir_Kind_Qualified_Expression =>              return "qualified expression";           when Iir_Kind_Type_Conversion => diff --git a/evaluation.adb b/evaluation.adb index a30b1bf37..b7b53599a 100644 --- a/evaluation.adb +++ b/evaluation.adb @@ -1770,20 +1770,24 @@ package body Evaluation is           when Iir_Kind_Simple_Aggregate =>              return Expr; +         when Iir_Kind_Parenthesis_Expression => +            return Build_Constant +              (Eval_Static_Expr (Get_Expression (Expr)), Expr);           when Iir_Kind_Qualified_Expression => -            return Build_Constant (Eval_Expr (Get_Expression (Expr)), Expr); +            return Build_Constant +              (Eval_Static_Expr (Get_Expression (Expr)), Expr);           when Iir_Kind_Type_Conversion =>              return Eval_Type_Conversion (Expr);           when Iir_Kind_Range_Expression => -            Set_Left_Limit (Expr, Eval_Expr (Get_Left_Limit (Expr))); -            Set_Right_Limit (Expr, Eval_Expr (Get_Right_Limit (Expr))); +            Set_Left_Limit (Expr, Eval_Static_Expr (Get_Left_Limit (Expr))); +            Set_Right_Limit (Expr, Eval_Static_Expr (Get_Right_Limit (Expr)));              return Expr;           when Iir_Kinds_Monadic_Operator =>              declare                 Operand : Iir;              begin -               Operand := Eval_Expr (Get_Operand (Expr)); +               Operand := Eval_Static_Expr (Get_Operand (Expr));                 Set_Operand (Expr, Operand);                 return Eval_Monadic_Operator (Expr, Operand);              end; @@ -1791,8 +1795,8 @@ package body Evaluation is              declare                 Left, Right : Iir;              begin -               Left := Eval_Expr (Get_Left (Expr)); -               Right := Eval_Expr (Get_Right (Expr)); +               Left := Eval_Static_Expr (Get_Left (Expr)); +               Right := Eval_Static_Expr (Get_Right (Expr));                 Set_Left (Expr, Left);                 Set_Right (Expr, Right); @@ -2067,16 +2071,15 @@ package body Evaluation is             | Iir_Kind_Character_Literal             | Iir_Kind_Selected_Name =>              declare +               Orig : constant Iir := Get_Named_Entity (Expr);                 Res : Iir; -               Orig : Iir;              begin -               Orig := Get_Named_Entity (Expr);                 Res := Eval_Static_Expr (Orig);                 if Res /= Orig then -                  Location_Copy (Res, Expr); +                  return Build_Constant (Res, Expr); +               else +                  return Res;                 end if; -               Free_Name (Expr); -               return Res;              end;           when Iir_Kind_Error =>              return Expr; @@ -437,6 +437,7 @@ package body Iirs is             | Iir_Kind_Exponentiation_Operator             | Iir_Kind_Function_Call             | Iir_Kind_Aggregate +           | Iir_Kind_Parenthesis_Expression             | Iir_Kind_Qualified_Expression             | Iir_Kind_Type_Conversion             | Iir_Kind_Allocator_By_Expression @@ -2382,6 +2383,7 @@ package body Iirs is             | Iir_Kind_Exponentiation_Operator             | Iir_Kind_Function_Call             | Iir_Kind_Aggregate +           | Iir_Kind_Parenthesis_Expression             | Iir_Kind_Qualified_Expression             | Iir_Kind_Type_Conversion             | Iir_Kind_Allocator_By_Expression @@ -3235,50 +3237,6 @@ package body Iirs is        Set_Field2 (Target, El);     end Set_Selected_Element; -   procedure Check_Kind_For_Suffix_Identifier (Target : Iir) is -   begin -      case Get_Kind (Target) is -         when Iir_Kind_Selected_Name => -            null; -         when others => -            Failed ("Suffix_Identifier", Target); -      end case; -   end Check_Kind_For_Suffix_Identifier; - -   function Get_Suffix_Identifier (Target : Iir) return Name_Id is -   begin -      Check_Kind_For_Suffix_Identifier (Target); -      return Iir_To_Name_Id (Get_Field2 (Target)); -   end Get_Suffix_Identifier; - -   procedure Set_Suffix_Identifier (Target : Iir; Ident : Name_Id) is -   begin -      Check_Kind_For_Suffix_Identifier (Target); -      Set_Field2 (Target, Name_Id_To_Iir (Ident)); -   end Set_Suffix_Identifier; - -   procedure Check_Kind_For_Attribute_Identifier (Target : Iir) is -   begin -      case Get_Kind (Target) is -         when Iir_Kind_Attribute_Name => -            null; -         when others => -            Failed ("Attribute_Identifier", Target); -      end case; -   end Check_Kind_For_Attribute_Identifier; - -   function Get_Attribute_Identifier (Target : Iir) return Name_Id is -   begin -      Check_Kind_For_Attribute_Identifier (Target); -      return Iir_To_Name_Id (Get_Field2 (Target)); -   end Get_Attribute_Identifier; - -   procedure Set_Attribute_Identifier (Target : Iir; Ident : Name_Id) is -   begin -      Check_Kind_For_Attribute_Identifier (Target); -      Set_Field2 (Target, Name_Id_To_Iir (Ident)); -   end Set_Attribute_Identifier; -     procedure Check_Kind_For_Use_Clause_Chain (Target : Iir) is     begin        case Get_Kind (Target) is @@ -3542,7 +3500,9 @@ package body Iirs is             | Iir_Kind_Case_Statement             | Iir_Kind_Procedure_Call_Statement             | Iir_Kind_If_Statement -           | Iir_Kind_Simple_Name => +           | Iir_Kind_Simple_Name +           | Iir_Kind_Selected_Name +           | Iir_Kind_Attribute_Name =>              null;           when others =>              Failed ("Identifier", Target); @@ -5168,6 +5128,7 @@ package body Iirs is             | Iir_Kind_Choice_By_Range             | Iir_Kind_Attribute_Specification             | Iir_Kind_Disconnection_Specification +           | Iir_Kind_Parenthesis_Expression             | Iir_Kind_Qualified_Expression             | Iir_Kind_Type_Conversion             | Iir_Kind_Allocator_By_Expression @@ -5923,6 +5884,7 @@ package body Iirs is             | Iir_Kind_Exponentiation_Operator             | Iir_Kind_Function_Call             | Iir_Kind_Aggregate +           | Iir_Kind_Parenthesis_Expression             | Iir_Kind_Qualified_Expression             | Iir_Kind_Type_Conversion             | Iir_Kind_Allocator_By_Expression @@ -6354,13 +6316,13 @@ package body Iirs is     function Get_Prefix (Target : Iir) return Iir is     begin        Check_Kind_For_Prefix (Target); -      return Get_Field3 (Target); +      return Get_Field0 (Target);     end Get_Prefix;     procedure Set_Prefix (Target : Iir; Prefix : Iir) is     begin        Check_Kind_For_Prefix (Target); -      Set_Field3 (Target, Prefix); +      Set_Field0 (Target, Prefix);     end Set_Prefix;     procedure Check_Kind_For_Suffix (Target : Iir) is @@ -7195,13 +7157,13 @@ package body Iirs is     function Get_Simple_Name_Identifier (Target : Iir) return Name_Id is     begin        Check_Kind_For_Simple_Name_Identifier (Target); -      return Iir_To_Name_Id (Get_Field2 (Target)); +      return Iir_To_Name_Id (Get_Field3 (Target));     end Get_Simple_Name_Identifier;     procedure Set_Simple_Name_Identifier (Target : Iir; Ident : Name_Id) is     begin        Check_Kind_For_Simple_Name_Identifier (Target); -      Set_Field2 (Target, Name_Id_To_Iir (Ident)); +      Set_Field3 (Target, Name_Id_To_Iir (Ident));     end Set_Simple_Name_Identifier;     procedure Check_Kind_For_Protected_Type_Body (Target : Iir) is @@ -7366,6 +7328,109 @@ package body Iirs is        Set_Flag6 (Decl, Val);     end Set_Use_Flag; +   procedure Check_Kind_For_End_Has_Reserved_Id (Target : Iir) is +   begin +      case Get_Kind (Target) is +         when Iir_Kind_Protected_Type_Declaration +           | Iir_Kind_Record_Type_Definition +           | Iir_Kind_Physical_Type_Definition +           | Iir_Kind_Protected_Type_Body +           | Iir_Kind_Configuration_Declaration +           | Iir_Kind_Entity_Declaration +           | Iir_Kind_Package_Declaration +           | Iir_Kind_Package_Body +           | Iir_Kind_Architecture_Body +           | Iir_Kind_Package_Instantiation_Declaration +           | Iir_Kind_Component_Declaration +           | Iir_Kind_Function_Body +           | Iir_Kind_Procedure_Body +           | Iir_Kind_Sensitized_Process_Statement +           | Iir_Kind_Process_Statement +           | Iir_Kind_Block_Statement +           | Iir_Kind_Generate_Statement => +            null; +         when others => +            Failed ("End_Has_Reserved_Id", Target); +      end case; +   end Check_Kind_For_End_Has_Reserved_Id; + +   function Get_End_Has_Reserved_Id (Decl : Iir) return Boolean is +   begin +      Check_Kind_For_End_Has_Reserved_Id (Decl); +      return Get_Flag8 (Decl); +   end Get_End_Has_Reserved_Id; + +   procedure Set_End_Has_Reserved_Id (Decl : Iir; Flag : Boolean) is +   begin +      Check_Kind_For_End_Has_Reserved_Id (Decl); +      Set_Flag8 (Decl, Flag); +   end Set_End_Has_Reserved_Id; + +   procedure Check_Kind_For_End_Has_Identifier (Target : Iir) is +   begin +      case Get_Kind (Target) is +         when Iir_Kind_Protected_Type_Declaration +           | Iir_Kind_Record_Type_Definition +           | Iir_Kind_Physical_Type_Definition +           | Iir_Kind_Protected_Type_Body +           | Iir_Kind_Configuration_Declaration +           | Iir_Kind_Entity_Declaration +           | Iir_Kind_Package_Declaration +           | Iir_Kind_Package_Body +           | Iir_Kind_Architecture_Body +           | Iir_Kind_Package_Instantiation_Declaration +           | Iir_Kind_Component_Declaration +           | Iir_Kind_Function_Body +           | Iir_Kind_Procedure_Body +           | Iir_Kind_Sensitized_Process_Statement +           | Iir_Kind_Process_Statement +           | Iir_Kind_Block_Statement +           | Iir_Kind_Generate_Statement +           | Iir_Kind_For_Loop_Statement +           | Iir_Kind_While_Loop_Statement +           | Iir_Kind_Case_Statement +           | Iir_Kind_If_Statement +           | Iir_Kind_Elsif => +            null; +         when others => +            Failed ("End_Has_Identifier", Target); +      end case; +   end Check_Kind_For_End_Has_Identifier; + +   function Get_End_Has_Identifier (Decl : Iir) return Boolean is +   begin +      Check_Kind_For_End_Has_Identifier (Decl); +      return Get_Flag9 (Decl); +   end Get_End_Has_Identifier; + +   procedure Set_End_Has_Identifier (Decl : Iir; Flag : Boolean) is +   begin +      Check_Kind_For_End_Has_Identifier (Decl); +      Set_Flag9 (Decl, Flag); +   end Set_End_Has_Identifier; + +   procedure Check_Kind_For_Has_Begin (Target : Iir) is +   begin +      case Get_Kind (Target) is +         when Iir_Kind_Entity_Declaration => +            null; +         when others => +            Failed ("Has_Begin", Target); +      end case; +   end Check_Kind_For_Has_Begin; + +   function Get_Has_Begin (Decl : Iir) return Boolean is +   begin +      Check_Kind_For_Has_Begin (Decl); +      return Get_Flag10 (Decl); +   end Get_Has_Begin; + +   procedure Set_Has_Begin (Decl : Iir; Flag : Boolean) is +   begin +      Check_Kind_For_Has_Begin (Decl); +      Set_Flag10 (Decl, Flag); +   end Set_Has_Begin; +     procedure Check_Kind_For_Psl_Property (Target : Iir) is     begin        case Get_Kind (Target) is @@ -200,10 +200,10 @@ package Iirs is     -- Iir_Kind_Character_Literal (Short)     -- -   --   Get/Set_Identifier (Field3) -   --     --   Get/Set_Type (Field1)     -- +   --   Get/Set_Identifier (Field3) +   --     --   Get/Set_Named_Entity (Field4)     --     --   Get/Set_Base_Name (Field5) @@ -565,12 +565,12 @@ package Iirs is     -- Iir_Kind_Selected_Element (Short)     -- A record element selection.     -- +   --   Get/Set_Prefix (Field0) +   --     --   Get/Set_Type (Field1)     --     --   Get/Set_Selected_Element (Field2)     -- -   --   Get/Set_Prefix (Field3) -   --     --   Get/Set_Base_Name (Field5)     --     --   Get/Set_Expr_Staticness (State1) @@ -581,9 +581,9 @@ package Iirs is     -- Iir_Kind_Dereference (Short)     -- An implicit access dereference.     -- -   --   Get/Set_Type (Field1) +   --   Get/Set_Prefix (Field0)     -- -   --   Get/Set_Prefix (Field3) +   --   Get/Set_Type (Field1)     --     --   Get/Set_Base_Name (Field5)     -- @@ -599,11 +599,11 @@ package Iirs is     -- Iir_Kind_Signature (Short)     -- +   --   Get/Set_Prefix (Field0) +   --     --   Get/Set_Return_Type (Field1)     --     --   Get/Set_Type_Marks_List (Field2) -   -- -   --   Get/Set_Prefix (Field3)     -- Iir_Kind_Overload_List (Short)     -- @@ -633,6 +633,12 @@ package Iirs is     --   Get/Set_Visible_Flag (Flag4)     --     --   Get/Set_Is_Within_Flag (Flag5) +   -- +   --   Get/Set_End_Has_Reserved_Id (Flag8) +   -- +   --   Get/Set_End_Has_Identifier (Flag9) +   -- +   --   Get/Set_Has_Begin (Flag10)     -- Iir_Kind_Architecture_Body (Medium)     -- @@ -661,6 +667,10 @@ package Iirs is     --   Get/Set_Visible_Flag (Flag4)     --     --   Get/Set_Is_Within_Flag (Flag5) +   -- +   --   Get/Set_End_Has_Reserved_Id (Flag8) +   -- +   --   Get/Set_End_Has_Identifier (Flag9)     -- Iir_Kind_Configuration_Declaration (Medium)     -- @@ -682,6 +692,10 @@ package Iirs is     --   Get/Set_Entity_Name (Field7)     --     --   Get/Set_Visible_Flag (Flag4) +   -- +   --   Get/Set_End_Has_Reserved_Id (Flag8) +   -- +   --   Get/Set_End_Has_Identifier (Flag9)     -- Iir_Kind_Package_Header (Medium)     -- @@ -707,6 +721,10 @@ package Iirs is     --   Get/Set_Need_Body (Flag1)     --     --   Get/Set_Visible_Flag (Flag4) +   -- +   --   Get/Set_End_Has_Reserved_Id (Flag8) +   -- +   --   Get/Set_End_Has_Identifier (Flag9)     -- Iir_Kind_Package_Body (Short)     -- Note: a body is not a declaration, that's the reason why there is no @@ -721,6 +739,10 @@ package Iirs is     --     -- The corresponding package declaration.     --   Get/Set_Package (Field4) +   -- +   --   Get/Set_End_Has_Reserved_Id (Flag8) +   -- +   --   Get/Set_End_Has_Identifier (Flag9)     -- Iir_Kind_Package_Instantiation_Declaration (Medium)     -- @@ -736,6 +758,10 @@ package Iirs is     --   Get/Set_Generic_Map_Aspect_Chain (Field8)     --     --   Get/Set_Visible_Flag (Flag4) +   -- +   --   Get/Set_End_Has_Reserved_Id (Flag8) +   -- +   --   Get/Set_End_Has_Identifier (Flag9)     -- Iir_Kind_Library_Declaration (Medium)     -- @@ -771,6 +797,10 @@ package Iirs is     --   Get/Set_Visible_Flag (Flag4)     --     --   Get/Set_Use_Flag (Flag6) +   -- +   --   Get/Set_End_Has_Reserved_Id (Flag8) +   -- +   --   Get/Set_End_Has_Identifier (Flag9)     -- Iir_Kind_Object_Alias_Declaration (Short)     -- @@ -1033,6 +1063,10 @@ package Iirs is     --   Get/Set_Subprogram_Specification (Field4)     --     --   Get/Set_Sequential_Statement_Chain (Field5) +   -- +   --   Get/Set_End_Has_Reserved_Id (Flag8) +   -- +   --   Get/Set_End_Has_Identifier (Flag9)     -- Iir_Kind_Implicit_Procedure_Declaration (Medium)     -- Iir_Kind_Implicit_Function_Declaration (Medium) @@ -1548,6 +1582,10 @@ package Iirs is     --   Get/Set_Has_Signal_Flag (Flag3)     --     --   Get/Set_Type_Staticness (State1) +   -- +   --   Get/Set_End_Has_Reserved_Id (Flag8) +   -- +   --   Get/Set_End_Has_Identifier (Flag9)     -- Iir_Kind_Unit_Declaration (Medium)     -- @@ -1624,6 +1662,10 @@ package Iirs is     --   Get/Set_Signal_Type_Flag (Flag2)     --     --   Get/Set_Has_Signal_Flag (Flag3) +   -- +   --   Get/Set_End_Has_Reserved_Id (Flag8) +   -- +   --   Get/Set_End_Has_Identifier (Flag9)     -- Iir_Kind_Access_Type_Definition (Short)     -- @@ -1695,6 +1737,10 @@ package Iirs is     --   Get/Set_Resolved_Flag (Flag1)     --     --   Get/Set_Signal_Type_Flag (Flag2) +   -- +   --   Get/Set_End_Has_Reserved_Id (Flag8) +   -- +   --   Get/Set_End_Has_Identifier (Flag9)     -- Iir_Kind_Protected_Type_Body (Short)     -- @@ -1707,6 +1753,10 @@ package Iirs is     --   Get/Set_Identifier (Field3)     --     --   Get/Set_Protected_Type_Declaration (Field4) +   -- +   --   Get/Set_End_Has_Reserved_Id (Flag8) +   -- +   --   Get/Set_End_Has_Identifier (Flag9)     -------------------------     -- subtype definitions -- @@ -1948,6 +1998,10 @@ package Iirs is     --   Get/Set_Visible_Flag (Flag4)     --     --   Get/Set_Is_Within_Flag (Flag5) +   -- +   --   Get/Set_End_Has_Reserved_Id (Flag8) +   -- +   --   Get/Set_End_Has_Identifier (Flag9)     -- Iir_Kind_Concurrent_Assertion_Statement (Medium)     -- @@ -2068,6 +2122,10 @@ package Iirs is     --   Get/Set_Visible_Flag (Flag4)     --     --   Get/Set_Is_Within_Flag (Flag5) +   -- +   --   Get/Set_End_Has_Reserved_Id (Flag8) +   -- +   --   Get/Set_End_Has_Identifier (Flag9)     -- Iir_Kind_Generate_Statement (Medium)     -- @@ -2093,6 +2151,10 @@ package Iirs is     --   Get/Set_Generate_Block_Configuration (Field7)     --     --   Get/Set_Visible_Flag (Flag4) +   -- +   --   Get/Set_End_Has_Reserved_Id (Flag8) +   -- +   --   Get/Set_End_Has_Identifier (Flag9)     -- Iir_Kind_Simple_Simultaneous_Statement (Medium)     -- @@ -2145,6 +2207,8 @@ package Iirs is     --     -- Only for Iir_Kind_If_Statement:     --   Get/Set_Visible_Flag (Flag4) +   -- +   --   Get/Set_End_Has_Identifier (Flag9)     -- Iir_Kind_For_Loop_Statement (Short)     -- @@ -2164,6 +2228,8 @@ package Iirs is     --   Get/Set_Visible_Flag (Flag4)     --     --   Get/Set_Is_Within_Flag (Flag5) +   -- +   --   Get/Set_End_Has_Identifier (Flag9)     -- Iir_Kind_While_Loop_Statement (Short)     -- @@ -2181,6 +2247,8 @@ package Iirs is     --   Get/Set_Sequential_Statement_Chain (Field5)     --     --   Get/Set_Visible_Flag (Flag4) +   -- +   --   Get/Set_End_Has_Identifier (Flag9)     -- Iir_Kind_Exit_Statement (Short)     -- Iir_Kind_Next_Statement (Short) @@ -2336,6 +2404,8 @@ package Iirs is     --   Get/Set_Expression (Field5)     --     --   Get/Set_Visible_Flag (Flag4) +   -- +   --   Get/Set_End_Has_Identifier (Flag9)     -- Iir_Kind_Procedure_Call_Statement (Short)     -- Iir_Kind_Concurrent_Procedure_Call_Statement (Short) @@ -2471,6 +2541,14 @@ package Iirs is     -- True if the choice list has an 'others' choice.     --   Get/Set_Aggr_Others_Flag (Flag2) +   -- Iir_Kind_Parenthesis_Expression (Short) +   -- +   --   Get/Set_Type (Field1) +   -- +   --   Get/Set_Expression (Field5) +   -- +   --   Get/Set_Expr_Staticness (State1) +     -- Iir_Kind_Qualified_Expression (Short)     --     --   Get/Set_Type (Field1) @@ -2524,11 +2602,11 @@ package Iirs is     -- Iir_Kind_Selected_Name (Short)     -- -   --   Get/Set_Type (Field1) +   --   Get/Set_Prefix (Field0)     -- -   --   Get/Set_Suffix_Identifier (Field2) +   --   Get/Set_Type (Field1)     -- -   --   Get/Set_Prefix (Field3) +   --   Get/Set_Identifier (Field3)     --     --   Get/Set_Named_Entity (Field4)     -- @@ -2538,9 +2616,9 @@ package Iirs is     -- Iir_Kind_Selected_By_All_Name (Short)     -- -   --   Get/Set_Type (Field1) +   --   Get/Set_Prefix (Field0)     -- -   --   Get/Set_Prefix (Field3) +   --   Get/Set_Type (Field1)     --     --   Get/Set_Named_Entity (Field4)     -- @@ -2559,12 +2637,12 @@ package Iirs is     -- Iir_Kind_Indexed_Name (Short)     -- Select the element designed with the INDEX_LIST from array PREFIX.     -- +   --   Get/Set_Prefix (Field0) +   --     --   Get/Set_Type (Field1)     --     --   Get/Set_Index_List (Field2)     -- -   --   Get/Set_Prefix (Field3) -   --     --   Get/Set_Base_Name (Field5)     --     --   Get/Set_Expr_Staticness (State1) @@ -2573,12 +2651,12 @@ package Iirs is     -- Iir_Kind_Slice_Name (Short)     -- +   --   Get/Set_Prefix (Field0) +   --     --   Get/Set_Type (Field1)     --     --   Get/Set_Suffix (Field2)     -- -   --   Get/Set_Prefix (Field3) -   --     --   Get/Set_Base_Name (Field5)     --     --   Get/Set_Expr_Staticness (State1) @@ -2590,13 +2668,13 @@ package Iirs is     -- either a function call, an indexed array, a type conversion or a slice     -- name.     -- +   --   Get/Set_Prefix (Field0) +   --     -- Always returns null_iir.     --   Get/Set_Type (Field1)     --     --   Get/Set_Association_Chain (Field2)     -- -   --   Get/Set_Prefix (Field3) -   --     --   Get/Set_Named_Entity (Field4)     ---------------- @@ -2605,11 +2683,11 @@ package Iirs is     -- Iir_Kind_Attribute_Name (Short)     -- -   --   Get/Set_Type (Field1) +   --   Get/Set_Prefix (Field0)     -- -   --   Get/Set_Attribute_Identifier (Field2) +   --   Get/Set_Type (Field1)     -- -   --   Get/Set_Prefix (Field3) +   --   Get/Set_Identifier (Field3)     --     --   Get/Set_Named_Entity (Field4)     -- @@ -2619,9 +2697,9 @@ package Iirs is     -- Iir_Kind_Base_Attribute (Short)     -- -   --   Get/Set_Type (Field1) +   --   Get/Set_Prefix (Field0)     -- -   --   Get/Set_Prefix (Field3) +   --   Get/Set_Type (Field1)     -- Iir_Kind_Left_Type_Attribute (Short)     -- Iir_Kind_Right_Type_Attribute (Short) @@ -2629,9 +2707,9 @@ package Iirs is     -- Iir_Kind_Low_Type_Attribute (Short)     -- Iir_Kind_Ascending_Type_Attribute (Short)     -- -   --   Get/Set_Type (Field1) +   --   Get/Set_Prefix (Field0)     -- -   --   Get/Set_Prefix (Field3) +   --   Get/Set_Type (Field1)     --     --   Get/Set_Base_Name (Field5)     -- @@ -2648,12 +2726,12 @@ package Iirs is     -- Iir_Kind_Ascending_Array_Attribute (Short)     -- Iir_Kind_Length_Array_Attribute (Short)     -- +   --   Get/Set_Prefix (Field0) +   --     --   Get/Set_Type (Field1)     --     --   Get/Set_Index_Subtype (Field2)     -- -   --   Get/Set_Prefix (Field3) -   --     --   Get/Set_Parameter (Field4)     --     --   Get/Set_Base_Name (Field5) @@ -2668,12 +2746,12 @@ package Iirs is     -- Iir_Kind_Transaction_Attribute (Short)     -- (Iir_Kinds_Signal_Attribute)     -- +   --   Get/Set_Prefix (Field0) +   --     --   Get/Set_Type (Field1)     --     --   Get/Set_Chain (Field2)     -- -   --   Get/Set_Prefix (Field3) -   --     -- Not used by Iir_Kind_Transaction_Attribute     --   Get/Set_Parameter (Field4)     -- @@ -2693,9 +2771,9 @@ package Iirs is     -- Iir_Kind_Driving_Attribute (Short)     -- Iir_Kind_Driving_Value_Attribute (Short)     -- -   --   Get/Set_Type (Field1) +   --   Get/Set_Prefix (Field0)     -- -   --   Get/Set_Prefix (Field3) +   --   Get/Set_Type (Field1)     --     --   Get/Set_Expr_Staticness (State1)     -- @@ -2708,9 +2786,9 @@ package Iirs is     -- Iir_Kind_Leftof_Attribute (Short)     -- Iir_Kind_Rightof_Attribute (Short)     -- -   --   Get/Set_Type (Field1) +   --   Get/Set_Prefix (Field0)     -- -   --   Get/Set_Prefix (Field3) +   --   Get/Set_Type (Field1)     --     --   Get/Set_Parameter (Field4)     -- @@ -2723,9 +2801,9 @@ package Iirs is     -- Iir_Kind_Image_Attribute (Short)     -- Iir_Kind_Value_Attribute (Short)     -- -   --   Get/Set_Type (Field1) +   --   Get/Set_Prefix (Field0)     -- -   --   Get/Set_Prefix (Field3) +   --   Get/Set_Type (Field1)     --     --   Get/Set_Parameter (Field4)     -- @@ -2739,12 +2817,12 @@ package Iirs is     -- Iir_Kind_Instance_Name_Attribute (Short)     -- Iir_Kind_Path_Name_Attribute (Short)     -- +   --   Get/Set_Prefix (Field0) +   --     --   Get/Set_Type (Field1)     --     -- Only for Iir_Kind_Simple_Name_Attribute: -   --   Get/Set_Simple_Name_Identifier (Field2) -   -- -   --   Get/Set_Prefix (Field3) +   --   Get/Set_Simple_Name_Identifier (Field3)     --     --   Get/Set_Base_Name (Field5)     -- @@ -2957,6 +3035,7 @@ package Iirs is         Iir_Kind_Exponentiation_Operator,         Iir_Kind_Function_Call,         Iir_Kind_Aggregate, +       Iir_Kind_Parenthesis_Expression,         Iir_Kind_Qualified_Expression,         Iir_Kind_Type_Conversion,         Iir_Kind_Allocator_By_Expression, @@ -4828,14 +4907,6 @@ package Iirs is     function Get_Selected_Element (Target : Iir) return Iir;     procedure Set_Selected_Element (Target : Iir; El : Iir); -   --  Field: Field2 (uc) -   function Get_Suffix_Identifier (Target : Iir) return Name_Id; -   procedure Set_Suffix_Identifier (Target : Iir; Ident : Name_Id); - -   --  Field: Field2 (uc) -   function Get_Attribute_Identifier (Target : Iir) return Name_Id; -   procedure Set_Attribute_Identifier (Target : Iir; Ident : Name_Id); -     --  Selected names of an use_clause are chained.     --  Field: Field3     function Get_Use_Clause_Chain (Target : Iir) return Iir; @@ -5360,7 +5431,7 @@ package Iirs is     procedure Set_Name_Staticness (Target : Iir; Static : Iir_Staticness);     --  Prefix of a name. -   --  Field: Field3 +   --  Field: Field0     function Get_Prefix (Target : Iir) return Iir;     procedure Set_Prefix (Target : Iir; Prefix : Iir); @@ -5538,7 +5609,7 @@ package Iirs is     procedure Set_Overload_List (Target : Iir; List : Iir_List);     --  Identifier of the simple_name attribute. -   --  Field: Field2 (uc) +   --  Field: Field3 (uc)     function Get_Simple_Name_Identifier (Target : Iir) return Name_Id;     procedure Set_Simple_Name_Identifier (Target : Iir; Ident : Name_Id); @@ -5572,6 +5643,21 @@ package Iirs is     function Get_Use_Flag (Decl : Iir) return Boolean;     procedure Set_Use_Flag (Decl : Iir; Val : Boolean); +   --  Layout flag: true if 'end' is followed by the reserved identifier. +   --  Field: Flag8 +   function Get_End_Has_Reserved_Id (Decl : Iir) return Boolean; +   procedure Set_End_Has_Reserved_Id (Decl : Iir; Flag : Boolean); + +   --  Layout flag: true if 'end' is followed by the identifier. +   --  Field: Flag9 +   function Get_End_Has_Identifier (Decl : Iir) return Boolean; +   procedure Set_End_Has_Identifier (Decl : Iir; Flag : Boolean); + +   --  Layout flag: true if 'begin' is present. +   --  Field: Flag10 +   function Get_Has_Begin (Decl : Iir) return Boolean; +   procedure Set_Has_Begin (Decl : Iir; Flag : Boolean); +     --  Field: Field1 (uc)     function Get_Psl_Property (Decl : Iir) return PSL_Node;     procedure Set_Psl_Property (Decl : Iir; Prop : PSL_Node); diff --git a/iirs_utils.adb b/iirs_utils.adb index 8bbaf9b16..d307febda 100644 --- a/iirs_utils.adb +++ b/iirs_utils.adb @@ -657,10 +657,9 @@ package body Iirs_Utils is        Name : constant Iir := Get_Entity_Name (Arch);     begin        case Get_Kind (Name) is -         when Iir_Kind_Simple_Name => +         when Iir_Kind_Simple_Name +           | Iir_Kind_Selected_Name =>              return Get_Identifier (Name); -         when Iir_Kind_Selected_Name => -            return Get_Suffix_Identifier (Name);           when others =>              Error_Kind ("get_entity_identifier_of_architecture", Name);        end case; @@ -734,7 +733,7 @@ package body Iirs_Utils is        if Get_Kind (Attr) /= Iir_Kind_Attribute_Name then           return False;        end if; -      Id := Get_Attribute_Identifier (Attr); +      Id := Get_Identifier (Attr);        return Id = Name_Range or Id = Name_Reverse_Range;     end Is_Range_Attribute_Name; diff --git a/libraries.adb b/libraries.adb index e37689ca6..d99b4d268 100644 --- a/libraries.adb +++ b/libraries.adb @@ -1343,7 +1343,7 @@ package body Libraries is              begin                 Lib := Get_Library (Get_Identifier (Get_Prefix (Unit)),                                     Get_Location (Unit)); -               return Find_Primary_Unit (Lib, Get_Suffix_Identifier (Unit)); +               return Find_Primary_Unit (Lib, Get_Identifier (Unit));              end;           when Iir_Kind_Entity_Aspect_Entity =>              return Find_Secondary_Unit @@ -333,6 +333,36 @@ package body Nodes is        Nodet.Table (N).Flag7 := V;     end Set_Flag7; +   function Get_Flag8 (N : Node_Type) return Boolean is +   begin +      return Nodet.Table (N).Flag8; +   end Get_Flag8; + +   procedure Set_Flag8 (N : Node_Type; V : Boolean) is +   begin +      Nodet.Table (N).Flag8 := V; +   end Set_Flag8; + +   function Get_Flag9 (N : Node_Type) return Boolean is +   begin +      return Nodet.Table (N).Flag9; +   end Get_Flag9; + +   procedure Set_Flag9 (N : Node_Type; V : Boolean) is +   begin +      Nodet.Table (N).Flag9 := V; +   end Set_Flag9; + +   function Get_Flag10 (N : Node_Type) return Boolean is +   begin +      return Nodet.Table (N).Flag10; +   end Get_Flag10; + +   procedure Set_Flag10 (N : Node_Type; V : Boolean) is +   begin +      Nodet.Table (N).Flag10 := V; +   end Set_Flag10; +     function Get_State1 (N : Node_Type) return Bit2_Type is     begin @@ -62,6 +62,9 @@ package Nodes is     --   Flag5 : Boolean     --   Flag6 : Boolean     --   Flag7 : Boolean +   --   Flag8 : Boolean +   --   Flag9 : Boolean +   --   Flag10 : Boolean     --   Nkind : Kind_Type     --   State1 : Bit2_Type     --   State2 : Bit2_Type @@ -211,6 +214,21 @@ package Nodes is     procedure Set_Flag7 (N : Node_Type; V : Boolean);     pragma Inline (Set_Flag7); +   function Get_Flag8 (N : Node_Type) return Boolean; +   pragma Inline (Get_Flag8); +   procedure Set_Flag8 (N : Node_Type; V : Boolean); +   pragma Inline (Set_Flag8); + +   function Get_Flag9 (N : Node_Type) return Boolean; +   pragma Inline (Get_Flag9); +   procedure Set_Flag9 (N : Node_Type; V : Boolean); +   pragma Inline (Set_Flag9); + +   function Get_Flag10 (N : Node_Type) return Boolean; +   pragma Inline (Get_Flag10); +   procedure Set_Flag10 (N : Node_Type; V : Boolean); +   pragma Inline (Set_Flag10); +     function Get_State1 (N : Node_Type) return Bit2_Type;     pragma Inline (Get_State1); @@ -147,6 +147,7 @@ package body Parse is              Error_Msg_Parse                ("mispelling, """ & Name_Table.Image (Name) & """ expected");           else +            Set_End_Has_Identifier (Decl, True);              Xrefs.Xref_End (Get_Token_Location, Decl);           end if;        end if; @@ -803,7 +804,7 @@ package body Parse is                    return Null_Iir;                 end if;                 Res := Create_Iir (Iir_Kind_Attribute_Name); -               Set_Attribute_Identifier (Res, Current_Identifier); +               Set_Identifier (Res, Current_Identifier);                 Set_Location (Res);                 if Get_Kind (Prefix) = Iir_Kind_Signature then                    Set_Signature (Res, Prefix); @@ -845,12 +846,12 @@ package body Parse is                       Res := Create_Iir (Iir_Kind_Selected_Name);                       Set_Location (Res);                       Set_Prefix (Res, Prefix); -                     Set_Suffix_Identifier (Res, Current_Identifier); +                     Set_Identifier (Res, Current_Identifier);                    when Tok_String =>                       Res := Create_Iir (Iir_Kind_Selected_Name);                       Set_Location (Res);                       Set_Prefix (Res, Prefix); -                     Set_Suffix_Identifier +                     Set_Identifier                         (Res, Scan_To_Operator_Name (Get_Token_Location));                    when others =>                       Error_Msg_Parse ("an identifier or all is expected"); @@ -1000,7 +1001,7 @@ package body Parse is              Lexical_Layout := 0;           else              Is_Default := False; -            Lexical_Layout := Iir_Lexical_Has_Mode; +            Lexical_Layout := Iir_Lexical_Has_Class;              Scan;           end if; @@ -1683,7 +1684,7 @@ package body Parse is           Scan_Expect (Tok_Body);        end if;        Scan; -      Check_End_Name (Decl); +      Check_End_Name (Ident, Res);        return Decl;     end Parse_Protected_Type_Definition; @@ -1770,7 +1771,7 @@ package body Parse is                          Error_Msg_Parse                            ("simple_name not allowed here in vhdl87");                       end if; -                     Check_End_Name (Decl); +                     Check_End_Name (Get_Identifier (Decl), Unit_Def);                    end if;                    if Def /= Null_Iir then                       Set_Type (Def, Unit_Def); @@ -1784,12 +1785,13 @@ package body Parse is              Decl := Create_Iir (Iir_Kind_Type_Declaration);              Set_Identifier (Decl, Ident);              Set_Location (Decl, Loc); -            Set_Type_Definition (Decl, Parse_Record_Definition); +            Def := Parse_Record_Definition; +            Set_Type_Definition (Decl, Def);              if Current_Token = Tok_Identifier then                 if Flags.Vhdl_Std = Vhdl_87 then                    Error_Msg_Parse ("simple_name not allowed here in vhdl87");                 end if; -               Check_End_Name (Decl); +               Check_End_Name (Get_Identifier (Decl), Def);              end if;           when Tok_Access =>              Def := Parse_Access_Definition; @@ -3374,6 +3376,7 @@ package body Parse is        Parse_Declarative_Part (Res);        if Current_Token = Tok_Begin then +         Set_Has_Begin (Res, True);           Scan;           Parse_Concurrent_Statements (Res);        end if; @@ -3387,6 +3390,7 @@ package body Parse is           if Flags.Vhdl_Std = Vhdl_87 then              Error_Msg_Parse ("""entity"" keyword not allowed here by vhdl 87");           end if; +         Set_End_Has_Reserved_Id (Res, True);           Scan;        end if;        Check_End_Name (Res); @@ -3486,7 +3490,7 @@ package body Parse is     is        use Iir_Chains.Association_Choices_Chain_Handling;        Expr: Iir; -      Res: Iir_Aggregate; +      Res: Iir;        Last : Iir;        Assoc: Iir;        Loc : Location_Type; @@ -3506,9 +3510,19 @@ package body Parse is                 null;              when Tok_Right_Paren =>                 -- This was just a braced expression. +                 -- Eat ')'.                 Scan; -               return Expr; + +               if Flag_Parse_Parenthesis then +                  --  Create a node for the parenthesis. +                  Res := Create_Iir (Iir_Kind_Parenthesis_Expression); +                  Set_Location (Res, Loc); +                  Set_Expression (Res, Expr); +                  return Res; +               else +                  return Expr; +               end if;              when Tok_Semi_Colon =>                 --  Surely a missing parenthesis.                 --  FIXME: in case of multiple missing parenthesises, several @@ -5159,6 +5173,7 @@ package body Parse is        else           Expect (Tok_Process);           Scan; +         Set_End_Has_Reserved_Id (Res, True);           Check_End_Name (Res);           Expect (Tok_Semi_Colon);        end if; @@ -5982,6 +5997,7 @@ package body Parse is              Error_Msg_Parse                ("'architecture' keyword not allowed here by vhdl 87");           end if; +         Set_End_Has_Reserved_Id (Res, True);           Scan;        end if;        Check_End_Name (Res); @@ -18,6 +18,9 @@  with Iirs; use Iirs;  package Parse is +   --  If True, create nodes for parenthesis expressions. +   Flag_Parse_Parenthesis : Boolean := False; +     -- Parse an expression.     -- (Used by PSL).     function Parse_Expression return Iir; diff --git a/sem_assocs.adb b/sem_assocs.adb index f393cfd0e..23252f5ce 100644 --- a/sem_assocs.adb +++ b/sem_assocs.adb @@ -921,7 +921,7 @@ package body Sem_Assocs is              end if;              Rec_El := Find_Name_In_List                (Get_Elements_Declaration_List (Base_Type), -               Get_Suffix_Identifier (Name)); +               Get_Identifier (Name));              if Rec_El = Null_Iir then                 Name_Type := Null_Iir;                 return; diff --git a/sem_expr.adb b/sem_expr.adb index 47764bf12..c77170a14 100644 --- a/sem_expr.adb +++ b/sem_expr.adb @@ -294,6 +294,8 @@ package body Sem_Expr is           when Iir_Kind_Allocator_By_Expression             | Iir_Kind_Allocator_By_Subtype =>              return Is_Allocator_Type (A_Type, Expr); +         when Iir_Kind_Parenthesis_Expression => +            return Is_Expr_Compatible (A_Type, Get_Expression (Expr));           when others =>              --  Error while EXPR was typed.  FIXME: should create an ERROR              --  node? @@ -355,6 +357,7 @@ package body Sem_Expr is             | Iir_Kind_Implicit_Dereference             | Iir_Kinds_Expression_Attribute             | Iir_Kind_Attribute_Value +           | Iir_Kind_Parenthesis_Expression             | Iir_Kind_Type_Conversion             | Iir_Kind_Function_Call =>              return Expr; @@ -3576,6 +3579,8 @@ package body Sem_Expr is                | Iir_Kinds_Dyadic_Operator                | Iir_Kind_Function_Call =>                 return; +            when Iir_Kind_Parenthesis_Expression => +               Obj := Get_Expression (Obj);              when Iir_Kind_Qualified_Expression =>                 return;              when Iir_Kind_Type_Conversion @@ -3829,6 +3834,21 @@ package body Sem_Expr is                 return Sem_Aggregate (Expr, A_Type);              end if; +         when Iir_Kind_Parenthesis_Expression => +            declare +               Sub_Expr : Iir; +            begin +               Sub_Expr := Get_Expression (Expr); +               Sub_Expr := Sem_Expression_Ov (Sub_Expr, A_Type1); +               if Sub_Expr = Null_Iir then +                  return Null_Iir; +               end if; +               Set_Expression (Expr, Sub_Expr); +               Set_Type (Expr, Get_Type (Sub_Expr)); +               Set_Expr_Staticness (Expr, Get_Expr_Staticness (Sub_Expr)); +               return Expr; +            end; +           when Iir_Kind_Qualified_Expression =>              declare                 N_Type: Iir; diff --git a/sem_names.adb b/sem_names.adb index 93ff0175b..8d85c0eca 100644 --- a/sem_names.adb +++ b/sem_names.adb @@ -294,7 +294,7 @@ package body Sem_Names is        Id : Name_Id;        Decl_Body : Iir;     begin -      Id := Get_Suffix_Identifier (Name); +      Id := Get_Identifier (Name);        case Get_Kind (Decl) is           when Iir_Kind_Function_Declaration             | Iir_Kind_Procedure_Declaration => @@ -1559,7 +1559,7 @@ package body Sem_Names is           Set_Named_Entity (Name, Prefix);           return;        end if; -      Suffix := Get_Suffix_Identifier (Name); +      Suffix := Get_Identifier (Name);        Res := Null_Iir; @@ -1982,9 +1982,9 @@ package body Sem_Names is          (Get_Kind (Actual) = Iir_Kind_Range_Expression           or else           (Get_Kind (Actual) = Iir_Kind_Attribute_Name -          and then (Get_Attribute_Identifier (Actual) = Std_Names.Name_Range +          and then (Get_Identifier (Actual) = Std_Names.Name_Range                      or else -                    Get_Attribute_Identifier (Actual) +                    Get_Identifier (Actual)                      = Std_Names.Name_Reverse_Range)))        then           --  A slice. @@ -2304,7 +2304,7 @@ package body Sem_Names is              Error_Kind ("sem_user_attribute", Prefix);        end case; -      Attr_Id := Get_Attribute_Identifier (Attr); +      Attr_Id := Get_Identifier (Attr);        Value := Get_Attribute_Value_Chain (Prefix);        while Value /= Null_Iir loop           Spec := Get_Attribute_Specification (Value); @@ -2334,7 +2334,7 @@ package body Sem_Names is     is        use Std_Names;        Prefix_Name : constant Iir := Get_Prefix (Attr); -      Id : constant Name_Id := Get_Attribute_Identifier (Attr); +      Id : constant Name_Id := Get_Identifier (Attr);        Prefix : Iir;        Prefix_Type : Iir;        Res : Iir; @@ -2387,7 +2387,7 @@ package body Sem_Names is        end case;        --  Create the resulting node. -      case Get_Attribute_Identifier (Attr) is +      case Get_Identifier (Attr) is           when Name_Pos =>              Res := Create_Iir (Iir_Kind_Pos_Attribute);           when Name_Val => @@ -2411,7 +2411,7 @@ package body Sem_Names is        Set_Prefix (Res, Prefix);        Set_Base_Name (Res, Res); -      case Get_Attribute_Identifier (Attr) is +      case Get_Identifier (Attr) is           when Name_Pos =>              --  LRM93 14.1              --  Result type: universal_integer. @@ -2447,7 +2447,7 @@ package body Sem_Names is     is        use Std_Names;        Prefix_Name : constant Iir := Get_Prefix (Attr); -      Id : constant Name_Id := Get_Attribute_Identifier (Attr); +      Id : constant Name_Id := Get_Identifier (Attr);        Res : Iir;        Prefix : Iir;        Prefix_Type : Iir; @@ -2489,7 +2489,7 @@ package body Sem_Names is              Set_Expr_Staticness (Res, Get_Type_Staticness (Prefix_Type));        end case; -      case Get_Attribute_Identifier (Attr) is +      case Get_Identifier (Attr) is           when Name_Ascending =>              --  LRM93 14.1              --  Result Type: type boolean. @@ -2565,7 +2565,7 @@ package body Sem_Names is           when Iir_Kind_Process_Statement =>              Error_Msg_Sem                (Disp_Node (Prefix) & " is not an appropriate prefix for '" -               & Name_Table.Image (Get_Attribute_Identifier (Attr)) +               & Name_Table.Image (Get_Identifier (Attr))                 & " attribute",                 Attr);              return Error_Mark; @@ -2583,14 +2583,14 @@ package body Sem_Names is           when others =>              Error_Msg_Sem                ("prefix of '" -               & Name_Table.Image (Get_Attribute_Identifier (Attr)) +               & Name_Table.Image (Get_Identifier (Attr))                 & " attribute must denote a constrained array subtype",                 Attr);              return Error_Mark;        end case;        Res_Type := Prefix_Type; -      case Get_Attribute_Identifier (Attr) is +      case Get_Identifier (Attr) is           when Name_Left =>              Res := Create_Iir (Iir_Kind_Left_Array_Attribute);           when Name_Right => @@ -2648,7 +2648,7 @@ package body Sem_Names is              when Iir_Kind_Function_Declaration                | Iir_Kind_Procedure_Declaration =>                 Error_Msg_Sem -                 ("'" & Name_Table.Image (Get_Attribute_Identifier (Attr)) & +                 ("'" & Name_Table.Image (Get_Identifier (Attr)) &                    " is not allowed for a signal parameter", Attr);              when others =>                 null; @@ -2676,11 +2676,11 @@ package body Sem_Names is           when others =>              Error_Msg_Sem                ("prefix of '" -               & Name_Table.Image (Get_Attribute_Identifier (Attr)) +               & Name_Table.Image (Get_Identifier (Attr))                 & " attribute must denote a signal", Attr);              return Error_Mark;        end case; -      case Get_Attribute_Identifier (Attr) is +      case Get_Identifier (Attr) is           when Name_Stable =>              Res := Sem_Signal_Signal_Attribute                (Attr, Iir_Kind_Stable_Attribute); @@ -2881,7 +2881,7 @@ package body Sem_Names is           when Iir_Kind_Signal_Interface_Declaration             | Iir_Kind_Constant_Interface_Declaration => -            if Get_Attribute_Identifier (Attr) /= Name_Simple_Name +            if Get_Identifier (Attr) /= Name_Simple_Name                and then Get_Kind (Get_Parent (Prefix))                = Iir_Kind_Component_Declaration              then @@ -2894,7 +2894,7 @@ package body Sem_Names is                             Attr);        end case; -      case Get_Attribute_Identifier (Attr) is +      case Get_Identifier (Attr) is           when Name_Simple_Name =>              Res := Create_Iir (Iir_Kind_Simple_Name_Attribute);              Eval_Simple_Name (Get_Identifier (Prefix)); @@ -2947,7 +2947,7 @@ package body Sem_Names is        --  'Simple_Name, 'Path_Name or 'Instance_Name, then the attribute name        --  denotes the attribute of the alias and not of the aliased name.        if Flags.Vhdl_Std > Vhdl_87 -        and then Get_Attribute_Identifier (Attr) in Name_Id_Name_Attributes +        and then Get_Identifier (Attr) in Name_Id_Name_Attributes        then           Sem_Name (Prefix, True);        else @@ -2984,7 +2984,7 @@ package body Sem_Names is           return;        end if; -      case Get_Attribute_Identifier (Attr) is +      case Get_Identifier (Attr) is           when Name_Base =>              Res := Sem_Base_Attribute (Attr);           when Name_Image diff --git a/translate/ghdldrv/ghdllocal.adb b/translate/ghdldrv/ghdllocal.adb index 6459f70dd..a94b27928 100644 --- a/translate/ghdldrv/ghdllocal.adb +++ b/translate/ghdldrv/ghdllocal.adb @@ -581,7 +581,7 @@ package body Ghdllocal is        return "-s [OPTS] FILEs    Check syntax of FILEs";     end Get_Short_Help; -   function Analyze_One_File (File_Name : String) return Iir_Design_File +   procedure Analyze_One_File (File_Name : String)     is        use Ada.Text_IO;        Id : Name_Id; @@ -621,20 +621,15 @@ package body Ghdllocal is        if Errorout.Nbr_Errors > 0 then           raise Errorout.Compilation_Error;        end if; - -      return Design_File;     end Analyze_One_File; -   procedure Analyze_Files (Files : Argument_List; Save_Library : Boolean) -   is -      Design_File : Iir_Design_File; -      pragma Unreferenced (Design_File); +   procedure Analyze_Files (Files : Argument_List; Save_Library : Boolean) is     begin        Setup_Libraries (True);        --  Parse all files.        for I in Files'Range loop -         Design_File := Analyze_One_File (Files (I).all); +         Analyze_One_File (Files (I).all);        end loop;        if Save_Library then diff --git a/translate/ghdldrv/ghdllocal.ads b/translate/ghdldrv/ghdllocal.ads index f197038c3..46eff1a14 100644 --- a/translate/ghdldrv/ghdllocal.ads +++ b/translate/ghdldrv/ghdllocal.ads @@ -84,10 +84,6 @@ package Ghdllocal is     --  Setup standard libaries path.  If LOAD is true, then load them now.     procedure Setup_Libraries (Load : Boolean); -   --  Analyze file FILE_NAME.  Raise Compilation_Error in case of analysis -   --  error. -   function Analyze_One_File (File_Name : String) return Iir_Design_File; -     --  Setup library, analyze FILES, and if SAVE_LIBRARY is set save the     --  work library only     procedure Analyze_Files (Files : Argument_List; Save_Library : Boolean); diff --git a/translate/ghdldrv/ghdlprint.adb b/translate/ghdldrv/ghdlprint.adb index 214f03009..3af75f864 100644 --- a/translate/ghdldrv/ghdlprint.adb +++ b/translate/ghdldrv/ghdlprint.adb @@ -19,6 +19,7 @@ with Ada.Characters.Latin_1;  with Ada.Text_IO; use Ada.Text_IO;  with GNAT.Directory_Operations;  with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.Table;  with Types; use Types;  with Flags;  with Name_Table; use Name_Table; @@ -29,11 +30,13 @@ with Iirs; use Iirs;  with Iirs_Utils; use Iirs_Utils;  with Tokens;  with Scanner; +with Parse;  with Version;  with Xrefs;  with Ghdlmain; use Ghdlmain;  with Ghdllocal; use Ghdllocal;  with Disp_Vhdl; +with Back_End;  package body Ghdlprint is     type Html_Format_Type is (Html_2, Html_Css); @@ -969,20 +972,136 @@ package body Ghdlprint is        pragma Unreferenced (Cmd);        Design_File : Iir_Design_File;        Unit : Iir; + +      Id : Name_Id; +      Next_Unit : Iir;     begin        Setup_Libraries (True); +      Parse.Flag_Parse_Parenthesis := True;        --  Parse all files.        for I in Args'Range loop -         Design_File := Analyze_One_File (Args (I).all); +         Id := Name_Table.Get_Identifier (Args (I).all); +         Design_File := Libraries.Load_File (Id); +         if Design_File = Null_Iir then +            raise Errorout.Compilation_Error; +         end if; +           Unit := Get_First_Design_Unit (Design_File);           while Unit /= Null_Iir loop -            Disp_Vhdl.Disp_Vhdl (Unit); -            Unit := Get_Chain (Unit); +            -- Sem, canon, annotate a design unit. +            Back_End.Finish_Compilation (Unit, True); + +            Next_Unit := Get_Chain (Unit); +            if Errorout.Nbr_Errors = 0 then +               Disp_Vhdl.Disp_Vhdl (Unit); +               Set_Chain (Unit, Null_Iir); +               Libraries.Add_Design_Unit_Into_Library (Unit); +            end if; + +            Unit := Next_Unit;           end loop; + +         if Errorout.Nbr_Errors > 0 then +            raise Errorout.Compilation_Error; +         end if;        end loop;     end Perform_Action; +   --  Command compare tokens. +   type Command_Compare_Tokens is new Command_Lib with null record; +   function Decode_Command (Cmd : Command_Compare_Tokens; Name : String) +                           return Boolean; +   function Get_Short_Help (Cmd : Command_Compare_Tokens) return String; +   procedure Perform_Action (Cmd : in out Command_Compare_Tokens; +                             Args : Argument_List); + +   function Decode_Command (Cmd : Command_Compare_Tokens; Name : String) +                           return Boolean +   is +      pragma Unreferenced (Cmd); +   begin +      return Name = "--compare-tokens"; +   end Decode_Command; + +   function Get_Short_Help (Cmd : Command_Compare_Tokens) return String +   is +      pragma Unreferenced (Cmd); +   begin +      return "--compare-tokens [OPTS] REF FILEs    Compare FILEs with REF"; +   end Get_Short_Help; + +   procedure Perform_Action (Cmd : in out Command_Compare_Tokens; +                             Args : Argument_List) +   is +      pragma Unreferenced (Cmd); +      use Tokens; +      use Scanner; + +      package Ref_Tokens is new GNAT.Table +        (Table_Component_Type => Token_Type, +         Table_Index_Type => Integer, +         Table_Low_Bound => 0, +         Table_Initial => 1024, +         Table_Increment => 100); + +      Id : Name_Id; +      Fe : Source_File_Entry; +      Local_Id : Name_Id; +      Tok_Idx : Natural; +   begin +      if Args'Length < 1 then +         Error ("missing ref file"); +         raise Compile_Error; +      end if; + +      Local_Id := Get_Identifier (""); + +      for I in Args'Range loop +         --  Load the file. +         Id := Get_Identifier (Args (I).all); +         Fe := Files_Map.Load_Source_File (Local_Id, Id); +         if Fe = No_Source_File_Entry then +            Error ("cannot open file " & Args (I).all); +            raise Compile_Error; +         end if; +         Set_File (Fe); + +         if I = Args'First then +            --  Scan ref file +            loop +               Scan; +               Ref_Tokens.Append (Current_Token); +               exit when Current_Token = Tok_Eof; +            end loop; +         else +            --  Scane file +            Tok_Idx := Ref_Tokens.First; +            loop +               Scan; +               if Ref_Tokens.Table (Tok_Idx) /= Current_Token then +                  Error_Msg_Parse ("token mismatch"); +                  exit; +               end if; +               case Current_Token is +                  when Tok_Eof => +                     exit; +                  when others => +                     null; +               end case; +               Tok_Idx := Tok_Idx + 1; +            end loop; +         end if; +         Close_File; +      end loop; + +      Ref_Tokens.Free; + +      if Nbr_Errors /= 0 then +         raise Compilation_Error; +      end if; +   end Perform_Action; +     --  Command html.     type Command_Html is abstract new Command_Lib with null record; @@ -1616,6 +1735,7 @@ package body Ghdlprint is        Register_Command (new Command_Chop);        Register_Command (new Command_Lines);        Register_Command (new Command_Reprint); +      Register_Command (new Command_Compare_Tokens);        Register_Command (new Command_PP_Html);        Register_Command (new Command_Xref_Html);        Register_Command (new Command_Xref); | 
