From 777f73f67f0f2d18f73dc223a2d941ece31d0c9e Mon Sep 17 00:00:00 2001 From: Tristan Gingold Date: Wed, 23 Jul 2014 20:13:49 +0200 Subject: Add parenthesis_Expression, --reprint and --compare-tokens commands. --- canon.adb | 3 +- disp_tree.adb | 15 ++-- disp_vhdl.adb | 106 ++++++++++++++++++++--- errorout.adb | 4 +- evaluation.adb | 25 +++--- iirs.adb | 163 ++++++++++++++++++++++++----------- iirs.ads | 184 +++++++++++++++++++++++++++++----------- iirs_utils.adb | 7 +- libraries.adb | 2 +- nodes.adb | 30 +++++++ nodes.ads | 18 ++++ parse.adb | 36 +++++--- parse.ads | 3 + sem_assocs.adb | 2 +- sem_expr.adb | 20 +++++ sem_names.adb | 40 ++++----- translate/ghdldrv/ghdllocal.adb | 11 +-- translate/ghdldrv/ghdllocal.ads | 4 - translate/ghdldrv/ghdlprint.adb | 126 ++++++++++++++++++++++++++- 19 files changed, 618 insertions(+), 181 deletions(-) diff --git a/canon.adb b/canon.adb index 9309a703c..b33883457 100644 --- a/canon.adb +++ b/canon.adb @@ -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; diff --git a/iirs.adb b/iirs.adb index 539a1d672..76da74f81 100644 --- a/iirs.adb +++ b/iirs.adb @@ -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 diff --git a/iirs.ads b/iirs.ads index 21e05a40e..8f707af32 100644 --- a/iirs.ads +++ b/iirs.ads @@ -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 diff --git a/nodes.adb b/nodes.adb index 75fb51f99..9885eb1bc 100644 --- a/nodes.adb +++ b/nodes.adb @@ -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 diff --git a/nodes.ads b/nodes.ads index bec29a932..00ec1a714 100644 --- a/nodes.ads +++ b/nodes.ads @@ -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); diff --git a/parse.adb b/parse.adb index 22a536ca8..57cd4cdbc 100644 --- a/parse.adb +++ b/parse.adb @@ -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); diff --git a/parse.ads b/parse.ads index af9a43251..26bdef3ec 100644 --- a/parse.ads +++ b/parse.ads @@ -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); -- cgit v1.2.3