diff options
47 files changed, 1261 insertions, 1266 deletions
diff --git a/src/flags.ads b/src/flags.ads index 4bb6ec486..dc6dcc96d 100644 --- a/src/flags.ads +++ b/src/flags.ads @@ -67,6 +67,10 @@ package Flags is -- -dstats: disp statistics. Dump_Stats : Boolean := False; + -- If not 0, do internal consistency and leaks check on the AST after + -- analysis. + Check_Ast_Level : Natural := 0; + -- -lX options: list tree as a vhdl file. -- --lall option: makes -lX options to apply to all files diff --git a/src/ghdldrv/ghdlcomp.adb b/src/ghdldrv/ghdlcomp.adb index 77aa4ebe7..18ed69380 100644 --- a/src/ghdldrv/ghdlcomp.adb +++ b/src/ghdldrv/ghdlcomp.adb @@ -24,9 +24,7 @@ with Ada.Text_IO; with Types; with Iirs; use Iirs; -with Nodes_GC; with Flags; -with Back_End; with Sem; with Name_Table; with Errorout; use Errorout; @@ -39,9 +37,6 @@ package body Ghdlcomp is Flag_Expect_Failure : Boolean := False; - Flag_Debug_Nodes_Leak : Boolean := False; - -- If True, detect unreferenced nodes at the end of analysis. - -- Commands which use the mcode compiler. type Command_Comp is abstract new Command_Lib with null record; procedure Decode_Option (Cmd : in out Command_Comp; @@ -59,8 +54,8 @@ package body Ghdlcomp is if Option = "--expect-failure" then Flag_Expect_Failure := True; Res := Option_Ok; - elsif Option = "--debug-nodes-leak" then - Flag_Debug_Nodes_Leak := True; + elsif Option = "--check-ast" then + Flags.Check_Ast_Level := Flags.Check_Ast_Level + 1; Res := Option_Ok; elsif Hooks.Decode_Option.all (Option) then Res := Option_Ok; @@ -341,7 +336,7 @@ package body Ghdlcomp is if Design_File /= Null_Iir then Unit := Get_First_Design_Unit (Design_File); while Unit /= Null_Iir loop - Back_End.Finish_Compilation (Unit, True); + Libraries.Finish_Compilation (Unit, True); Next_Unit := Get_Chain (Unit); @@ -378,10 +373,6 @@ package body Ghdlcomp is raise Compilation_Error; end if; - if Flag_Debug_Nodes_Leak then - Nodes_GC.Report_Unreferenced; - end if; - Libraries.Save_Work_Library; exception diff --git a/src/ghdldrv/ghdllocal.adb b/src/ghdldrv/ghdllocal.adb index b1050e5fe..411965374 100644 --- a/src/ghdldrv/ghdllocal.adb +++ b/src/ghdldrv/ghdllocal.adb @@ -19,24 +19,17 @@ with Ada.Text_IO; use Ada.Text_IO; with Ada.Command_Line; use Ada.Command_Line; with GNAT.Directory_Operations; with Types; use Types; -with Iir_Chains; -with Nodes_Meta; with Libraries; with Std_Package; with Flags; with Name_Table; with Std_Names; -with Back_End; with Disp_Vhdl; with Default_Pathes; with Scanner; -with Sem; -with Canon; with Errorout; with Configuration; with Files_Map; -with Post_Sems; -with Disp_Tree; with Options; with Iirs_Utils; use Iirs_Utils; @@ -48,89 +41,10 @@ package body Ghdllocal is -- If TRUE, generate 32bits code on 64bits machines. Flag_32bit : Boolean := False; - procedure Finish_Compilation - (Unit : Iir_Design_Unit; Main : Boolean := False) - is - use Errorout; - Lib_Unit : constant Iir := Get_Library_Unit (Unit); - Config : Iir_Design_Unit; - begin - if (Main or Flags.Dump_All) and then Flags.Dump_Parse then - Disp_Tree.Disp_Tree (Unit); - end if; - - if Flags.Verbose then - Report_Msg (Msgid_Note, Semantic, +Unit, - "analyze %n", (1 => +Lib_Unit)); - end if; - - Sem.Semantic (Unit); - - if (Main or Flags.Dump_All) and then Flags.Dump_Sem then - Disp_Tree.Disp_Tree (Unit); - end if; - - if Errorout.Nbr_Errors > 0 then - raise Compilation_Error; - end if; - - if (Main or Flags.List_All) and then Flags.List_Sem then - Disp_Vhdl.Disp_Vhdl (Unit); - end if; - - Post_Sems.Post_Sem_Checks (Unit); - - if Errorout.Nbr_Errors > 0 then - raise Compilation_Error; - end if; - - if Flags.Flag_Elaborate - or else ((Main or Flags.List_All) and then Flags.List_Canon) - then - if Flags.Verbose then - Report_Msg (Msgid_Note, Semantic, No_Location, - "canonicalize %n", (1 => +Lib_Unit)); - end if; - - Canon.Canonicalize (Unit); - - -- FIXME: for Main only ? - if Get_Kind (Lib_Unit) = Iir_Kind_Package_Declaration - and then not Get_Need_Body (Lib_Unit) - and then Get_Need_Instance_Bodies (Lib_Unit) - then - -- Create the bodies for instances - Set_Package_Instantiation_Bodies_Chain - (Lib_Unit, - Canon.Create_Instantiation_Bodies (Lib_Unit, Lib_Unit)); - elsif Get_Kind (Lib_Unit) = Iir_Kind_Package_Body - and then Get_Need_Instance_Bodies (Get_Package (Lib_Unit)) - then - Iir_Chains.Append_Chain - (Lib_Unit, Nodes_Meta.Field_Declaration_Chain, - Canon.Create_Instantiation_Bodies (Get_Package (Lib_Unit), - Lib_Unit)); - end if; - - if (Main or Flags.List_All) and then Flags.List_Canon then - Disp_Vhdl.Disp_Vhdl (Unit); - end if; - end if; - - if Flags.Flag_Elaborate then - if Get_Kind (Lib_Unit) = Iir_Kind_Architecture_Body then - Config := - Canon.Create_Default_Configuration_Declaration (Lib_Unit); - Set_Default_Configuration_Declaration (Lib_Unit, Config); - end if; - end if; - end Finish_Compilation; - procedure Compile_Init is begin Options.Initialize; Flag_Ieee := Lib_Standard; - Back_End.Finish_Compilation := Finish_Compilation'Access; Flag_Verbose := False; end Compile_Init; @@ -800,7 +714,7 @@ package body Ghdllocal is | Date_Analyzed => null; when Date_Parsed => - Back_End.Finish_Compilation (Unit, False); + Libraries.Finish_Compilation (Unit, False); when others => raise Internal_Error; end case; @@ -865,7 +779,7 @@ package body Ghdllocal is New_Line; end if; -- Sem, canon, annotate a design unit. - Back_End.Finish_Compilation (Unit, True); + Libraries.Finish_Compilation (Unit, True); Next_Unit := Get_Chain (Unit); if Errorout.Nbr_Errors = 0 then diff --git a/src/ghdldrv/ghdlprint.adb b/src/ghdldrv/ghdlprint.adb index d9c6165a8..093ba00a9 100644 --- a/src/ghdldrv/ghdlprint.adb +++ b/src/ghdldrv/ghdlprint.adb @@ -30,12 +30,12 @@ with Iirs_Utils; use Iirs_Utils; with Tokens; with Scanner; with Parse; +with Canon; 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); @@ -985,8 +985,14 @@ package body Ghdlprint is Next_Unit : Iir; begin Setup_Libraries (True); + + -- Keep parenthesis during parse. Parse.Flag_Parse_Parenthesis := True; + Canon.Canon_Flag_Concurrent_Stmts := False; + Canon.Canon_Flag_Configurations := False; + Canon.Canon_Flag_Specification_Lists := False; + -- Parse all files. for I in Args'Range loop Id := Name_Table.Get_Identifier (Args (I).all); @@ -998,7 +1004,7 @@ package body Ghdlprint is Unit := Get_First_Design_Unit (Design_File); while Unit /= Null_Iir loop -- Analyze the design unit. - Back_End.Finish_Compilation (Unit, True); + Libraries.Finish_Compilation (Unit, True); Next_Unit := Get_Chain (Unit); if Errorout.Nbr_Errors = 0 then diff --git a/src/ghdldrv/ghdlsimul.adb b/src/ghdldrv/ghdlsimul.adb index ddf70bbb3..2f2e13ce5 100644 --- a/src/ghdldrv/ghdlsimul.adb +++ b/src/ghdldrv/ghdlsimul.adb @@ -25,7 +25,6 @@ with GNAT.OS_Lib; use GNAT.OS_Lib; with Types; with Iirs; use Iirs; with Flags; -with Back_End; with Name_Table; with Errorout; use Errorout; with Std_Package; @@ -35,7 +34,6 @@ with Configuration; with Iirs_Utils; with Annotations; with Elaboration; -with Sim_Be; with Simulation.Main; with Debugger; with Execution; @@ -58,10 +56,6 @@ package body Ghdlsimul is return; end if; - -- Initialize. - Back_End.Finish_Compilation := Sim_Be.Finish_Compilation'Access; - Back_End.Sem_Foreign := null; - Setup_Libraries (False); Libraries.Load_Std_Library; @@ -79,6 +73,7 @@ package body Ghdlsimul is is use Name_Table; use Types; + use Configuration; First_Id : Name_Id; Sec_Id : Name_Id; @@ -117,6 +112,11 @@ package body Ghdlsimul is raise Compilation_Error; end if; end; + + -- Annotate all units. + for I in Design_Units.First .. Design_Units.Last loop + Annotations.Annotate (Design_Units.Table (I)); + end loop; end Compile_Elab; -- Set options. diff --git a/src/ghdldrv/ghdlxml.adb b/src/ghdldrv/ghdlxml.adb index 329af4658..6641202a0 100644 --- a/src/ghdldrv/ghdlxml.adb +++ b/src/ghdldrv/ghdlxml.adb @@ -198,23 +198,26 @@ package body Ghdlxml is Put_Empty_Stag_End; end Disp_Iir_List_Ref; - procedure Disp_Iir_Chain (Id : String; N : Iir) + procedure Disp_Iir_Chain_Elements (Chain : Iir) is El : Iir; begin + El := Chain; + while Is_Valid (El) loop + Disp_Iir ("el", El); + El := Get_Chain (El); + end loop; + end Disp_Iir_Chain_Elements; + + procedure Disp_Iir_Chain (Id : String; N : Iir) is + begin if N = Null_Iir then return; end if; Put_Stag (Id); Put_Stag_End; - - El := N; - while Is_Valid (El) loop - Disp_Iir ("el", El); - El := Get_Chain (El); - end loop; - + Disp_Iir_Chain_Elements (N); Put_Etag (Id); end Disp_Iir_Chain; @@ -513,7 +516,11 @@ package body Ghdlxml is Col := 0; Put_Line ("<?xml version=""1.0"" encoding=""UTF-8"" standalone=""yes""?>"); - Disp_Iir_Chain ("root", Libraries.Get_Libraries_Chain); + Put_Stag ("root"); + Put_Attribute ("version", "0.13"); + Put_Stag_End; + Disp_Iir_Chain_Elements (Libraries.Get_Libraries_Chain); + Put_Etag ("root"); exception when Compilation_Error => Error ("xml dump failed due to compilation error"); diff --git a/src/libraries.adb b/src/libraries.adb index 36c79579e..4258eeaea 100644 --- a/src/libraries.adb +++ b/src/libraries.adb @@ -23,14 +23,21 @@ with System; with Errorout; use Errorout; with Scanner; with Iirs_Utils; use Iirs_Utils; +with Iir_Chains; +with Nodes_Meta; with Parse; -with Back_End; with Name_Table; use Name_Table; with Str_Table; with Tokens; with Files_Map; with Flags; with Std_Package; +with Disp_Tree; +with Disp_Vhdl; +with Sem; +with Post_Sems; +with Canon; +with Nodes_GC; package body Libraries is -- Chain of known libraries. This is also the top node of all iir node. @@ -1541,6 +1548,87 @@ package body Libraries is return False; end Is_Obsolete; + procedure Finish_Compilation + (Unit : Iir_Design_Unit; Main : Boolean := False) + is + Lib_Unit : constant Iir := Get_Library_Unit (Unit); + begin + if (Main or Flags.Dump_All) and then Flags.Dump_Parse then + Disp_Tree.Disp_Tree (Unit); + end if; + + if Flags.Check_Ast_Level > 0 then + Nodes_GC.Check_Tree (Unit); + end if; + + if Flags.Verbose then + Report_Msg (Msgid_Note, Semantic, +Lib_Unit, + "analyze %n", (1 => +Lib_Unit)); + end if; + + Sem.Semantic (Unit); + + if (Main or Flags.Dump_All) and then Flags.Dump_Sem then + Disp_Tree.Disp_Tree (Unit); + end if; + + if Errorout.Nbr_Errors > 0 then + raise Compilation_Error; + end if; + + if (Main or Flags.List_All) and then Flags.List_Sem then + Disp_Vhdl.Disp_Vhdl (Unit); + end if; + + -- Post checks + ---------------- + + Post_Sems.Post_Sem_Checks (Unit); + + if Errorout.Nbr_Errors > 0 then + raise Compilation_Error; + end if; + + -- Canonalisation. + ------------------ + + if Flags.Verbose then + Report_Msg (Msgid_Note, Semantic, +Lib_Unit, + "canonicalize %n", (1 => +Lib_Unit)); + end if; + + Canon.Canonicalize (Unit); + + -- FIXME: for Main only ? + if Get_Kind (Lib_Unit) = Iir_Kind_Package_Declaration + and then not Get_Need_Body (Lib_Unit) + and then Get_Need_Instance_Bodies (Lib_Unit) + then + -- Create the bodies for instances + Set_Package_Instantiation_Bodies_Chain + (Lib_Unit, Canon.Create_Instantiation_Bodies (Lib_Unit, Lib_Unit)); + elsif Get_Kind (Lib_Unit) = Iir_Kind_Package_Body + and then Get_Need_Instance_Bodies (Get_Package (Lib_Unit)) + then + Iir_Chains.Append_Chain + (Lib_Unit, Nodes_Meta.Field_Declaration_Chain, + Canon.Create_Instantiation_Bodies (Get_Package (Lib_Unit), + Lib_Unit)); + end if; + + if (Main or Flags.Dump_All) and then Flags.Dump_Canon then + Disp_Tree.Disp_Tree (Unit); + end if; + + if Errorout.Nbr_Errors > 0 then + raise Compilation_Error; + end if; + + if (Main or Flags.List_All) and then Flags.List_Canon then + Disp_Vhdl.Disp_Vhdl (Unit); + end if; + end Finish_Compilation; + procedure Load_Parse_Design_Unit (Design_Unit: Iir_Design_Unit; Loc : Iir) is use Scanner; @@ -1639,7 +1727,7 @@ package body Libraries is -- Avoid infinite recursion, if the unit is self-referenced. Set_Date_State (Design_Unit, Date_Analyze); - Back_End.Finish_Compilation (Design_Unit); + Finish_Compilation (Design_Unit); end if; case Get_Date (Design_Unit) is diff --git a/src/libraries.ads b/src/libraries.ads index 448195822..0a7e04674 100644 --- a/src/libraries.ads +++ b/src/libraries.ads @@ -145,6 +145,10 @@ package Libraries is (Primary: Iir_Design_Unit; Name: Name_Id; Loc : Iir) return Iir_Design_Unit; + -- Analyze UNIT. + procedure Finish_Compilation + (Unit : Iir_Design_Unit; Main : Boolean := False); + -- Get or create a library from an identifier. -- LOC is used only to report errors. function Get_Library (Ident : Name_Id; Loc : Location_Type) diff --git a/src/vhdl/back_end.ads b/src/vhdl/back_end.ads index e9db8bd42..00ac5c429 100644 --- a/src/vhdl/back_end.ads +++ b/src/vhdl/back_end.ads @@ -26,18 +26,6 @@ package Back_End is type Disp_Option_Acc is access procedure; Disp_Option : Disp_Option_Acc := null; - -- UNIT is a design unit from parse. - -- According to the current back-end, do what is necessary. - -- - -- If MAIN is true, then UNIT is a wanted to be analysed design unit, and - -- dump/list options can applied. - -- This avoid to dump/list units fetched (through a selected name or a - -- use clause) indirectly by the main unit. - type Finish_Compilation_Acc is access - procedure (Unit : Iir_Design_Unit; Main : Boolean := False); - - Finish_Compilation : Finish_Compilation_Acc := null; - -- DECL is an architecture (library unit) or a subprogram (specification) -- decorated with a FOREIGN attribute. Do back-end checks. -- May be NULL for no additionnal checks. diff --git a/src/vhdl/canon.adb b/src/vhdl/canon.adb index 30fe6c939..0e560cd5f 100644 --- a/src/vhdl/canon.adb +++ b/src/vhdl/canon.adb @@ -2401,11 +2401,10 @@ package body Canon is El := Get_Named_Entity (El); Comp_Conf := Get_Component_Configuration (El); if Comp_Conf /= Null_Iir and then Comp_Conf /= Conf then - if Get_Kind (Comp_Conf) /= Iir_Kind_Configuration_Specification - or else Get_Kind (Conf) /= Iir_Kind_Component_Configuration - then - raise Internal_Error; - end if; + pragma Assert + (Get_Kind (Comp_Conf) = Iir_Kind_Configuration_Specification); + pragma Assert + (Get_Kind (Conf) = Iir_Kind_Component_Configuration); Canon_Incremental_Binding (Comp_Conf, Conf, Parent); else Set_Component_Configuration (El, Conf); @@ -2444,34 +2443,38 @@ package body Canon is if Canon_Flag_Expressions then Canon_Expression (Get_Expression (Dis)); end if; - Signal_List := Get_Signal_List (Dis); - if Signal_List = Iir_List_All then - Force := True; - elsif Signal_List = Iir_List_Others then - Force := False; - else - return; - end if; - Dis_Type := Get_Type (Get_Type_Mark (Dis)); - N_List := Create_Iir_List; - Set_Signal_List (Dis, N_List); - El := Get_Declaration_Chain (Decl_Parent); - while El /= Null_Iir loop - if Get_Kind (El) = Iir_Kind_Signal_Declaration - and then Get_Type (El) = Dis_Type - and then Get_Guarded_Signal_Flag (El) - then - if not Get_Has_Disconnect_Flag (El) then - Set_Has_Disconnect_Flag (El, True); - Append_Element (N_List, El); - else - if Force then - raise Internal_Error; + + if Canon_Flag_Specification_Lists then + Signal_List := Get_Signal_List (Dis); + if Signal_List = Iir_List_All then + Force := True; + elsif Signal_List = Iir_List_Others then + Force := False; + else + return; + end if; + + Dis_Type := Get_Type (Get_Type_Mark (Dis)); + N_List := Create_Iir_List; + Set_Signal_List (Dis, N_List); + El := Get_Declaration_Chain (Decl_Parent); + while El /= Null_Iir loop + if Get_Kind (El) = Iir_Kind_Signal_Declaration + and then Get_Type (El) = Dis_Type + and then Get_Guarded_Signal_Flag (El) + then + if not Get_Has_Disconnect_Flag (El) then + Set_Has_Disconnect_Flag (El, True); + Append_Element (N_List, El); + else + if Force then + raise Internal_Error; + end if; end if; end if; - end if; - El := Get_Chain (El); - end loop; + El := Get_Chain (El); + end loop; + end if; end Canon_Disconnection_Specification; procedure Canon_Subtype_Indication (Def : Iir) is @@ -2676,8 +2679,10 @@ package body Canon is null; when Iir_Kind_Configuration_Specification => - Canon_Component_Specification (Decl, Parent); - Canon_Component_Configuration (Top, Decl); + if Canon_Flag_Configurations then + Canon_Component_Specification (Decl, Parent); + Canon_Component_Configuration (Top, Decl); + end if; when Iir_Kind_Package_Declaration => Canon_Declarations (Top, Decl, Parent); @@ -3021,17 +3026,23 @@ package body Canon is Canon_Interface_List (Get_Generic_Chain (El)); Canon_Interface_List (Get_Port_Chain (El)); Canon_Declarations (Unit, El, El); - Canon_Concurrent_Stmts (Unit, El); + if Canon_Flag_Concurrent_Stmts then + Canon_Concurrent_Stmts (Unit, El); + end if; when Iir_Kind_Architecture_Body => Canon_Declarations (Unit, El, El); - Canon_Concurrent_Stmts (Unit, El); + if Canon_Flag_Concurrent_Stmts then + Canon_Concurrent_Stmts (Unit, El); + end if; when Iir_Kind_Package_Declaration => Canon_Declarations (Unit, El, Null_Iir); when Iir_Kind_Package_Body => Canon_Declarations (Unit, El, Null_Iir); when Iir_Kind_Configuration_Declaration => Canon_Declarations (Unit, El, Null_Iir); - Canon_Block_Configuration (Unit, Get_Block_Configuration (El)); + if Canon_Flag_Configurations then + Canon_Block_Configuration (Unit, Get_Block_Configuration (El)); + end if; when Iir_Kind_Package_Instantiation_Declaration => El := Canon_Package_Instantiation_Declaration (El); Set_Library_Unit (Unit, El); diff --git a/src/vhdl/canon.ads b/src/vhdl/canon.ads index b78eaaa1c..40ce5088f 100644 --- a/src/vhdl/canon.ads +++ b/src/vhdl/canon.ads @@ -25,6 +25,15 @@ package Canon is -- If true, canon sequentials statements (processes and subprograms). Canon_Flag_Sequentials_Stmts : Boolean := False; + -- If true, canon concurrent statements. + Canon_Flag_Concurrent_Stmts : Boolean := True; + + -- If true, canon configuration. + Canon_Flag_Configurations : Boolean := True; + + -- If true, canon lists in specifications. + Canon_Flag_Specification_Lists : Boolean := True; + -- If true, canon expressions. Canon_Flag_Expressions : Boolean := False; diff --git a/src/vhdl/configuration.adb b/src/vhdl/configuration.adb index b36142595..16554a2fa 100644 --- a/src/vhdl/configuration.adb +++ b/src/vhdl/configuration.adb @@ -21,6 +21,7 @@ with Std_Package; with Name_Table; use Name_Table; with Flags; with Iirs_Utils; use Iirs_Utils; +with Canon; package body Configuration is procedure Add_Design_Concurrent_Stmts (Parent : Iir); @@ -282,6 +283,7 @@ package body Configuration is Entity : Iir; Arch : Iir; Config : Iir; + Arch_Lib : Iir; Id : Name_Id; Entity_Lib : Iir; begin @@ -329,17 +331,24 @@ package body Configuration is -- before the architecture in case of recursive instantiation: -- the configuration depends on the architecture. if Add_Default then - Config := Get_Default_Configuration_Declaration - (Get_Library_Unit (Arch)); - if Config /= Null_Iir then - if Get_Configuration_Mark_Flag (Config) - and then not Get_Configuration_Done_Flag (Config) - then - -- Recursive instantiation. - return; - else - Add_Design_Unit (Config, Aspect); - end if; + Arch_Lib := Get_Library_Unit (Arch); + + -- The default configuration may already exist due to a + -- previous instantiation. Create it if it doesn't exist. + Config := Get_Default_Configuration_Declaration (Arch_Lib); + if Is_Null (Config) then + Config := + Canon.Create_Default_Configuration_Declaration (Arch_Lib); + Set_Default_Configuration_Declaration (Arch_Lib, Config); + end if; + + if Get_Configuration_Mark_Flag (Config) + and then not Get_Configuration_Done_Flag (Config) + then + -- Recursive instantiation. + return; + else + Add_Design_Unit (Config, Aspect); end if; end if; @@ -609,11 +618,12 @@ package body Configuration is return Null_Iir; end if; Lib_Unit := Get_Library_Unit (Unit); - Top := Get_Default_Configuration_Declaration (Lib_Unit); - if Top = Null_Iir then - -- No default configuration for this architecture. - raise Internal_Error; - end if; + pragma Assert + (Is_Null (Get_Default_Configuration_Declaration (Lib_Unit))); + + Top := Canon.Create_Default_Configuration_Declaration (Lib_Unit); + Set_Default_Configuration_Declaration (Lib_Unit, Top); + pragma Assert (Is_Valid (Top)); when Iir_Kind_Configuration_Declaration => Top := Unit; when others => diff --git a/src/vhdl/disp_vhdl.adb b/src/vhdl/disp_vhdl.adb index bfa044e9c..a92fcb2b5 100644 --- a/src/vhdl/disp_vhdl.adb +++ b/src/vhdl/disp_vhdl.adb @@ -2123,7 +2123,7 @@ package body Disp_Vhdl is begin Disp_Identifier (Iterator); Put (" in "); - Disp_Discrete_Range (Get_Discrete_Range (Iterator)); + Disp_Discrete_Range (Get_Subtype_Indication (Iterator)); end Disp_Parameter_Specification; procedure Disp_Method_Object (Call : Iir) diff --git a/src/vhdl/evaluation.adb b/src/vhdl/evaluation.adb index 69d0a6dc8..07aaa0acf 100644 --- a/src/vhdl/evaluation.adb +++ b/src/vhdl/evaluation.adb @@ -40,7 +40,9 @@ package body Evaluation is when Iir_Kind_Physical_Int_Literal | Iir_Kind_Physical_Fp_Literal => -- Extract Unit. - Unit := Get_Physical_Unit_Value (Get_Physical_Unit (Expr)); + Unit := Get_Physical_Literal (Get_Physical_Unit (Expr)); + pragma Assert (Get_Physical_Unit (Unit) + = Get_Primary_Unit (Get_Type (Unit))); case Kind is when Iir_Kind_Physical_Int_Literal => return Get_Value (Expr) * Get_Value (Unit); @@ -51,7 +53,7 @@ package body Evaluation is raise Program_Error; end case; when Iir_Kind_Unit_Declaration => - return Get_Value (Get_Physical_Unit_Value (Expr)); + return Get_Value (Get_Physical_Literal (Expr)); when others => Error_Kind ("get_physical_value", Expr); end case; @@ -1748,7 +1750,7 @@ package body Evaluation is return Build_Overflow (Expr); end if; - Mult := Get_Value (Get_Physical_Unit_Value (Unit)); + Mult := Get_Value (Get_Physical_Literal (Unit)); if Found_Real then return Build_Physical (Iir_Int64 (Iir_Fp64'Value (Val (Val'First .. Sep)) @@ -2066,7 +2068,7 @@ package body Evaluation is when Iir_Kind_Object_Alias_Declaration => return Eval_Static_Expr (Get_Name (Expr)); when Iir_Kind_Unit_Declaration => - return Get_Physical_Unit_Value (Expr); + return Get_Physical_Literal (Expr); when Iir_Kind_Simple_Aggregate => return Expr; diff --git a/src/vhdl/iirs.adb b/src/vhdl/iirs.adb index 4f19470e6..c1a733a5f 100644 --- a/src/vhdl/iirs.adb +++ b/src/vhdl/iirs.adb @@ -74,14 +74,7 @@ package body Iirs is Num (Kind) := Num (Kind) + 1; Format := Get_Format (Kind); Formats (Format) := Formats (Format) + 1; - case Format is - when Format_Medium => - I := I + 2; - when Format_Short - | Format_Fp - | Format_Int => - I := I + 1; - end case; + I := Next_Node (I); end loop; Put_Line ("Stats per iir_kind:"); @@ -131,18 +124,19 @@ package body Iirs is return Res; end Create_Iir_Error; - procedure Location_Copy (Target: Iir; Src: Iir) is + procedure Location_Copy (Target : Iir; Src : Iir) is begin Set_Location (Target, Get_Location (Src)); end Location_Copy; -- Get kind - function Get_Kind (An_Iir: Iir) return Iir_Kind + function Get_Kind (N : Iir) return Iir_Kind is -- Speed up: avoid to check that nkind is in the bounds of Iir_Kind. pragma Suppress (Range_Check); begin - return Iir_Kind'Val (Get_Nkind (An_Iir)); + pragma Assert (N /= Null_Iir); + return Iir_Kind'Val (Get_Nkind (N)); end Get_Kind; function Time_Stamp_Id_To_Iir is new Ada.Unchecked_Conversion @@ -260,8 +254,12 @@ package body Iirs is | Iir_Kind_Library_Clause | Iir_Kind_Use_Clause | Iir_Kind_Context_Reference + | Iir_Kind_Integer_Literal + | Iir_Kind_Floating_Point_Literal | Iir_Kind_Null_Literal | Iir_Kind_String_Literal8 + | Iir_Kind_Physical_Int_Literal + | Iir_Kind_Physical_Fp_Literal | Iir_Kind_Simple_Aggregate | Iir_Kind_Overflow_Literal | Iir_Kind_Waveform_Element @@ -517,12 +515,6 @@ package body Iirs is | Iir_Kind_Simple_Simultaneous_Statement | Iir_Kind_Wait_Statement => return Format_Medium; - when Iir_Kind_Floating_Point_Literal - | Iir_Kind_Physical_Fp_Literal => - return Format_Fp; - when Iir_Kind_Integer_Literal - | Iir_Kind_Physical_Int_Literal => - return Format_Int; end case; end Get_Format; @@ -904,20 +896,39 @@ package body Iirs is Set_Field12 (Design_Unit, Int32_To_Iir (Line)); end Set_Design_Unit_Source_Col; - function Get_Value (Lit : Iir) return Iir_Int64 is + type Iir_Int64_Conv is record + Field4: Iir; + Field5: Iir; + end record; + pragma Pack (Iir_Int64_Conv); + pragma Assert (Iir_Int64_Conv'Size = Iir_Int64'Size); + + function Get_Value (Lit : Iir) return Iir_Int64 + is + function To_Iir_Int64 is new Ada.Unchecked_Conversion + (Iir_Int64_Conv, Iir_Int64); + Conv : Iir_Int64_Conv; begin pragma Assert (Lit /= Null_Iir); pragma Assert (Has_Value (Get_Kind (Lit)), "no field Value"); - return Get_Int64 (Lit); + Conv.Field4 := Get_Field4 (Lit); + Conv.Field5 := Get_Field5 (Lit); + return To_Iir_Int64 (Conv); end Get_Value; - procedure Set_Value (Lit : Iir; Val : Iir_Int64) is + procedure Set_Value (Lit : Iir; Val : Iir_Int64) + is + function To_Iir_Int64_Conv is new Ada.Unchecked_Conversion + (Iir_Int64, Iir_Int64_Conv); + Conv : Iir_Int64_Conv; begin pragma Assert (Lit /= Null_Iir); pragma Assert (Has_Value (Get_Kind (Lit)), "no field Value"); - Set_Int64 (Lit, Val); + Conv := To_Iir_Int64_Conv (Val); + Set_Field4 (Lit, Conv.Field4); + Set_Field5 (Lit, Conv.Field5); end Set_Value; function Get_Enum_Pos (Lit : Iir) return Iir_Int32 is @@ -952,36 +963,39 @@ package body Iirs is Set_Field4 (Unit, Lit); end Set_Physical_Literal; - function Get_Physical_Unit_Value (Unit : Iir) return Iir is - begin - pragma Assert (Unit /= Null_Iir); - pragma Assert (Has_Physical_Unit_Value (Get_Kind (Unit)), - "no field Physical_Unit_Value"); - return Get_Field5 (Unit); - end Get_Physical_Unit_Value; - - procedure Set_Physical_Unit_Value (Unit : Iir; Lit : Iir) is - begin - pragma Assert (Unit /= Null_Iir); - pragma Assert (Has_Physical_Unit_Value (Get_Kind (Unit)), - "no field Physical_Unit_Value"); - Set_Field5 (Unit, Lit); - end Set_Physical_Unit_Value; + type Iir_Fp64_Conv is record + Field4: Iir; + Field5: Iir; + end record; + pragma Pack (Iir_Fp64_Conv); + pragma Assert (Iir_Fp64_Conv'Size = Iir_Fp64'Size); - function Get_Fp_Value (Lit : Iir) return Iir_Fp64 is + function Get_Fp_Value (Lit : Iir) return Iir_Fp64 + is + function To_Iir_Fp64 is new Ada.Unchecked_Conversion + (Iir_Fp64_Conv, Iir_Fp64); + Conv : Iir_Fp64_Conv; begin pragma Assert (Lit /= Null_Iir); pragma Assert (Has_Fp_Value (Get_Kind (Lit)), "no field Fp_Value"); - return Get_Fp64 (Lit); + Conv.Field4 := Get_Field4 (Lit); + Conv.Field5 := Get_Field5 (Lit); + return To_Iir_Fp64 (Conv); end Get_Fp_Value; - procedure Set_Fp_Value (Lit : Iir; Val : Iir_Fp64) is + procedure Set_Fp_Value (Lit : Iir; Val : Iir_Fp64) + is + function To_Iir_Fp64_Conv is new Ada.Unchecked_Conversion + (Iir_Fp64, Iir_Fp64_Conv); + Conv : Iir_Fp64_Conv; begin pragma Assert (Lit /= Null_Iir); pragma Assert (Has_Fp_Value (Get_Kind (Lit)), "no field Fp_Value"); - Set_Fp64 (Lit, Val); + Conv := To_Iir_Fp64_Conv (Val); + Set_Field4 (Lit, Conv.Field4); + Set_Field5 (Lit, Conv.Field5); end Set_Fp_Value; function Get_Simple_Aggregate_List (Target : Iir) return Iir_List is @@ -1032,20 +1046,42 @@ package body Iirs is Set_Field4 (Lit, Int32_To_Iir (Len)); end Set_String_Length; - function Get_Bit_String_Base (Lit : Iir) return Number_Base_Type is + type Number_Base_Type_Conv is record + Flag12: Boolean; + Flag13: Boolean; + Flag14: Boolean; + end record; + pragma Pack (Number_Base_Type_Conv); + pragma Assert (Number_Base_Type_Conv'Size = Number_Base_Type'Size); + + function Get_Bit_String_Base (Lit : Iir) return Number_Base_Type + is + function To_Number_Base_Type is new Ada.Unchecked_Conversion + (Number_Base_Type_Conv, Number_Base_Type); + Conv : Number_Base_Type_Conv; begin pragma Assert (Lit /= Null_Iir); pragma Assert (Has_Bit_String_Base (Get_Kind (Lit)), "no field Bit_String_Base"); - return Number_Base_Type'Val (Get_Odigit1 (Lit)); + Conv.Flag12 := Get_Flag12 (Lit); + Conv.Flag13 := Get_Flag13 (Lit); + Conv.Flag14 := Get_Flag14 (Lit); + return To_Number_Base_Type (Conv); end Get_Bit_String_Base; - procedure Set_Bit_String_Base (Lit : Iir; Base : Number_Base_Type) is + procedure Set_Bit_String_Base (Lit : Iir; Base : Number_Base_Type) + is + function To_Number_Base_Type_Conv is new Ada.Unchecked_Conversion + (Number_Base_Type, Number_Base_Type_Conv); + Conv : Number_Base_Type_Conv; begin pragma Assert (Lit /= Null_Iir); pragma Assert (Has_Bit_String_Base (Get_Kind (Lit)), "no field Bit_String_Base"); - Set_Odigit1 (Lit, Number_Base_Type'Pos (Base)); + Conv := To_Number_Base_Type_Conv (Base); + Set_Flag12 (Lit, Conv.Flag12); + Set_Flag13 (Lit, Conv.Flag13); + Set_Flag14 (Lit, Conv.Flag14); end Set_Bit_String_Base; function Get_Has_Signed (Lit : Iir) return Boolean is @@ -1390,7 +1426,7 @@ package body Iirs is pragma Assert (Target /= Null_Iir); pragma Assert (Has_Open_Flag (Get_Kind (Target)), "no field Open_Flag"); - return Get_Flag12 (Target); + return Get_Flag15 (Target); end Get_Open_Flag; procedure Set_Open_Flag (Target : Iir; Flag : Boolean) is @@ -1398,7 +1434,7 @@ package body Iirs is pragma Assert (Target /= Null_Iir); pragma Assert (Has_Open_Flag (Get_Kind (Target)), "no field Open_Flag"); - Set_Flag12 (Target, Flag); + Set_Flag15 (Target, Flag); end Set_Open_Flag; function Get_After_Drivers_Flag (Target : Iir) return Boolean is @@ -2011,20 +2047,42 @@ package body Iirs is Set_Field1 (Target, Nature); end Set_Nature; - function Get_Mode (Target : Iir) return Iir_Mode is + type Iir_Mode_Conv is record + Flag12: Boolean; + Flag13: Boolean; + Flag14: Boolean; + end record; + pragma Pack (Iir_Mode_Conv); + pragma Assert (Iir_Mode_Conv'Size = Iir_Mode'Size); + + function Get_Mode (Target : Iir) return Iir_Mode + is + function To_Iir_Mode is new Ada.Unchecked_Conversion + (Iir_Mode_Conv, Iir_Mode); + Conv : Iir_Mode_Conv; begin pragma Assert (Target /= Null_Iir); pragma Assert (Has_Mode (Get_Kind (Target)), "no field Mode"); - return Iir_Mode'Val (Get_Odigit1 (Target)); + Conv.Flag12 := Get_Flag12 (Target); + Conv.Flag13 := Get_Flag13 (Target); + Conv.Flag14 := Get_Flag14 (Target); + return To_Iir_Mode (Conv); end Get_Mode; - procedure Set_Mode (Target : Iir; Mode : Iir_Mode) is + procedure Set_Mode (Target : Iir; Mode : Iir_Mode) + is + function To_Iir_Mode_Conv is new Ada.Unchecked_Conversion + (Iir_Mode, Iir_Mode_Conv); + Conv : Iir_Mode_Conv; begin pragma Assert (Target /= Null_Iir); pragma Assert (Has_Mode (Get_Kind (Target)), "no field Mode"); - Set_Odigit1 (Target, Iir_Mode'Pos (Mode)); + Conv := To_Iir_Mode_Conv (Mode); + Set_Flag12 (Target, Conv.Flag12); + Set_Flag13 (Target, Conv.Flag13); + Set_Flag14 (Target, Conv.Flag14); end Set_Mode; function Get_Guarded_Signal_Flag (Target : Iir) return Boolean is @@ -2629,7 +2687,7 @@ package body Iirs is pragma Assert (Target /= Null_Iir); pragma Assert (Has_Unit_Chain (Get_Kind (Target)), "no field Unit_Chain"); - return Get_Field1 (Target); + return Get_Field2 (Target); end Get_Unit_Chain; procedure Set_Unit_Chain (Target : Iir; Chain : Iir) is @@ -2637,7 +2695,7 @@ package body Iirs is pragma Assert (Target /= Null_Iir); pragma Assert (Has_Unit_Chain (Get_Kind (Target)), "no field Unit_Chain"); - Set_Field1 (Target, Chain); + Set_Field2 (Target, Chain); end Set_Unit_Chain; function Get_Primary_Unit (Target : Iir) return Iir is @@ -2645,7 +2703,7 @@ package body Iirs is pragma Assert (Target /= Null_Iir); pragma Assert (Has_Primary_Unit (Get_Kind (Target)), "no field Primary_Unit"); - return Get_Field1 (Target); + return Get_Field2 (Target); end Get_Primary_Unit; procedure Set_Primary_Unit (Target : Iir; Unit : Iir) is @@ -2653,7 +2711,7 @@ package body Iirs is pragma Assert (Target /= Null_Iir); pragma Assert (Has_Primary_Unit (Get_Kind (Target)), "no field Primary_Unit"); - Set_Field1 (Target, Unit); + Set_Field2 (Target, Unit); end Set_Primary_Unit; function Get_Identifier (Target : Iir) return Name_Id is diff --git a/src/vhdl/iirs.adb.in b/src/vhdl/iirs.adb.in index a4b789570..b5f06705e 100644 --- a/src/vhdl/iirs.adb.in +++ b/src/vhdl/iirs.adb.in @@ -74,14 +74,7 @@ package body Iirs is Num (Kind) := Num (Kind) + 1; Format := Get_Format (Kind); Formats (Format) := Formats (Format) + 1; - case Format is - when Format_Medium => - I := I + 2; - when Format_Short - | Format_Fp - | Format_Int => - I := I + 1; - end case; + I := Next_Node (I); end loop; Put_Line ("Stats per iir_kind:"); @@ -131,18 +124,19 @@ package body Iirs is return Res; end Create_Iir_Error; - procedure Location_Copy (Target: Iir; Src: Iir) is + procedure Location_Copy (Target : Iir; Src : Iir) is begin Set_Location (Target, Get_Location (Src)); end Location_Copy; -- Get kind - function Get_Kind (An_Iir: Iir) return Iir_Kind + function Get_Kind (N : Iir) return Iir_Kind is -- Speed up: avoid to check that nkind is in the bounds of Iir_Kind. pragma Suppress (Range_Check); begin - return Iir_Kind'Val (Get_Nkind (An_Iir)); + pragma Assert (N /= Null_Iir); + return Iir_Kind'Val (Get_Nkind (N)); end Get_Kind; function Time_Stamp_Id_To_Iir is new Ada.Unchecked_Conversion diff --git a/src/vhdl/iirs.ads b/src/vhdl/iirs.ads index af9c7478b..9310185c5 100644 --- a/src/vhdl/iirs.ads +++ b/src/vhdl/iirs.ads @@ -161,7 +161,7 @@ package Iirs is -- -- Get the kind of the iir. -- See below for the (public) list of kinds. - -- function Get_Kind (An_Iir: Iir) return Iir_Kind; + -- function Get_Kind (N : Iir) return Iir_Kind; -- Get the location of the node: ie the current position in the source -- file when the node was created. This is a little bit fuzzy. @@ -314,7 +314,7 @@ package Iirs is -- -- Base of the bit_string (corresponds to letters 'b', 'o', 'd' or 'x' in -- the base specifier). - -- Get/Set_Bit_String_Base (Odigit1) + -- Get/Set_Bit_String_Base (Flag12,Flag13,Flag14) -- -- Get/Set_Expr_Staticness (State1) -- @@ -328,10 +328,10 @@ package Iirs is -- True if the integer specifying the length is present. -- Get/Set_Has_Length (Flag3) - -- Iir_Kind_Integer_Literal (Int) + -- Iir_Kind_Integer_Literal (Short) -- -- Get/Set the value of the integer. - -- Get/Set_Value (Int64) + -- Get/Set_Value (Field4,Field5) -- -- Get/Set_Literal_Origin (Field2) -- @@ -339,10 +339,10 @@ package Iirs is -- -- Get/Set_Expr_Staticness (State1) - -- Iir_Kind_Floating_Point_Literal (Fp) + -- Iir_Kind_Floating_Point_Literal (Short) -- -- The value of the literal. - -- Get/Set_Fp_Value (Fp64) + -- Get/Set_Fp_Value (Field4,Field5) -- -- Get/Set_Literal_Origin (Field2) -- @@ -357,8 +357,8 @@ package Iirs is -- -- Get/Set_Expr_Staticness (State1) - -- Iir_Kind_Physical_Int_Literal (Int) - -- Iir_Kind_Physical_Fp_Literal (Fp) + -- Iir_Kind_Physical_Int_Literal (Short) + -- Iir_Kind_Physical_Fp_Literal (Short) -- -- Get/Set_Literal_Origin (Field2) -- @@ -375,11 +375,11 @@ package Iirs is -- -- Only for Iir_Kind_Physical_Int_Literal: -- The multiplicand. - -- Get/Set_Value (Int64) + -- Get/Set_Value (Field4,Field5) -- -- Only for Iir_Kind_Physical_Fp_Literal: -- The multiplicand. - -- Get/Set_Fp_Value (Fp64) + -- Get/Set_Fp_Value (Field4,Field5) -- Iir_Kind_Simple_Aggregate (Short) -- This node can only be generated by evaluation: it is an unidimentional @@ -1215,7 +1215,7 @@ package Iirs is -- present for uniformity (and speed). -- Get/Set_Type (Field1) -- - -- Get/Set_Mode (Odigit1) + -- Get/Set_Mode (Flag12,Flag13,Flag14) -- -- Only for Iir_Kind_Interface_Signal_Declaration: -- Get/Set_Has_Disconnect_Flag (Flag1) @@ -1244,7 +1244,7 @@ package Iirs is -- Get/Set_Has_Class (Flag11) -- -- Only for Iir_Kind_Interface_Signal_Declaration: - -- Get/Set_Open_Flag (Flag12) + -- Get/Set_Open_Flag (Flag15) -- -- Get/Set_Expr_Staticness (State1) -- @@ -1708,7 +1708,7 @@ package Iirs is -- Get/Set_File_Open_Kind (Field7) -- -- This is used only in vhdl 87. - -- Get/Set_Mode (Odigit1) + -- Get/Set_Mode (Flag12,Flag13,Flag14) -- -- Get/Set_Has_Identifier_List (Flag3) -- @@ -2072,8 +2072,11 @@ package Iirs is -- Iir_Kind_Physical_Type_Definition (Short) -- - -- Get/Set_Unit_Chain (Field1) - -- Get/Set_Primary_Unit (Alias Field1) + -- The range_constraint from the type declaration. + -- Get/Set_Range_Constraint (Field1) + -- + -- Get/Set_Unit_Chain (Field2) + -- Get/Set_Primary_Unit (Alias Field2) -- -- Get/Set_Type_Declarator (Field3) -- @@ -2087,6 +2090,8 @@ package Iirs is -- -- Get/Set_Type_Staticness (State1) -- + -- Get/Set_Is_Ref (Flag7) + -- -- Get/Set_End_Has_Reserved_Id (Flag8) -- -- Get/Set_End_Has_Identifier (Flag9) @@ -2111,12 +2116,10 @@ package Iirs is -- -- Get/Set_Identifier (Field3) -- - -- The value of the unit, computed from the primary unit. This is always - -- a physical integer literal. - -- Get/Set_Physical_Unit_Value (Field5) - -- - -- The Physical_Literal is the expression that appear in the sources, so - -- this is Null_Iir for a primary unit. + -- The Physical_Literal is the expression that defines the value of a + -- unit. It is evaluated during analysis and thus expressed as a multiple + -- of the primary unit. That's true even for the primary unit whose value + -- is thus 1. -- Get/Set_Physical_Literal (Field4) -- -- Get/Set_Expr_Staticness (State1) @@ -2138,6 +2141,9 @@ package Iirs is -- Iir_Kind_Integer_Type_Definition (Short) -- Iir_Kind_Floating_Type_Definition (Short) -- + -- The range_constraint from the type declaration. + -- Get/Set_Range_Constraint (Field1) + -- -- The type declarator that has created this type. -- Get/Set_Type_Declarator (Field3) -- @@ -2151,6 +2157,8 @@ package Iirs is -- Get/Set_Signal_Type_Flag (Flag2) -- -- Get/Set_Has_Signal_Flag (Flag3) + -- + -- Get/Set_Is_Ref (Flag7) -- Iir_Kind_Array_Type_Definition (Medium) -- @@ -5566,23 +5574,23 @@ package Iirs is -- General methods. -- Get the kind of the iir. - function Get_Kind (An_Iir: Iir) return Iir_Kind; + function Get_Kind (N : Iir) return Iir_Kind; pragma Inline (Get_Kind); -- Create a new IIR of kind NEW_KIND, and copy fields from SRC to this -- iir. Src fields are cleaned. --function Clone_Iir (Src: Iir; New_Kind : Iir_Kind) return Iir; - procedure Set_Location (Target: Iir; Location: Location_Type) + procedure Set_Location (Target : Iir; Location : Location_Type) renames Nodes.Set_Location; - function Get_Location (Target: Iir) return Location_Type + function Get_Location (Target : Iir) return Location_Type renames Nodes.Get_Location; - procedure Location_Copy (Target: Iir; Src: Iir); + procedure Location_Copy (Target : Iir; Src : Iir); - function Create_Iir (Kind: Iir_Kind) return Iir; + function Create_Iir (Kind : Iir_Kind) return Iir; function Create_Iir_Error return Iir; - procedure Free_Iir (Target: Iir) renames Nodes.Free_Node; + procedure Free_Iir (Target : Iir) renames Nodes.Free_Node; -- Disp statistics about node usage. procedure Disp_Stats; @@ -5718,7 +5726,7 @@ package Iirs is -- literals. -- Value of an integer/physical literal. - -- Field: Int64 + -- Field: Field4,Field5 (grp) function Get_Value (Lit : Iir) return Iir_Int64; procedure Set_Value (Lit : Iir; Val : Iir_Int64); @@ -5727,17 +5735,12 @@ package Iirs is function Get_Enum_Pos (Lit : Iir) return Iir_Int32; procedure Set_Enum_Pos (Lit : Iir; Val : Iir_Int32); - -- Field: Field4 Ref + -- Field: Field4 function Get_Physical_Literal (Unit : Iir) return Iir; procedure Set_Physical_Literal (Unit : Iir; Lit : Iir); - -- Value of a physical unit declaration. - -- Field: Field5 - function Get_Physical_Unit_Value (Unit : Iir) return Iir; - procedure Set_Physical_Unit_Value (Unit : Iir; Lit : Iir); - -- Value of a floating point literal. - -- Field: Fp64 + -- Field: Field4,Field5 (grp) function Get_Fp_Value (Lit : Iir) return Iir_Fp64; procedure Set_Fp_Value (Lit : Iir; Val : Iir_Fp64); @@ -5757,7 +5760,7 @@ package Iirs is procedure Set_String_Length (Lit : Iir; Len : Int32); -- Base of a bit string. Base_None for a string literal. - -- Field: Odigit1 (pos) + -- Field: Flag12,Flag13,Flag14 (grp) function Get_Bit_String_Base (Lit : Iir) return Number_Base_Type; procedure Set_Bit_String_Base (Lit : Iir; Base : Number_Base_Type); @@ -5866,7 +5869,7 @@ package Iirs is -- This flag is set for a very short time during the check that no in -- port is unconnected. - -- Field: Flag12 + -- Field: Flag15 function Get_Open_Flag (Target : Iir) return Boolean; procedure Set_Open_Flag (Target : Iir; Flag : Boolean); @@ -6033,7 +6036,7 @@ package Iirs is -- Discrete range of an iterator. During analysis, a subtype indiciation -- is created from this range. - -- Field: Field6 Ref + -- Field: Field6 function Get_Discrete_Range (Target : Iir) return Iir; procedure Set_Discrete_Range (Target : Iir; Rng : Iir); @@ -6061,7 +6064,7 @@ package Iirs is procedure Set_Nature (Target : Iir; Nature : Iir); -- Mode of interfaces or file (v87). - -- Field: Odigit1 (pos) + -- Field: Flag12,Flag13,Flag14 (grp) function Get_Mode (Target : Iir) return Iir_Mode; procedure Set_Mode (Target : Iir; Mode : Iir_Mode); @@ -6264,13 +6267,13 @@ package Iirs is -- Chain of physical type units. -- The first unit is the primary unit. If you really need the primary -- unit (and not the chain), you'd better to use Get_Primary_Unit. - -- Field: Field1 Chain + -- Field: Field2 Chain function Get_Unit_Chain (Target : Iir) return Iir; procedure Set_Unit_Chain (Target : Iir; Chain : Iir); -- Alias of Get_Unit_Chain. -- Return the primary unit of a physical type. - -- Field: Field1 Ref + -- Field: Field2 Ref function Get_Primary_Unit (Target : Iir) return Iir; procedure Set_Primary_Unit (Target : Iir; Unit : Iir); diff --git a/src/vhdl/iirs_utils.adb b/src/vhdl/iirs_utils.adb index 19966f306..cf1ecee5b 100644 --- a/src/vhdl/iirs_utils.adb +++ b/src/vhdl/iirs_utils.adb @@ -461,17 +461,24 @@ package body Iirs_Utils is return; end if; - case Get_Kind (Unit) is - when Iir_Kind_Design_Unit - | Iir_Kind_Entity_Aspect_Entity => - null; - when others => - Error_Kind ("add_dependence", Unit); - end case; + pragma Assert (Kind_In (Unit, Iir_Kind_Design_Unit, + Iir_Kind_Entity_Aspect_Entity)); Add_Element (Get_Dependence_List (Target), Unit); end Add_Dependence; + function Get_Unit_From_Dependence (Dep : Iir) return Iir is + begin + case Get_Kind (Dep) is + when Iir_Kind_Design_Unit => + return Dep; + when Iir_Kind_Entity_Aspect_Entity => + return Get_Design_Unit (Get_Entity (Dep)); + when others => + Error_Kind ("get_unit_from_dependence", Dep); + end case; + end Get_Unit_From_Dependence; + procedure Clear_Instantiation_Configuration_Vhdl87 (Parent : Iir; In_Generate : Boolean; Full : Boolean) is diff --git a/src/vhdl/iirs_utils.ads b/src/vhdl/iirs_utils.ads index 843adce7c..fb3f34b8c 100644 --- a/src/vhdl/iirs_utils.ads +++ b/src/vhdl/iirs_utils.ads @@ -96,6 +96,10 @@ package Iirs_Utils is -- UNIT must be either a design unit or a entity_aspect_entity. procedure Add_Dependence (Target: Iir_Design_Unit; Unit: Iir); + -- Get the design_unit from dependency DEP. DEP must be an element of + -- a dependencies list. + function Get_Unit_From_Dependence (Dep : Iir) return Iir; + -- Clear configuration field of all component instantiation of -- the concurrent statements of PARENT. procedure Clear_Instantiation_Configuration (Parent : Iir; Full : Boolean); diff --git a/src/vhdl/nodes.adb b/src/vhdl/nodes.adb index 884f9d69b..ef22fb028 100644 --- a/src/vhdl/nodes.adb +++ b/src/vhdl/nodes.adb @@ -27,10 +27,6 @@ package body Nodes is -- Null_Node or Error_Node). --pragma Suppress (Index_Check); - -- Suppress discriminant checks on the table. Relatively safe, since - -- iirs do their own checks. - pragma Suppress (Discriminant_Check); - package Nodet is new Tables (Table_Component_Type => Node_Record, Table_Index_Type => Node_Type, @@ -44,62 +40,38 @@ package body Nodes is Free_Chain : Node_Type := Null_Node; - -- Just to have the default value. - pragma Warnings (Off); - Init_Short : Node_Record (Format_Short); - Init_Medium : Node_Record (Format_Medium); - Init_Fp : Node_Record (Format_Fp); - Init_Int : Node_Record (Format_Int); - pragma Warnings (On); - function Create_Node (Format : Format_Type) return Node_Type is Res : Node_Type; begin - if Format = Format_Medium then - -- Allocate a first node. - Nodet.Increment_Last; - Res := Nodet.Last; - -- Check alignment. - if Res mod 2 = 1 then - Set_Field1 (Res, Free_Chain); - Free_Chain := Res; + case Format is + when Format_Medium => + -- Allocate a first node. Nodet.Increment_Last; Res := Nodet.Last; - end if; - -- Allocate the second node. - Nodet.Increment_Last; - Nodet.Table (Res) := Init_Medium; - Nodet.Table (Res + 1) := Init_Medium; - else - -- Check from free pool - if Free_Chain = Null_Node then + -- Check alignment. + if Res mod 2 = 1 then + Set_Field1 (Res, Free_Chain); + Free_Chain := Res; + Nodet.Increment_Last; + Res := Nodet.Last; + end if; + -- Allocate the second node. Nodet.Increment_Last; - Res := Nodet.Last; - else - Res := Free_Chain; - Free_Chain := Get_Field1 (Res); - end if; - case Format is - when Format_Short => - -- Inline initialization for speed. - Nodet.Table (Res) := Node_Record' - (Format => Format_Short, - Kind => 0, - State1 | State2 => 0, - Odigit1 => 0, - Location => Location_Nil, - Field0 | Field1 | Field2 | Field3 => Null_Node, - Field4 | Field5 => Null_Node, - others => False); - when Format_Medium => - raise Program_Error; - when Format_Fp => - Nodet.Table (Res) := Init_Fp; - when Format_Int => - Nodet.Table (Res) := Init_Int; - end case; - end if; + Nodet.Table (Res) := Init_Node; + Nodet.Table (Res).Format := Format_Medium; + Nodet.Table (Res + 1) := Init_Node; + when Format_Short => + -- Check from free pool + if Free_Chain = Null_Node then + Nodet.Increment_Last; + Res := Nodet.Last; + else + Res := Free_Chain; + Free_Chain := Get_Field1 (Res); + end if; + Nodet.Table (Res) := Init_Node; + end case; return Res; end Create_Node; @@ -122,9 +94,7 @@ package body Nodes is case Nodet.Table (N).Format is when Format_Medium => return N + 2; - when Format_Short - | Format_Int - | Format_Fp => + when Format_Short => return N + 1; end case; end Next_Node; @@ -403,6 +373,36 @@ package body Nodes is Nodet.Table (N).Flag12 := V; end Set_Flag12; + function Get_Flag13 (N : Node_Type) return Boolean is + begin + return Nodet.Table (N).Flag13; + end Get_Flag13; + + procedure Set_Flag13 (N : Node_Type; V : Boolean) is + begin + Nodet.Table (N).Flag13 := V; + end Set_Flag13; + + function Get_Flag14 (N : Node_Type) return Boolean is + begin + return Nodet.Table (N).Flag14; + end Get_Flag14; + + procedure Set_Flag14 (N : Node_Type; V : Boolean) is + begin + Nodet.Table (N).Flag14 := V; + end Set_Flag14; + + function Get_Flag15 (N : Node_Type) return Boolean is + begin + return Nodet.Table (N).Flag15; + end Get_Flag15; + + procedure Set_Flag15 (N : Node_Type; V : Boolean) is + begin + Nodet.Table (N).Flag15 := V; + end Set_Flag15; + function Get_State1 (N : Node_Type) return Bit2_Type is begin @@ -444,49 +444,6 @@ package body Nodes is Nodet.Table (N + 1).State2 := V; end Set_State4; - - function Get_Odigit1 (N : Node_Type) return Bit3_Type is - begin - return Nodet.Table (N).Odigit1; - end Get_Odigit1; - - procedure Set_Odigit1 (N : Node_Type; V : Bit3_Type) is - begin - Nodet.Table (N).Odigit1 := V; - end Set_Odigit1; - - function Get_Odigit2 (N : Node_Type) return Bit3_Type is - begin - return Nodet.Table (N + 1).Odigit1; - end Get_Odigit2; - - procedure Set_Odigit2 (N : Node_Type; V : Bit3_Type) is - begin - Nodet.Table (N + 1).Odigit1 := V; - end Set_Odigit2; - - - function Get_Fp64 (N : Node_Type) return Iir_Fp64 is - begin - return Nodet.Table (N).Fp64; - end Get_Fp64; - - procedure Set_Fp64 (N : Node_Type; V : Iir_Fp64) is - begin - Nodet.Table (N).Fp64 := V; - end Set_Fp64; - - - function Get_Int64 (N : Node_Type) return Iir_Int64 is - begin - return Nodet.Table (N).Int64; - end Get_Int64; - - procedure Set_Int64 (N : Node_Type; V : Iir_Int64) is - begin - Nodet.Table (N).Int64 := V; - end Set_Int64; - procedure Initialize is begin Nodet.Free; diff --git a/src/vhdl/nodes.ads b/src/vhdl/nodes.ads index f816a560b..b3fe3fd7d 100644 --- a/src/vhdl/nodes.ads +++ b/src/vhdl/nodes.ads @@ -34,9 +34,7 @@ package Nodes is type Format_Type is ( Format_Short, - Format_Medium, - Format_Fp, - Format_Int + Format_Medium ); -- Common fields are: @@ -52,32 +50,25 @@ package Nodes is -- Flag10 : Boolean -- Flag11 : Boolean -- Flag12 : Boolean + -- Flag13 : Boolean + -- Flag14 : Boolean + -- Flag15 : Boolean -- Nkind : Kind_Type -- State1 : Bit2_Type -- State2 : Bit2_Type - -- Odigit1 : Bit3_Type -- Location : Location_Type -- Field0 : Iir -- Field1 : Iir -- Field2 : Iir -- Field3 : Iir - - -- Fields of Format_Fp: - -- Fp64 : Iir_Fp64 - - -- Fields of Format_Int: - -- Int64 : Iir_Int64 - - -- Fields of Format_Short: -- Field4 : Iir -- Field5 : Iir + -- Fields of Format_Short: + -- Fields of Format_Medium: - -- Odigit2 : Bit3_Type (odigit1) -- State3 : Bit2_Type -- State4 : Bit2_Type - -- Field4 : Iir - -- Field5 : Iir -- Field6 : Iir (location) -- Field7 : Iir (field0) -- Field8 : Iir (field1) @@ -227,6 +218,21 @@ package Nodes is procedure Set_Flag12 (N : Node_Type; V : Boolean); pragma Inline (Set_Flag12); + function Get_Flag13 (N : Node_Type) return Boolean; + pragma Inline (Get_Flag13); + procedure Set_Flag13 (N : Node_Type; V : Boolean); + pragma Inline (Set_Flag13); + + function Get_Flag14 (N : Node_Type) return Boolean; + pragma Inline (Get_Flag14); + procedure Set_Flag14 (N : Node_Type; V : Boolean); + pragma Inline (Set_Flag14); + + function Get_Flag15 (N : Node_Type) return Boolean; + pragma Inline (Get_Flag15); + procedure Set_Flag15 (N : Node_Type; V : Boolean); + pragma Inline (Set_Flag15); + function Get_State1 (N : Node_Type) return Bit2_Type; pragma Inline (Get_State1); @@ -248,28 +254,6 @@ package Nodes is procedure Set_State4 (N : Node_Type; V : Bit2_Type); pragma Inline (Set_State4); - - function Get_Odigit1 (N : Node_Type) return Bit3_Type; - pragma Inline (Get_Odigit1); - procedure Set_Odigit1 (N : Node_Type; V : Bit3_Type); - pragma Inline (Set_Odigit1); - - function Get_Odigit2 (N : Node_Type) return Bit3_Type; - pragma Inline (Get_Odigit2); - procedure Set_Odigit2 (N : Node_Type; V : Bit3_Type); - pragma Inline (Set_Odigit2); - - - function Get_Fp64 (N : Node_Type) return Iir_Fp64; - pragma Inline (Get_Fp64); - procedure Set_Fp64 (N : Node_Type; V : Iir_Fp64); - pragma Inline (Set_Fp64); - - function Get_Int64 (N : Node_Type) return Iir_Int64; - pragma Inline (Get_Int64); - procedure Set_Int64 (N : Node_Type; V : Iir_Int64); - pragma Inline (Set_Int64); - -- Get the last node allocated. function Get_Last_Node return Node_Type; pragma Inline (Get_Last_Node); @@ -277,52 +261,60 @@ package Nodes is -- Free all and reinit. procedure Initialize; private - type Node_Record (Format : Format_Type := Format_Short) is record - Flag1 : Boolean := False; - Flag2 : Boolean := False; - Flag3 : Boolean := False; - Flag4 : Boolean := False; - Flag5 : Boolean := False; - Flag6 : Boolean := False; - Flag7 : Boolean := False; - Flag8 : Boolean := False; - Flag9 : Boolean := False; - Flag10 : Boolean := False; - - Flag11 : Boolean := False; - Flag12 : Boolean := False; - Flag13 : Boolean := False; - Flag14 : Boolean := False; - - -- 2*2 + 1*3 = 7 bits - State1 : Bit2_Type := 0; - State2 : Bit2_Type := 0; - Odigit1 : Bit3_Type := 0; + type Node_Record is record + -- First byte: + Format : Format_Type; + Flag1 : Boolean; + Flag2 : Boolean; + Flag3 : Boolean; + Flag4 : Boolean; + Flag5 : Boolean; + Flag6 : Boolean; + Flag7 : Boolean; + + -- Second byte: + Flag8 : Boolean; + Flag9 : Boolean; + Flag10 : Boolean; + Flag11 : Boolean; + Flag12 : Boolean; + Flag13 : Boolean; + Flag14 : Boolean; + Flag15 : Boolean; + + -- Third byte: + Flag16 : Boolean; + Flag17 : Boolean; + Flag18 : Boolean; + + -- 2*2 = 4 bits + State1 : Bit2_Type; + State2 : Bit2_Type; -- 9 bits Kind : Kind_Type; -- Location. - Location: Location_Type := Location_Nil; - - Field0 : Node_Type := Null_Node; - Field1 : Node_Type := Null_Node; - Field2 : Node_Type := Null_Node; - Field3 : Node_Type := Null_Node; - - case Format is - when Format_Short - | Format_Medium => - Field4: Node_Type := Null_Node; - Field5: Node_Type := Null_Node; - when Format_Fp => - Fp64 : Iir_Fp64; - when Format_Int => - Int64 : Iir_Int64; - end case; + Location: Location_Type; + + Field0 : Node_Type; + Field1 : Node_Type; + Field2 : Node_Type; + Field3 : Node_Type; + Field4 : Node_Type; + Field5 : Node_Type; end record; - pragma Pack (Node_Record); for Node_Record'Size use 8*32; for Node_Record'Alignment use 4; + pragma Suppress_Initialization (Node_Record); + + Init_Node : constant Node_Record := Node_Record' + (Format => Format_Short, + Kind => 0, + State1 | State2 => 0, + Location => Location_Nil, + Field0 | Field1 | Field2 | Field3 | Field4 | Field5 => Null_Node, + others => False); + end Nodes; diff --git a/src/vhdl/nodes_gc.adb b/src/vhdl/nodes_gc.adb index 9b1c34cf7..99343222f 100644 --- a/src/vhdl/nodes_gc.adb +++ b/src/vhdl/nodes_gc.adb @@ -17,11 +17,11 @@ -- 02111-1307, USA. with Ada.Text_IO; +with Ada.Unchecked_Deallocation; with Types; use Types; with Nodes; with Nodes_Meta; use Nodes_Meta; with Errorout; use Errorout; -with Iirs; use Iirs; with Libraries; with Disp_Tree; with Std_Package; @@ -35,6 +35,9 @@ package body Nodes_GC is Markers : Marker_Array_Acc; + procedure Free is new Ada.Unchecked_Deallocation + (Marker_Array, Marker_Array_Acc); + procedure Mark_Iir (N : Iir); procedure Mark_Iir_List (N : Iir_List) @@ -242,6 +245,8 @@ package body Nodes_GC is return; end if; + Markers (Get_Design_File (Unit)) := True; + -- First mark dependences List := Get_Dependence_List (Unit); if List /= Null_Iir_List then @@ -273,12 +278,11 @@ package body Nodes_GC is Mark_Iir (Unit); end Mark_Unit; - procedure Report_Unreferenced + -- Initialize the mark process. Create the array and mark some unrooted + -- but referenced nodes in std_package. + procedure Mark_Init is - use Ada.Text_IO; use Std_Package; - El : Iir; - Nbr_Unreferenced : Natural; begin Markers := new Marker_Array'(Null_Iir .. Iirs.Get_Last_Node => False); @@ -287,7 +291,29 @@ package body Nodes_GC is -- Node not owned, but used for "/" (time, time). Markers (Convertible_Integer_Type_Definition) := True; Markers (Convertible_Real_Type_Definition) := True; + end Mark_Init; + + -- Marks known nodes that aren't owned. + procedure Mark_Not_Owned + is + use Std_Package; + begin + -- These nodes are owned by type/subtype declarations, so unmark them + -- before marking their owner. + Markers (Convertible_Integer_Type_Definition) := False; + Markers (Convertible_Real_Type_Definition) := False; + + -- These nodes are not rooted. + Mark_Iir (Convertible_Integer_Type_Declaration); + Mark_Iir (Convertible_Integer_Subtype_Declaration); + Mark_Iir (Convertible_Real_Type_Declaration); + Mark_Iir (Universal_Integer_One); + Mark_Chain (Wildcard_Type_Declaration_Chain); + Mark_Iir (Error_Mark); + end Mark_Not_Owned; + procedure Mark_Units_Of_All_Libraries is + begin -- The user nodes. declare Lib : Iir; @@ -355,20 +381,20 @@ package body Nodes_GC is Unit := Get_Chain (Unit); end loop; end; + end Mark_Units_Of_All_Libraries; - -- These nodes are owned by type/subtype declarations, so unmark them - -- before marking their owner. - Markers (Convertible_Integer_Type_Definition) := False; - Markers (Convertible_Real_Type_Definition) := False; - - -- These nodes are not rooted. - Mark_Iir (Convertible_Integer_Type_Declaration); - Mark_Iir (Convertible_Integer_Subtype_Declaration); - Mark_Iir (Convertible_Real_Type_Declaration); - Mark_Iir (Universal_Integer_One); - Mark_Chain (Wildcard_Type_Declaration_Chain); - Mark_Iir (Error_Mark); + procedure Report_Unreferenced + is + use Ada.Text_IO; + use Std_Package; + El : Iir; + Nbr_Unreferenced : Natural; + begin + Mark_Init; + Mark_Units_Of_All_Libraries; + Mark_Not_Owned; + -- Iterate on all nodes, and report nodes not marked. El := Error_Mark; Nbr_Unreferenced := 0; while El in Markers'Range loop @@ -382,8 +408,20 @@ package body Nodes_GC is El := Iir (Nodes.Next_Node (Nodes.Node_Type (El))); end loop; + Free (Markers); + if Has_Error then raise Internal_Error; end if; end Report_Unreferenced; + + procedure Check_Tree (Unit : Iir) is + begin + Mark_Init; + Mark_Unit (Unit); + Free (Markers); + if Has_Error then + raise Internal_Error; + end if; + end Check_Tree; end Nodes_GC; diff --git a/src/vhdl/nodes_gc.ads b/src/vhdl/nodes_gc.ads index ad17c67b7..9b92b9e8b 100644 --- a/src/vhdl/nodes_gc.ads +++ b/src/vhdl/nodes_gc.ads @@ -16,9 +16,14 @@ -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. +with Iirs; use Iirs; + package Nodes_GC is Flag_Disp_Multiref : Boolean := True; + -- Perform an internal check on the tree structure of UNIT. + procedure Check_Tree (Unit : Iir); + procedure Report_Unreferenced; -- Display nodes that aren't referenced. end Nodes_GC; diff --git a/src/vhdl/nodes_meta.adb b/src/vhdl/nodes_meta.adb index 6a4f27355..98c34d187 100644 --- a/src/vhdl/nodes_meta.adb +++ b/src/vhdl/nodes_meta.adb @@ -45,7 +45,6 @@ package body Nodes_Meta is Field_Value => Type_Iir_Int64, Field_Enum_Pos => Type_Iir_Int32, Field_Physical_Literal => Type_Iir, - Field_Physical_Unit_Value => Type_Iir, Field_Fp_Value => Type_Iir_Fp64, Field_Simple_Aggregate_List => Type_Iir_List, Field_String8_Id => Type_String8_Id, @@ -407,8 +406,6 @@ package body Nodes_Meta is return "enum_pos"; when Field_Physical_Literal => return "physical_literal"; - when Field_Physical_Unit_Value => - return "physical_unit_value"; when Field_Fp_Value => return "fp_value"; when Field_Simple_Aggregate_List => @@ -1598,8 +1595,6 @@ package body Nodes_Meta is when Field_Enum_Pos => return Attr_None; when Field_Physical_Literal => - return Attr_Ref; - when Field_Physical_Unit_Value => return Attr_None; when Field_Fp_Value => return Attr_None; @@ -1720,7 +1715,7 @@ package body Nodes_Meta is when Field_Subtype_Indication => return Attr_None; when Field_Discrete_Range => - return Attr_Ref; + return Attr_None; when Field_Type_Definition => return Attr_None; when Field_Subtype_Definition => @@ -2276,9 +2271,9 @@ package body Nodes_Meta is Field_String_Length, Field_String8_Id, Field_Has_Signed, + Field_Bit_String_Base, Field_Has_Sign, Field_Has_Length, - Field_Bit_String_Base, Field_Expr_Staticness, Field_Literal_Origin, Field_Literal_Subtype, @@ -2659,23 +2654,29 @@ package body Nodes_Meta is Field_Resolved_Flag, Field_Signal_Type_Flag, Field_Has_Signal_Flag, + Field_Is_Ref, Field_Type_Staticness, + Field_Range_Constraint, Field_Type_Declarator, Field_Base_Type, -- Iir_Kind_Floating_Type_Definition Field_Resolved_Flag, Field_Signal_Type_Flag, Field_Has_Signal_Flag, + Field_Is_Ref, Field_Type_Staticness, + Field_Range_Constraint, Field_Type_Declarator, Field_Base_Type, -- Iir_Kind_Physical_Type_Definition Field_Resolved_Flag, Field_Signal_Type_Flag, Field_Has_Signal_Flag, + Field_Is_Ref, Field_End_Has_Reserved_Id, Field_End_Has_Identifier, Field_Type_Staticness, + Field_Range_Constraint, Field_Unit_Chain, Field_Type_Declarator, Field_Base_Type, @@ -2845,7 +2846,6 @@ package body Nodes_Meta is Field_Parent, Field_Type, Field_Chain, - Field_Physical_Unit_Value, Field_Physical_Literal, -- Iir_Kind_Library_Declaration Field_Identifier, @@ -3074,10 +3074,10 @@ package body Nodes_Meta is -- Iir_Kind_File_Declaration Field_Identifier, Field_Has_Mode, + Field_Mode, Field_Has_Identifier_List, Field_Visible_Flag, Field_Use_Flag, - Field_Mode, Field_Expr_Staticness, Field_Name_Staticness, Field_Parent, @@ -3163,12 +3163,12 @@ package body Nodes_Meta is Field_Identifier, Field_Has_Mode, Field_Has_Class, + Field_Mode, Field_Has_Identifier_List, Field_Visible_Flag, Field_After_Drivers_Flag, Field_Use_Flag, Field_Is_Ref, - Field_Mode, Field_Expr_Staticness, Field_Name_Staticness, Field_Parent, @@ -3180,12 +3180,12 @@ package body Nodes_Meta is Field_Identifier, Field_Has_Mode, Field_Has_Class, + Field_Mode, Field_Has_Identifier_List, Field_Visible_Flag, Field_After_Drivers_Flag, Field_Use_Flag, Field_Is_Ref, - Field_Mode, Field_Expr_Staticness, Field_Name_Staticness, Field_Parent, @@ -3198,6 +3198,7 @@ package body Nodes_Meta is Field_Has_Disconnect_Flag, Field_Has_Mode, Field_Has_Class, + Field_Mode, Field_Open_Flag, Field_Has_Active_Flag, Field_Has_Identifier_List, @@ -3207,7 +3208,6 @@ package body Nodes_Meta is Field_Is_Ref, Field_Guarded_Signal_Flag, Field_Signal_Kind, - Field_Mode, Field_Expr_Staticness, Field_Name_Staticness, Field_Parent, @@ -3219,12 +3219,12 @@ package body Nodes_Meta is Field_Identifier, Field_Has_Mode, Field_Has_Class, + Field_Mode, Field_Has_Identifier_List, Field_Visible_Flag, Field_After_Drivers_Flag, Field_Use_Flag, Field_Is_Ref, - Field_Mode, Field_Expr_Staticness, Field_Name_Staticness, Field_Parent, @@ -4383,207 +4383,207 @@ package body Nodes_Meta is Iir_Kind_Integer_Subtype_Definition => 367, Iir_Kind_Enumeration_Subtype_Definition => 377, Iir_Kind_Enumeration_Type_Definition => 387, - Iir_Kind_Integer_Type_Definition => 393, - Iir_Kind_Floating_Type_Definition => 399, - Iir_Kind_Physical_Type_Definition => 408, - Iir_Kind_Range_Expression => 416, - Iir_Kind_Protected_Type_Body => 423, - Iir_Kind_Wildcard_Type_Definition => 428, - Iir_Kind_Subtype_Definition => 433, - Iir_Kind_Scalar_Nature_Definition => 437, - Iir_Kind_Overload_List => 438, - Iir_Kind_Type_Declaration => 445, - Iir_Kind_Anonymous_Type_Declaration => 451, - Iir_Kind_Subtype_Declaration => 458, - Iir_Kind_Nature_Declaration => 464, - Iir_Kind_Subnature_Declaration => 470, - Iir_Kind_Package_Declaration => 485, - Iir_Kind_Package_Instantiation_Declaration => 498, - Iir_Kind_Package_Body => 506, - Iir_Kind_Configuration_Declaration => 515, - Iir_Kind_Entity_Declaration => 527, - Iir_Kind_Architecture_Body => 539, - Iir_Kind_Context_Declaration => 545, - Iir_Kind_Package_Header => 547, - Iir_Kind_Unit_Declaration => 556, - Iir_Kind_Library_Declaration => 563, - Iir_Kind_Component_Declaration => 573, - Iir_Kind_Attribute_Declaration => 580, - Iir_Kind_Group_Template_Declaration => 586, - Iir_Kind_Group_Declaration => 593, - Iir_Kind_Element_Declaration => 600, - Iir_Kind_Non_Object_Alias_Declaration => 608, - Iir_Kind_Psl_Declaration => 616, - Iir_Kind_Psl_Endpoint_Declaration => 630, - Iir_Kind_Terminal_Declaration => 636, - Iir_Kind_Free_Quantity_Declaration => 645, - Iir_Kind_Across_Quantity_Declaration => 657, - Iir_Kind_Through_Quantity_Declaration => 669, - Iir_Kind_Enumeration_Literal => 680, - Iir_Kind_Function_Declaration => 705, - Iir_Kind_Procedure_Declaration => 729, - Iir_Kind_Function_Body => 739, - Iir_Kind_Procedure_Body => 750, - Iir_Kind_Object_Alias_Declaration => 761, - Iir_Kind_File_Declaration => 775, - Iir_Kind_Guard_Signal_Declaration => 788, - Iir_Kind_Signal_Declaration => 805, - Iir_Kind_Variable_Declaration => 818, - Iir_Kind_Constant_Declaration => 832, - Iir_Kind_Iterator_Declaration => 843, - Iir_Kind_Interface_Constant_Declaration => 859, - Iir_Kind_Interface_Variable_Declaration => 875, - Iir_Kind_Interface_Signal_Declaration => 896, - Iir_Kind_Interface_File_Declaration => 912, - Iir_Kind_Interface_Type_Declaration => 922, - Iir_Kind_Interface_Package_Declaration => 933, - Iir_Kind_Interface_Function_Declaration => 950, - Iir_Kind_Interface_Procedure_Declaration => 963, - Iir_Kind_Signal_Attribute_Declaration => 966, - Iir_Kind_Identity_Operator => 970, - Iir_Kind_Negation_Operator => 974, - Iir_Kind_Absolute_Operator => 978, - Iir_Kind_Not_Operator => 982, - Iir_Kind_Condition_Operator => 986, - Iir_Kind_Reduction_And_Operator => 990, - Iir_Kind_Reduction_Or_Operator => 994, - Iir_Kind_Reduction_Nand_Operator => 998, - Iir_Kind_Reduction_Nor_Operator => 1002, - Iir_Kind_Reduction_Xor_Operator => 1006, - Iir_Kind_Reduction_Xnor_Operator => 1010, - Iir_Kind_And_Operator => 1015, - Iir_Kind_Or_Operator => 1020, - Iir_Kind_Nand_Operator => 1025, - Iir_Kind_Nor_Operator => 1030, - Iir_Kind_Xor_Operator => 1035, - Iir_Kind_Xnor_Operator => 1040, - Iir_Kind_Equality_Operator => 1045, - Iir_Kind_Inequality_Operator => 1050, - Iir_Kind_Less_Than_Operator => 1055, - Iir_Kind_Less_Than_Or_Equal_Operator => 1060, - Iir_Kind_Greater_Than_Operator => 1065, - Iir_Kind_Greater_Than_Or_Equal_Operator => 1070, - Iir_Kind_Match_Equality_Operator => 1075, - Iir_Kind_Match_Inequality_Operator => 1080, - Iir_Kind_Match_Less_Than_Operator => 1085, - Iir_Kind_Match_Less_Than_Or_Equal_Operator => 1090, - Iir_Kind_Match_Greater_Than_Operator => 1095, - Iir_Kind_Match_Greater_Than_Or_Equal_Operator => 1100, - Iir_Kind_Sll_Operator => 1105, - Iir_Kind_Sla_Operator => 1110, - Iir_Kind_Srl_Operator => 1115, - Iir_Kind_Sra_Operator => 1120, - Iir_Kind_Rol_Operator => 1125, - Iir_Kind_Ror_Operator => 1130, - Iir_Kind_Addition_Operator => 1135, - Iir_Kind_Substraction_Operator => 1140, - Iir_Kind_Concatenation_Operator => 1145, - Iir_Kind_Multiplication_Operator => 1150, - Iir_Kind_Division_Operator => 1155, - Iir_Kind_Modulus_Operator => 1160, - Iir_Kind_Remainder_Operator => 1165, - Iir_Kind_Exponentiation_Operator => 1170, - Iir_Kind_Function_Call => 1178, - Iir_Kind_Aggregate => 1184, - Iir_Kind_Parenthesis_Expression => 1187, - Iir_Kind_Qualified_Expression => 1191, - Iir_Kind_Type_Conversion => 1196, - Iir_Kind_Allocator_By_Expression => 1200, - Iir_Kind_Allocator_By_Subtype => 1205, - Iir_Kind_Selected_Element => 1211, - Iir_Kind_Dereference => 1216, - Iir_Kind_Implicit_Dereference => 1221, - Iir_Kind_Slice_Name => 1228, - Iir_Kind_Indexed_Name => 1234, - Iir_Kind_Psl_Expression => 1236, - Iir_Kind_Sensitized_Process_Statement => 1256, - Iir_Kind_Process_Statement => 1276, - Iir_Kind_Concurrent_Simple_Signal_Assignment => 1287, - Iir_Kind_Concurrent_Conditional_Signal_Assignment => 1298, - Iir_Kind_Concurrent_Selected_Signal_Assignment => 1310, - Iir_Kind_Concurrent_Assertion_Statement => 1318, - Iir_Kind_Concurrent_Procedure_Call_Statement => 1325, - Iir_Kind_Psl_Assert_Statement => 1338, - Iir_Kind_Psl_Cover_Statement => 1351, - Iir_Kind_Block_Statement => 1364, - Iir_Kind_If_Generate_Statement => 1374, - Iir_Kind_Case_Generate_Statement => 1383, - Iir_Kind_For_Generate_Statement => 1392, - Iir_Kind_Component_Instantiation_Statement => 1402, - Iir_Kind_Psl_Default_Clock => 1406, - Iir_Kind_Simple_Simultaneous_Statement => 1413, - Iir_Kind_Generate_Statement_Body => 1424, - Iir_Kind_If_Generate_Else_Clause => 1429, - Iir_Kind_Simple_Signal_Assignment_Statement => 1438, - Iir_Kind_Conditional_Signal_Assignment_Statement => 1447, - Iir_Kind_Null_Statement => 1451, - Iir_Kind_Assertion_Statement => 1458, - Iir_Kind_Report_Statement => 1464, - Iir_Kind_Wait_Statement => 1471, - Iir_Kind_Variable_Assignment_Statement => 1477, - Iir_Kind_Conditional_Variable_Assignment_Statement => 1483, - Iir_Kind_Return_Statement => 1489, - Iir_Kind_For_Loop_Statement => 1498, - Iir_Kind_While_Loop_Statement => 1506, - Iir_Kind_Next_Statement => 1512, - Iir_Kind_Exit_Statement => 1518, - Iir_Kind_Case_Statement => 1526, - Iir_Kind_Procedure_Call_Statement => 1532, - Iir_Kind_If_Statement => 1541, - Iir_Kind_Elsif => 1546, - Iir_Kind_Character_Literal => 1554, - Iir_Kind_Simple_Name => 1562, - Iir_Kind_Selected_Name => 1571, - Iir_Kind_Operator_Symbol => 1577, - Iir_Kind_Reference_Name => 1580, - Iir_Kind_Selected_By_All_Name => 1586, - Iir_Kind_Parenthesis_Name => 1591, - Iir_Kind_External_Constant_Name => 1599, - Iir_Kind_External_Signal_Name => 1607, - Iir_Kind_External_Variable_Name => 1615, - Iir_Kind_Package_Pathname => 1619, - Iir_Kind_Absolute_Pathname => 1620, - Iir_Kind_Relative_Pathname => 1621, - Iir_Kind_Pathname_Element => 1626, - Iir_Kind_Base_Attribute => 1628, - Iir_Kind_Left_Type_Attribute => 1633, - Iir_Kind_Right_Type_Attribute => 1638, - Iir_Kind_High_Type_Attribute => 1643, - Iir_Kind_Low_Type_Attribute => 1648, - Iir_Kind_Ascending_Type_Attribute => 1653, - Iir_Kind_Image_Attribute => 1659, - Iir_Kind_Value_Attribute => 1665, - Iir_Kind_Pos_Attribute => 1671, - Iir_Kind_Val_Attribute => 1677, - Iir_Kind_Succ_Attribute => 1683, - Iir_Kind_Pred_Attribute => 1689, - Iir_Kind_Leftof_Attribute => 1695, - Iir_Kind_Rightof_Attribute => 1701, - Iir_Kind_Delayed_Attribute => 1710, - Iir_Kind_Stable_Attribute => 1719, - Iir_Kind_Quiet_Attribute => 1728, - Iir_Kind_Transaction_Attribute => 1737, - Iir_Kind_Event_Attribute => 1741, - Iir_Kind_Active_Attribute => 1745, - Iir_Kind_Last_Event_Attribute => 1749, - Iir_Kind_Last_Active_Attribute => 1753, - Iir_Kind_Last_Value_Attribute => 1757, - Iir_Kind_Driving_Attribute => 1761, - Iir_Kind_Driving_Value_Attribute => 1765, - Iir_Kind_Behavior_Attribute => 1765, - Iir_Kind_Structure_Attribute => 1765, - Iir_Kind_Simple_Name_Attribute => 1772, - Iir_Kind_Instance_Name_Attribute => 1777, - Iir_Kind_Path_Name_Attribute => 1782, - Iir_Kind_Left_Array_Attribute => 1789, - Iir_Kind_Right_Array_Attribute => 1796, - Iir_Kind_High_Array_Attribute => 1803, - Iir_Kind_Low_Array_Attribute => 1810, - Iir_Kind_Length_Array_Attribute => 1817, - Iir_Kind_Ascending_Array_Attribute => 1824, - Iir_Kind_Range_Array_Attribute => 1831, - Iir_Kind_Reverse_Range_Array_Attribute => 1838, - Iir_Kind_Attribute_Name => 1847 + Iir_Kind_Integer_Type_Definition => 395, + Iir_Kind_Floating_Type_Definition => 403, + Iir_Kind_Physical_Type_Definition => 414, + Iir_Kind_Range_Expression => 422, + Iir_Kind_Protected_Type_Body => 429, + Iir_Kind_Wildcard_Type_Definition => 434, + Iir_Kind_Subtype_Definition => 439, + Iir_Kind_Scalar_Nature_Definition => 443, + Iir_Kind_Overload_List => 444, + Iir_Kind_Type_Declaration => 451, + Iir_Kind_Anonymous_Type_Declaration => 457, + Iir_Kind_Subtype_Declaration => 464, + Iir_Kind_Nature_Declaration => 470, + Iir_Kind_Subnature_Declaration => 476, + Iir_Kind_Package_Declaration => 491, + Iir_Kind_Package_Instantiation_Declaration => 504, + Iir_Kind_Package_Body => 512, + Iir_Kind_Configuration_Declaration => 521, + Iir_Kind_Entity_Declaration => 533, + Iir_Kind_Architecture_Body => 545, + Iir_Kind_Context_Declaration => 551, + Iir_Kind_Package_Header => 553, + Iir_Kind_Unit_Declaration => 561, + Iir_Kind_Library_Declaration => 568, + Iir_Kind_Component_Declaration => 578, + Iir_Kind_Attribute_Declaration => 585, + Iir_Kind_Group_Template_Declaration => 591, + Iir_Kind_Group_Declaration => 598, + Iir_Kind_Element_Declaration => 605, + Iir_Kind_Non_Object_Alias_Declaration => 613, + Iir_Kind_Psl_Declaration => 621, + Iir_Kind_Psl_Endpoint_Declaration => 635, + Iir_Kind_Terminal_Declaration => 641, + Iir_Kind_Free_Quantity_Declaration => 650, + Iir_Kind_Across_Quantity_Declaration => 662, + Iir_Kind_Through_Quantity_Declaration => 674, + Iir_Kind_Enumeration_Literal => 685, + Iir_Kind_Function_Declaration => 710, + Iir_Kind_Procedure_Declaration => 734, + Iir_Kind_Function_Body => 744, + Iir_Kind_Procedure_Body => 755, + Iir_Kind_Object_Alias_Declaration => 766, + Iir_Kind_File_Declaration => 780, + Iir_Kind_Guard_Signal_Declaration => 793, + Iir_Kind_Signal_Declaration => 810, + Iir_Kind_Variable_Declaration => 823, + Iir_Kind_Constant_Declaration => 837, + Iir_Kind_Iterator_Declaration => 848, + Iir_Kind_Interface_Constant_Declaration => 864, + Iir_Kind_Interface_Variable_Declaration => 880, + Iir_Kind_Interface_Signal_Declaration => 901, + Iir_Kind_Interface_File_Declaration => 917, + Iir_Kind_Interface_Type_Declaration => 927, + Iir_Kind_Interface_Package_Declaration => 938, + Iir_Kind_Interface_Function_Declaration => 955, + Iir_Kind_Interface_Procedure_Declaration => 968, + Iir_Kind_Signal_Attribute_Declaration => 971, + Iir_Kind_Identity_Operator => 975, + Iir_Kind_Negation_Operator => 979, + Iir_Kind_Absolute_Operator => 983, + Iir_Kind_Not_Operator => 987, + Iir_Kind_Condition_Operator => 991, + Iir_Kind_Reduction_And_Operator => 995, + Iir_Kind_Reduction_Or_Operator => 999, + Iir_Kind_Reduction_Nand_Operator => 1003, + Iir_Kind_Reduction_Nor_Operator => 1007, + Iir_Kind_Reduction_Xor_Operator => 1011, + Iir_Kind_Reduction_Xnor_Operator => 1015, + Iir_Kind_And_Operator => 1020, + Iir_Kind_Or_Operator => 1025, + Iir_Kind_Nand_Operator => 1030, + Iir_Kind_Nor_Operator => 1035, + Iir_Kind_Xor_Operator => 1040, + Iir_Kind_Xnor_Operator => 1045, + Iir_Kind_Equality_Operator => 1050, + Iir_Kind_Inequality_Operator => 1055, + Iir_Kind_Less_Than_Operator => 1060, + Iir_Kind_Less_Than_Or_Equal_Operator => 1065, + Iir_Kind_Greater_Than_Operator => 1070, + Iir_Kind_Greater_Than_Or_Equal_Operator => 1075, + Iir_Kind_Match_Equality_Operator => 1080, + Iir_Kind_Match_Inequality_Operator => 1085, + Iir_Kind_Match_Less_Than_Operator => 1090, + Iir_Kind_Match_Less_Than_Or_Equal_Operator => 1095, + Iir_Kind_Match_Greater_Than_Operator => 1100, + Iir_Kind_Match_Greater_Than_Or_Equal_Operator => 1105, + Iir_Kind_Sll_Operator => 1110, + Iir_Kind_Sla_Operator => 1115, + Iir_Kind_Srl_Operator => 1120, + Iir_Kind_Sra_Operator => 1125, + Iir_Kind_Rol_Operator => 1130, + Iir_Kind_Ror_Operator => 1135, + Iir_Kind_Addition_Operator => 1140, + Iir_Kind_Substraction_Operator => 1145, + Iir_Kind_Concatenation_Operator => 1150, + Iir_Kind_Multiplication_Operator => 1155, + Iir_Kind_Division_Operator => 1160, + Iir_Kind_Modulus_Operator => 1165, + Iir_Kind_Remainder_Operator => 1170, + Iir_Kind_Exponentiation_Operator => 1175, + Iir_Kind_Function_Call => 1183, + Iir_Kind_Aggregate => 1189, + Iir_Kind_Parenthesis_Expression => 1192, + Iir_Kind_Qualified_Expression => 1196, + Iir_Kind_Type_Conversion => 1201, + Iir_Kind_Allocator_By_Expression => 1205, + Iir_Kind_Allocator_By_Subtype => 1210, + Iir_Kind_Selected_Element => 1216, + Iir_Kind_Dereference => 1221, + Iir_Kind_Implicit_Dereference => 1226, + Iir_Kind_Slice_Name => 1233, + Iir_Kind_Indexed_Name => 1239, + Iir_Kind_Psl_Expression => 1241, + Iir_Kind_Sensitized_Process_Statement => 1261, + Iir_Kind_Process_Statement => 1281, + Iir_Kind_Concurrent_Simple_Signal_Assignment => 1292, + Iir_Kind_Concurrent_Conditional_Signal_Assignment => 1303, + Iir_Kind_Concurrent_Selected_Signal_Assignment => 1315, + Iir_Kind_Concurrent_Assertion_Statement => 1323, + Iir_Kind_Concurrent_Procedure_Call_Statement => 1330, + Iir_Kind_Psl_Assert_Statement => 1343, + Iir_Kind_Psl_Cover_Statement => 1356, + Iir_Kind_Block_Statement => 1369, + Iir_Kind_If_Generate_Statement => 1379, + Iir_Kind_Case_Generate_Statement => 1388, + Iir_Kind_For_Generate_Statement => 1397, + Iir_Kind_Component_Instantiation_Statement => 1407, + Iir_Kind_Psl_Default_Clock => 1411, + Iir_Kind_Simple_Simultaneous_Statement => 1418, + Iir_Kind_Generate_Statement_Body => 1429, + Iir_Kind_If_Generate_Else_Clause => 1434, + Iir_Kind_Simple_Signal_Assignment_Statement => 1443, + Iir_Kind_Conditional_Signal_Assignment_Statement => 1452, + Iir_Kind_Null_Statement => 1456, + Iir_Kind_Assertion_Statement => 1463, + Iir_Kind_Report_Statement => 1469, + Iir_Kind_Wait_Statement => 1476, + Iir_Kind_Variable_Assignment_Statement => 1482, + Iir_Kind_Conditional_Variable_Assignment_Statement => 1488, + Iir_Kind_Return_Statement => 1494, + Iir_Kind_For_Loop_Statement => 1503, + Iir_Kind_While_Loop_Statement => 1511, + Iir_Kind_Next_Statement => 1517, + Iir_Kind_Exit_Statement => 1523, + Iir_Kind_Case_Statement => 1531, + Iir_Kind_Procedure_Call_Statement => 1537, + Iir_Kind_If_Statement => 1546, + Iir_Kind_Elsif => 1551, + Iir_Kind_Character_Literal => 1559, + Iir_Kind_Simple_Name => 1567, + Iir_Kind_Selected_Name => 1576, + Iir_Kind_Operator_Symbol => 1582, + Iir_Kind_Reference_Name => 1585, + Iir_Kind_Selected_By_All_Name => 1591, + Iir_Kind_Parenthesis_Name => 1596, + Iir_Kind_External_Constant_Name => 1604, + Iir_Kind_External_Signal_Name => 1612, + Iir_Kind_External_Variable_Name => 1620, + Iir_Kind_Package_Pathname => 1624, + Iir_Kind_Absolute_Pathname => 1625, + Iir_Kind_Relative_Pathname => 1626, + Iir_Kind_Pathname_Element => 1631, + Iir_Kind_Base_Attribute => 1633, + Iir_Kind_Left_Type_Attribute => 1638, + Iir_Kind_Right_Type_Attribute => 1643, + Iir_Kind_High_Type_Attribute => 1648, + Iir_Kind_Low_Type_Attribute => 1653, + Iir_Kind_Ascending_Type_Attribute => 1658, + Iir_Kind_Image_Attribute => 1664, + Iir_Kind_Value_Attribute => 1670, + Iir_Kind_Pos_Attribute => 1676, + Iir_Kind_Val_Attribute => 1682, + Iir_Kind_Succ_Attribute => 1688, + Iir_Kind_Pred_Attribute => 1694, + Iir_Kind_Leftof_Attribute => 1700, + Iir_Kind_Rightof_Attribute => 1706, + Iir_Kind_Delayed_Attribute => 1715, + Iir_Kind_Stable_Attribute => 1724, + Iir_Kind_Quiet_Attribute => 1733, + Iir_Kind_Transaction_Attribute => 1742, + Iir_Kind_Event_Attribute => 1746, + Iir_Kind_Active_Attribute => 1750, + Iir_Kind_Last_Event_Attribute => 1754, + Iir_Kind_Last_Active_Attribute => 1758, + Iir_Kind_Last_Value_Attribute => 1762, + Iir_Kind_Driving_Attribute => 1766, + Iir_Kind_Driving_Value_Attribute => 1770, + Iir_Kind_Behavior_Attribute => 1770, + Iir_Kind_Structure_Attribute => 1770, + Iir_Kind_Simple_Name_Attribute => 1777, + Iir_Kind_Instance_Name_Attribute => 1782, + Iir_Kind_Path_Name_Attribute => 1787, + Iir_Kind_Left_Array_Attribute => 1794, + Iir_Kind_Right_Array_Attribute => 1801, + Iir_Kind_High_Array_Attribute => 1808, + Iir_Kind_Low_Array_Attribute => 1815, + Iir_Kind_Length_Array_Attribute => 1822, + Iir_Kind_Ascending_Array_Attribute => 1829, + Iir_Kind_Range_Array_Attribute => 1836, + Iir_Kind_Reverse_Range_Array_Attribute => 1843, + Iir_Kind_Attribute_Name => 1852 ); function Get_Fields (K : Iir_Kind) return Fields_Array @@ -4945,8 +4945,6 @@ package body Nodes_Meta is return Get_Hash_Chain (N); when Field_Physical_Literal => return Get_Physical_Literal (N); - when Field_Physical_Unit_Value => - return Get_Physical_Unit_Value (N); when Field_Literal_Origin => return Get_Literal_Origin (N); when Field_Range_Origin => @@ -5351,8 +5349,6 @@ package body Nodes_Meta is Set_Hash_Chain (N, V); when Field_Physical_Literal => Set_Physical_Literal (N, V); - when Field_Physical_Unit_Value => - Set_Physical_Unit_Value (N, V); when Field_Literal_Origin => Set_Literal_Origin (N, V); when Field_Range_Origin => @@ -6661,11 +6657,6 @@ package body Nodes_Meta is return K = Iir_Kind_Unit_Declaration; end Has_Physical_Literal; - function Has_Physical_Unit_Value (K : Iir_Kind) return Boolean is - begin - return K = Iir_Kind_Unit_Declaration; - end Has_Physical_Unit_Value; - function Has_Fp_Value (K : Iir_Kind) return Boolean is begin case K is @@ -8128,6 +8119,9 @@ package body Nodes_Meta is | Iir_Kind_Integer_Subtype_Definition | Iir_Kind_Enumeration_Subtype_Definition | Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Integer_Type_Definition + | Iir_Kind_Floating_Type_Definition + | Iir_Kind_Physical_Type_Definition | Iir_Kind_Subtype_Definition => return True; when others => @@ -10403,6 +10397,9 @@ package body Nodes_Meta is | Iir_Kind_Integer_Subtype_Definition | Iir_Kind_Enumeration_Subtype_Definition | Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Integer_Type_Definition + | Iir_Kind_Floating_Type_Definition + | Iir_Kind_Physical_Type_Definition | Iir_Kind_Subtype_Definition | Iir_Kind_Signal_Declaration | Iir_Kind_Variable_Declaration diff --git a/src/vhdl/nodes_meta.ads b/src/vhdl/nodes_meta.ads index c9d51c9da..ea92cb2f4 100644 --- a/src/vhdl/nodes_meta.ads +++ b/src/vhdl/nodes_meta.ads @@ -85,7 +85,6 @@ package Nodes_Meta is Field_Value, Field_Enum_Pos, Field_Physical_Literal, - Field_Physical_Unit_Value, Field_Fp_Value, Field_Simple_Aggregate_List, Field_String8_Id, @@ -593,7 +592,6 @@ package Nodes_Meta is function Has_Value (K : Iir_Kind) return Boolean; function Has_Enum_Pos (K : Iir_Kind) return Boolean; function Has_Physical_Literal (K : Iir_Kind) return Boolean; - function Has_Physical_Unit_Value (K : Iir_Kind) return Boolean; function Has_Fp_Value (K : Iir_Kind) return Boolean; function Has_Simple_Aggregate_List (K : Iir_Kind) return Boolean; function Has_String8_Id (K : Iir_Kind) return Boolean; diff --git a/src/vhdl/parse.adb b/src/vhdl/parse.adb index 49ce426e4..7d4598a4a 100644 --- a/src/vhdl/parse.adb +++ b/src/vhdl/parse.adb @@ -2016,7 +2016,7 @@ package body Parse is if Array_Constrained then -- Sem_Type will create the array type. Res_Type := Create_Iir (Iir_Kind_Array_Subtype_Definition); - Set_Element_Subtype (Res_Type, Element_Subtype); + Set_Array_Element_Constraint (Res_Type, Element_Subtype); Set_Index_Constraint_List (Res_Type, Index_List); else Res_Type := Create_Iir (Iir_Kind_Array_Type_Definition); @@ -2045,7 +2045,7 @@ package body Parse is -- [ LRM93 3.1.3 ] -- secondary_unit_declaration ::= identifier = physical_literal ; function Parse_Physical_Type_Definition (Parent : Iir) - return Iir_Physical_Type_Definition + return Iir_Physical_Type_Definition is use Iir_Chains.Unit_Chain_Handling; Res: Iir_Physical_Type_Definition; @@ -2392,19 +2392,18 @@ package body Parse is if Current_Token = Tok_Units then -- A physical type definition. declare - Unit_Def : Iir; + Phys_Def : Iir; begin - Unit_Def := Parse_Physical_Type_Definition (Parent); + Phys_Def := Parse_Physical_Type_Definition (Parent); 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 (Get_Identifier (Decl), Unit_Def); - end if; - if Def /= Null_Iir then - Set_Type (Def, Unit_Def); + Check_End_Name (Get_Identifier (Decl), Phys_Def); end if; + Set_Range_Constraint (Phys_Def, Def); + Set_Type_Definition (Decl, Phys_Def); end; end if; @@ -2631,7 +2630,7 @@ package body Parse is Scan; if Current_Token = Tok_Left_Paren then - Set_Element_Subtype (Def, Parse_Element_Constraint); + Set_Array_Element_Constraint (Def, Parse_Element_Constraint); end if; return Def; end Parse_Element_Constraint; diff --git a/src/vhdl/sem_decls.adb b/src/vhdl/sem_decls.adb index 20ce9aae6..9fac6d50e 100644 --- a/src/vhdl/sem_decls.adb +++ b/src/vhdl/sem_decls.adb @@ -3230,7 +3230,7 @@ package body Sem_Decls is return; end if; - Set_Discrete_Range (Iterator, A_Range); + Set_Discrete_Range (Iterator, Null_Iir); It_Type := Range_To_Subtype_Indication (A_Range); Set_Subtype_Indication (Iterator, It_Type); diff --git a/src/vhdl/sem_expr.adb b/src/vhdl/sem_expr.adb index 892fbfc7a..9807fc24a 100644 --- a/src/vhdl/sem_expr.adb +++ b/src/vhdl/sem_expr.adb @@ -3552,6 +3552,7 @@ package body Sem_Expr is function Sem_Physical_Literal (Lit: Iir) return Iir is Unit_Name : Iir; + Unit : Iir; Unit_Type : Iir; Res: Iir; begin @@ -3570,9 +3571,11 @@ package body Sem_Expr is Error_Kind ("sem_physical_literal", Lit); end case; Unit_Name := Sem_Denoting_Name (Unit_Name); - if Get_Kind (Get_Named_Entity (Unit_Name)) /= Iir_Kind_Unit_Declaration - then - Error_Class_Match (Unit_Name, "unit"); + Unit := Get_Named_Entity (Unit_Name); + if Get_Kind (Unit) /= Iir_Kind_Unit_Declaration then + if not Is_Error (Unit) then + Error_Class_Match (Unit_Name, "unit"); + end if; Set_Named_Entity (Unit_Name, Create_Error_Name (Unit_Name)); end if; Set_Unit_Name (Res, Unit_Name); @@ -4051,12 +4054,14 @@ package body Sem_Expr is | Iir_Kind_Unit_Declaration => declare Res: Iir; + Res_Type : Iir; begin Res := Sem_Physical_Literal (Expr); - if Res = Null_Iir then + Res_Type := Get_Type (Res); + if Is_Null (Res_Type) then return Null_Iir; end if; - if A_Type /= Null_Iir and then Get_Type (Res) /= A_Type then + if A_Type /= Null_Iir and then Res_Type /= A_Type then Error_Not_Match (Res, A_Type); return Null_Iir; end if; diff --git a/src/vhdl/sem_names.adb b/src/vhdl/sem_names.adb index f524020b9..26672b385 100644 --- a/src/vhdl/sem_names.adb +++ b/src/vhdl/sem_names.adb @@ -927,6 +927,7 @@ package body Sem_Names is | Iir_Kind_Architecture_Body | Iir_Kind_Block_Statement | Iir_Kind_Block_Header + | Iir_Kind_Component_Declaration | Iir_Kinds_Process_Statement | Iir_Kind_Generate_Statement_Body | Iir_Kind_Design_Unit => diff --git a/src/vhdl/sem_types.adb b/src/vhdl/sem_types.adb index 4e5baa373..064648096 100644 --- a/src/vhdl/sem_types.adb +++ b/src/vhdl/sem_types.adb @@ -303,17 +303,17 @@ package body Sem_Types is end Create_Physical_Literal; -- Analyze a physical type definition. Create a subtype. - function Sem_Physical_Type_Definition (Range_Expr: Iir; Decl : Iir) + function Sem_Physical_Type_Definition (Def : Iir; Decl : Iir) return Iir_Physical_Subtype_Definition is Unit: Iir_Unit_Declaration; - Def : Iir_Physical_Type_Definition; Sub_Type: Iir_Physical_Subtype_Definition; + Range_Expr : Iir; Range_Expr1: Iir; Val : Iir; Lit : Iir_Physical_Int_Literal; begin - Def := Get_Type (Range_Expr); + Range_Expr := Get_Range_Constraint (Def); -- LRM93 4.1 -- The simple name declared by a type declaration denotes the @@ -326,11 +326,6 @@ package body Sem_Types is Set_Type_Staticness (Def, Locally); Set_Signal_Type_Flag (Def, True); - -- Set the type definition of the type declaration (it was currently the - -- range expression). Do it early so that the units can be referenced - -- by expanded names. - Set_Type_Definition (Decl, Def); - -- LRM93 3.1.3 -- Each bound of a range constraint that is used in a physical type -- definition must be a locally static expression of some integer type @@ -367,13 +362,14 @@ package body Sem_Types is -- Analyze the primary unit. Unit := Get_Unit_Chain (Def); - Lit := Create_Physical_Literal (1, Unit); - Set_Physical_Unit_Value (Unit, Lit); - - Sem_Scopes.Add_Name (Unit); + -- Set its value to 1. Set_Type (Unit, Def); Set_Expr_Staticness (Unit, Locally); Set_Name_Staticness (Unit, Locally); + Lit := Create_Physical_Literal (1, Unit); + Set_Physical_Literal (Unit, Lit); + + Sem_Scopes.Add_Name (Unit); Set_Visible_Flag (Unit, True); Xref_Decl (Unit); @@ -428,7 +424,7 @@ package body Sem_Types is Val := Sem_Expression (Get_Physical_Literal (Unit), Def); if Val /= Null_Iir then Val := Eval_Physical_Literal (Val); - Set_Physical_Unit_Value (Unit, Val); + Set_Physical_Literal (Unit, Val); -- LRM93 §3.1 -- The position number of unit names need not lie within the range @@ -445,8 +441,9 @@ package body Sem_Types is end if; else -- Avoid errors storm. - Set_Physical_Literal (Unit, Get_Primary_Unit (Def)); - Set_Physical_Unit_Value (Unit, Lit); + Val := Create_Physical_Literal (1, Get_Primary_Unit (Def)); + Set_Literal_Origin (Val, Get_Physical_Literal (Unit)); + Set_Physical_Literal (Unit, Val); end if; Set_Type (Unit, Def); @@ -1018,11 +1015,13 @@ package body Sem_Types is end loop; Set_Index_Subtype_List (Def, Index_List); - -- Element type. - Set_Element_Subtype_Indication (Base_Type, Get_Element_Subtype (Def)); + -- Element type. Transfer it to the base type. + Set_Element_Subtype_Indication + (Base_Type, Get_Array_Element_Constraint (Def)); Sem_Array_Element (Base_Type); El_Type := Get_Element_Subtype (Base_Type); Set_Element_Subtype (Def, El_Type); + Set_Array_Element_Constraint (Def, Null_Iir); Set_Signal_Type_Flag (Def, Get_Signal_Type_Flag (Base_Type)); @@ -1121,12 +1120,11 @@ package body Sem_Types is when Iir_Kind_Enumeration_Type_Definition => return Sem_Enumeration_Type_Definition (Def, Decl); + when Iir_Kind_Physical_Type_Definition => + return Sem_Physical_Type_Definition (Def, Decl); + when Iir_Kind_Range_Expression => - if Get_Type (Def) /= Null_Iir then - return Sem_Physical_Type_Definition (Def, Decl); - else - return Range_Expr_To_Type_Definition (Def, Decl); - end if; + return Range_Expr_To_Type_Definition (Def, Decl); when Iir_Kind_Range_Array_Attribute | Iir_Kind_Attribute_Name @@ -1482,6 +1480,7 @@ package body Sem_Types is -- There is no element_constraint. pragma Assert (Resolution /= Null_Iir); Res := Copy_Subtype_Indication (Type_Mark); + El_Def := Null_Iir; else case Get_Kind (Def) is when Iir_Kind_Subtype_Definition => @@ -1516,7 +1515,7 @@ package body Sem_Types is Base_Type := Get_Base_Type (Type_Mark); Set_Base_Type (Def, Base_Type); - El_Def := Get_Element_Subtype (Def); + El_Def := Get_Array_Element_Constraint (Def); Staticness := Get_Type_Staticness (El_Type); Error_Seen := False; diff --git a/src/vhdl/simulate/annotations.adb b/src/vhdl/simulate/annotations.adb index 4758b5bed..c4c6fded1 100644 --- a/src/vhdl/simulate/annotations.adb +++ b/src/vhdl/simulate/annotations.adb @@ -595,11 +595,20 @@ package body Annotations is procedure Annotate_Declaration (Block_Info: Sim_Info_Acc; Decl: Iir) is begin case Get_Kind (Decl) is - when Iir_Kind_Delayed_Attribute - | Iir_Kind_Stable_Attribute - | Iir_Kind_Quiet_Attribute - | Iir_Kind_Transaction_Attribute - | Iir_Kind_Signal_Declaration => + when Iir_Kind_Signal_Attribute_Declaration => + declare + Attr : Iir; + begin + Attr := Get_Signal_Attribute_Chain (Decl); + while Is_Valid (Attr) loop + Annotate_Anonymous_Type_Definition + (Block_Info, Get_Type (Attr)); + Create_Signal_Info (Block_Info, Attr); + Attr := Get_Attr_Chain (Attr); + end loop; + end; + + when Iir_Kind_Signal_Declaration => Annotate_Anonymous_Type_Definition (Block_Info, Get_Type (Decl)); Create_Signal_Info (Block_Info, Decl); diff --git a/src/vhdl/simulate/elaboration.adb b/src/vhdl/simulate/elaboration.adb index bc3fe1896..e96f92b3f 100644 --- a/src/vhdl/simulate/elaboration.adb +++ b/src/vhdl/simulate/elaboration.adb @@ -2530,14 +2530,28 @@ package body Elaboration is when Iir_Kind_Use_Clause => null; - when Iir_Kind_Delayed_Attribute => - Elaborate_Delayed_Signal (Instance, Decl); - when Iir_Kind_Stable_Attribute => - Elaborate_Implicit_Signal (Instance, Decl, Mode_Stable); - when Iir_Kind_Quiet_Attribute => - Elaborate_Implicit_Signal (Instance, Decl, Mode_Quiet); - when Iir_Kind_Transaction_Attribute => - Elaborate_Implicit_Signal (Instance, Decl, Mode_Transaction); + when Iir_Kind_Signal_Attribute_Declaration => + declare + Attr : Iir; + begin + Attr := Get_Signal_Attribute_Chain (Decl); + while Is_Valid (Attr) loop + case Iir_Kinds_Signal_Attribute (Get_Kind (Attr)) is + when Iir_Kind_Delayed_Attribute => + Elaborate_Delayed_Signal (Instance, Attr); + when Iir_Kind_Stable_Attribute => + Elaborate_Implicit_Signal + (Instance, Attr, Mode_Stable); + when Iir_Kind_Quiet_Attribute => + Elaborate_Implicit_Signal + (Instance, Attr, Mode_Quiet); + when Iir_Kind_Transaction_Attribute => + Elaborate_Implicit_Signal + (Instance, Attr, Mode_Transaction); + end case; + Attr := Get_Attr_Chain (Attr); + end loop; + end; when Iir_Kind_Non_Object_Alias_Declaration => null; diff --git a/src/vhdl/simulate/execution.adb b/src/vhdl/simulate/execution.adb index 936cbd3f3..41b7b2690 100644 --- a/src/vhdl/simulate/execution.adb +++ b/src/vhdl/simulate/execution.adb @@ -1990,7 +1990,8 @@ package body Execution is Set_Expr (Pos); Pos := Pos + 1; when Iir_Kind_Choice_By_Name => - Set_Expr (1 + Get_Element_Position (Get_Choice_Name (Assoc))); + Set_Expr (1 + Get_Element_Position + (Get_Named_Entity (Get_Choice_Name (Assoc)))); when Iir_Kind_Choice_By_Others => for I in Res.Val_Record.V'Range loop if Res.Val_Record.V (I) = null then @@ -2189,12 +2190,13 @@ package body Execution is end case; end Execute_Name_Aggregate; - -- Return the indexes range of dimension DIM for type or object PREFIX. - -- DIM starts at 1. - function Execute_Indexes - (Block: Block_Instance_Acc; Prefix: Iir; Dim : Iir_Int64) - return Iir_Value_Literal_Acc + -- Return the indexes range for prefix of ATTR. + function Execute_Indexes (Block: Block_Instance_Acc; Attr : Iir) + return Iir_Value_Literal_Acc is + Prefix : constant Iir := Strip_Denoting_Name (Get_Prefix (Attr)); + Dim : constant Natural := + Evaluation.Eval_Attribute_Parameter_Or_1 (Attr); begin case Get_Kind (Prefix) is when Iir_Kind_Type_Declaration @@ -2203,12 +2205,9 @@ package body Execution is Index : Iir; begin Index := Get_Nth_Element - (Get_Index_Subtype_List (Get_Type (Prefix)), - Natural (Dim - 1)); + (Get_Index_Subtype_List (Get_Type (Prefix)), Dim - 1); return Execute_Bounds (Block, Index); end; - when Iir_Kinds_Denoting_Name => - return Execute_Indexes (Block, Get_Named_Entity (Prefix), Dim); when Iir_Kind_Array_Type_Definition | Iir_Kind_Array_Subtype_Definition => Error_Kind ("execute_indexes", Prefix); @@ -2257,29 +2256,17 @@ package body Execution is return Execute_Bounds (Block, Get_Range_Constraint (Prefix)); when Iir_Kind_Range_Array_Attribute => - declare - Prefix_Val : Iir_Value_Literal_Acc; - Dim : Iir_Int64; - begin - Dim := Get_Value (Get_Parameter (Prefix)); - Prefix_Val := Execute_Indexes (Block, Get_Prefix (Prefix), Dim); - Bound := Prefix_Val; - end; + Bound := Execute_Indexes (Block, Prefix); when Iir_Kind_Reverse_Range_Array_Attribute => - declare - Dim : Iir_Int64; - begin - Dim := Get_Value (Get_Parameter (Prefix)); - Bound := Execute_Indexes (Block, Get_Prefix (Prefix), Dim); - case Bound.Dir is - when Iir_To => - Bound := Create_Range_Value - (Bound.Right, Bound.Left, Iir_Downto, Bound.Length); - when Iir_Downto => - Bound := Create_Range_Value - (Bound.Right, Bound.Left, Iir_To, Bound.Length); - end case; - end; + Bound := Execute_Indexes (Block, Prefix); + case Bound.Dir is + when Iir_To => + Bound := Create_Range_Value + (Bound.Right, Bound.Left, Iir_Downto, Bound.Length); + when Iir_Downto => + Bound := Create_Range_Value + (Bound.Right, Bound.Left, Iir_To, Bound.Length); + end case; when Iir_Kind_Floating_Type_Definition | Iir_Kind_Integer_Type_Definition => @@ -3057,33 +3044,27 @@ package body Execution is return Execute_Low_Limit (Res); when Iir_Kind_High_Array_Attribute => - Res := Execute_Indexes - (Block, Get_Prefix (Expr), Get_Value (Get_Parameter (Expr))); + Res := Execute_Indexes (Block, Expr); return Execute_High_Limit (Res); when Iir_Kind_Low_Array_Attribute => - Res := Execute_Indexes - (Block, Get_Prefix (Expr), Get_Value (Get_Parameter (Expr))); + Res := Execute_Indexes (Block, Expr); return Execute_Low_Limit (Res); when Iir_Kind_Left_Array_Attribute => - Res := Execute_Indexes - (Block, Get_Prefix (Expr), Get_Value (Get_Parameter (Expr))); + Res := Execute_Indexes (Block, Expr); return Execute_Left_Limit (Res); when Iir_Kind_Right_Array_Attribute => - Res := Execute_Indexes - (Block, Get_Prefix (Expr), Get_Value (Get_Parameter (Expr))); + Res := Execute_Indexes (Block, Expr); return Execute_Right_Limit (Res); when Iir_Kind_Length_Array_Attribute => - Res := Execute_Indexes - (Block, Get_Prefix (Expr), Get_Value (Get_Parameter (Expr))); + Res := Execute_Indexes (Block, Expr); return Execute_Length (Res); when Iir_Kind_Ascending_Array_Attribute => - Res := Execute_Indexes - (Block, Get_Prefix (Expr), Get_Value (Get_Parameter (Expr))); + Res := Execute_Indexes (Block, Expr); return Boolean_To_Lit (Res.Dir = Iir_To); when Iir_Kind_Event_Attribute => diff --git a/src/vhdl/simulate/sim_be.adb b/src/vhdl/simulate/sim_be.adb deleted file mode 100644 index 59eacc814..000000000 --- a/src/vhdl/simulate/sim_be.adb +++ /dev/null @@ -1,117 +0,0 @@ --- Interpreter back-end --- Copyright (C) 2014 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GHDL; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -with Ada.Text_IO; -with Sem; -with Canon; -with Annotations; -with Disp_Tree; -with Errorout; use Errorout; -with Flags; -with Disp_Vhdl; -with Post_Sems; - -package body Sim_Be is - procedure Finish_Compilation (Unit: Iir_Design_Unit; Main: Boolean := False) - is - use Ada.Text_IO; - Lib_Unit : constant Iir := Get_Library_Unit (Unit); - begin - -- Semantic analysis. - - if Flags.Verbose then - Put_Line ("analyze " & Disp_Node (Lib_Unit)); - end if; - Sem.Semantic (Unit); - - if (Main or Flags.Dump_All) and then Flags.Dump_Sem then - Disp_Tree.Disp_Tree (Unit); - end if; - - if Errorout.Nbr_Errors > 0 then - raise Compilation_Error; - end if; - - if (Main or Flags.List_All) and then Flags.List_Sem then - Disp_Vhdl.Disp_Vhdl (Unit); - end if; - - -- Post checks - ---------------- - - Post_Sems.Post_Sem_Checks (Unit); - - if Errorout.Nbr_Errors > 0 then - raise Compilation_Error; - end if; - - - -- Canonicalisation. - ------------------ - if Flags.Verbose then - Put_Line ("canonicalize " & Disp_Node (Lib_Unit)); - end if; - - Canon.Canonicalize (Unit); - - if Errorout.Nbr_Errors > 0 then - raise Compilation_Error; - end if; - - if (Main or Flags.List_All) and then Flags.List_Canon then - Disp_Vhdl.Disp_Vhdl (Unit); - end if; - - if Flags.Flag_Elaborate then - if Get_Kind (Lib_Unit) = Iir_Kind_Architecture_Body then - declare - Config : Iir_Design_Unit; - begin - Config := Canon.Create_Default_Configuration_Declaration - (Lib_Unit); - Set_Default_Configuration_Declaration (Lib_Unit, Config); - if (Main or Flags.Dump_All) and then Flags.Dump_Canon then - Disp_Tree.Disp_Tree (Config); - end if; - if (Main or Flags.List_All) and then Flags.List_Canon then - Disp_Vhdl.Disp_Vhdl (Config); - end if; - end; - end if; - end if; - - -- Annotation. - ------------- - if Flags.Verbose then - Put_Line ("annotate " & Disp_Node (Lib_Unit)); - end if; - - Annotations.Annotate (Unit); - - if Errorout.Nbr_Errors > 0 then - raise Compilation_Error; - end if; - - if (Main or Flags.List_All) and then Flags.List_Annotate then - Disp_Vhdl.Disp_Vhdl (Unit); - end if; - if (Main or Flags.Dump_All) and then Flags.Dump_Annotate then - Disp_Tree.Disp_Tree (Unit); - end if; - end Finish_Compilation; -end Sim_Be; diff --git a/src/vhdl/simulate/sim_be.ads b/src/vhdl/simulate/sim_be.ads deleted file mode 100644 index 9256c4b68..000000000 --- a/src/vhdl/simulate/sim_be.ads +++ /dev/null @@ -1,25 +0,0 @@ --- Interpreter back-end --- Copyright (C) 2014 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GHDL; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -with Iirs; use Iirs; - -package Sim_Be is - procedure Finish_Compilation - (Unit: Iir_Design_Unit; Main: Boolean := False); -end Sim_Be; - diff --git a/src/vhdl/std_package.adb b/src/vhdl/std_package.adb index 598bdc533..0a6a847bf 100644 --- a/src/vhdl/std_package.adb +++ b/src/vhdl/std_package.adb @@ -798,13 +798,12 @@ package body Std_Package is Set_Type (Unit, Time_Type_Definition); Lit1 := Create_Std_Phys_Lit (Multiplier_Value, Multiplier); - Set_Physical_Literal (Unit, Lit1); Lit := Create_Std_Phys_Lit (Multiplier_Value - * Get_Value (Get_Physical_Unit_Value (Multiplier)), - Get_Physical_Unit (Get_Physical_Unit_Value (Multiplier))); + * Get_Value (Get_Physical_Literal (Multiplier)), + Get_Physical_Unit (Get_Physical_Literal (Multiplier))); Set_Literal_Origin (Lit, Lit1); - Set_Physical_Unit_Value (Unit, Lit); + Set_Physical_Literal (Unit, Lit); Set_Expr_Staticness (Unit, Time_Staticness); Set_Name_Staticness (Unit, Locally); @@ -843,7 +842,7 @@ package body Std_Package is Set_Type (Time_Fs_Unit, Time_Type_Definition); Set_Expr_Staticness (Time_Fs_Unit, Time_Staticness); Set_Name_Staticness (Time_Fs_Unit, Locally); - Set_Physical_Unit_Value + Set_Physical_Literal (Time_Fs_Unit, Create_Std_Phys_Lit (1, Time_Fs_Unit)); Append (Last_Unit, Time_Type_Definition, Time_Fs_Unit); diff --git a/src/vhdl/translate/ortho_front.adb b/src/vhdl/translate/ortho_front.adb index 667bbfe5b..460e588df 100644 --- a/src/vhdl/translate/ortho_front.adb +++ b/src/vhdl/translate/ortho_front.adb @@ -17,17 +17,16 @@ -- 02111-1307, USA. with Types; use Types; with Name_Table; +with Iirs; use Iirs; +with Libraries; use Libraries; +with Iirs_Utils; use Iirs_Utils; with Std_Package; -with Back_End; with Flags; +with Configuration; with Translation; -with Iirs; use Iirs; -with Libraries; use Libraries; with Sem; with Errorout; use Errorout; with GNAT.OS_Lib; -with Canon; -with Disp_Vhdl; with Bug; with Trans_Be; with Options; @@ -81,8 +80,7 @@ package body Ortho_Front is Flag_Expect_Failure := False; end Init; - function Decode_Elab_Option (Arg : String_Acc) return Natural - is + function Decode_Elab_Option (Arg : String_Acc) return Natural is begin Elab_Architecture := null; -- Entity (+ architecture) to elaborate @@ -220,59 +218,185 @@ package body Ortho_Front is end Decode_Option; - -- Lighter version of libraries.is_obselete, since DESIGN_UNIT must be in - -- the currently analyzed design file. - function Is_Obsolete (Design_Unit : Iir_Design_Unit) return Boolean + -- Add dependencies of UNIT in DEP_LIST. If a UNIT or a unit it depends + -- on is obsolete, later units are not inserted and this function returns + -- FALSE. UNIT is not added to DEP_LIST. + function Add_Dependence (Unit : Iir_Design_Unit; Dep_List : Iir_List) + return Boolean is List : Iir_List; El : Iir; begin - if Get_Date (Design_Unit) = Date_Obsolete then - return True; + if Get_Date (Unit) = Date_Obsolete then + return False; end if; - List := Get_Dependence_List (Design_Unit); + List := Get_Dependence_List (Unit); if Is_Null_List (List) then - return False; + return True; end if; for I in Natural loop El := Get_Nth_Element (List, I); exit when Is_Null (El); - -- FIXME: there may be entity_aspect_entity... - if Get_Kind (El) = Iir_Kind_Design_Unit - and then Get_Date (El) = Date_Obsolete + + El := Get_Unit_From_Dependence (El); + + if not Get_Configuration_Mark_Flag (El) then + -- EL is not in the list. + if not Add_Dependence (El, Dep_List) then + -- FIXME: Also mark UNIT to avoid walking again. + -- FIXME: this doesn't work as Libraries cannot write the .cf + -- file if a unit is obsolete. + -- Set_Date (Unit, Date_Obsolete); + return False; + end if; + + -- Add to the list (only once). + Set_Configuration_Mark_Flag (El, True); + Append_Element (Dep_List, El); + end if; + end loop; + return True; + end Add_Dependence; + + procedure Do_Compile (Vhdl_File : Name_Id) + is + Res : Iir_Design_File; + New_Design_File : Iir_Design_File; + Design : Iir_Design_Unit; + Next_Design : Iir_Design_Unit; + + -- List of dependencies. + Dep_List : Iir_List; + + -- List of units to be compiled. It is generally the same units as the + -- one in the design_file, but some may be removed because a unit can be + -- obsoleted (directly or indirectly) by a later unit in the same file. + Units_List : Iir_List; + begin + -- Do not elaborate. + Flags.Flag_Elaborate := False; + + -- Read and parse the file. + Res := Libraries.Load_File (Vhdl_File); + if Errorout.Nbr_Errors > 0 then + raise Compilation_Error; + end if; + + -- Analyze all design units. + -- FIXME: outdate the design file? + New_Design_File := Null_Iir; + Design := Get_First_Design_Unit (Res); + while Is_Valid (Design) loop + -- Analyze and canon a design unit. + Libraries.Finish_Compilation (Design, True); + + Next_Design := Get_Chain (Design); + if Errorout.Nbr_Errors = 0 then + Set_Chain (Design, Null_Iir); + Libraries.Add_Design_Unit_Into_Library (Design); + New_Design_File := Get_Design_File (Design); + end if; + + Design := Next_Design; + end loop; + + if Errorout.Nbr_Errors > 0 then + raise Compilation_Error; + end if; + + -- Must have at least one design unit + pragma Assert (Is_Valid (New_Design_File)); + + -- Do late analysis checks. + Design := Get_First_Design_Unit (New_Design_File); + while Is_Valid (Design) loop + Sem.Sem_Analysis_Checks_List + (Design, Is_Warning_Enabled (Warnid_Delayed_Checks)); + Design := Get_Chain (Design); + end loop; + + -- Gather dependencies + pragma Assert (Flags.Flag_Elaborate = False); + Configuration.Flag_Load_All_Design_Units := False; + + -- Exclude std.standard + Set_Configuration_Mark_Flag (Std_Package.Std_Standard_Unit, True); + Set_Configuration_Done_Flag (Std_Package.Std_Standard_Unit, True); + + Dep_List := Create_Iir_List; + Units_List := Create_Iir_List; + + Design := Get_First_Design_Unit (New_Design_File); + while Is_Valid (Design) loop + if Add_Dependence (Design, Dep_List) then + -- Discard obsolete units. + Append_Element (Units_List, Design); + end if; + Design := Get_Chain (Design); + end loop; + + if Errorout.Nbr_Errors > 0 then + -- Errors can happen (missing package body for instantiation). + raise Compilation_Error; + end if; + + -- Translate declarations of dependencies. + Translation.Translate_Standard (False); + for I in Natural loop + Design := Get_Nth_Element (Dep_List, I); + exit when Design = Null_Iir; + if Get_Design_File (Design) /= New_Design_File then + -- Do not yet translate units to be compiled. They can appear as + -- dependencies. + Translation.Translate (Design, False); + end if; + end loop; + + -- Compile only now. + -- Note: the order of design unit is kept. + for I in Natural loop + Design := Get_Nth_Element (Units_List, I); + exit when Design = Null_Iir; + + if Get_Kind (Get_Library_Unit (Design)) + = Iir_Kind_Configuration_Declaration then - return True; + -- Defer code generation of configuration declaration. + -- (default binding may change between analysis and + -- elaboration). + Translation.Translate (Design, False); + else + Translation.Translate (Design, True); end if; + + if Errorout.Nbr_Errors > 0 then + -- This can happen (foreign attribute). + raise Compilation_Error; + end if; + + Design := Get_Chain (Design); end loop; - return False; - end Is_Obsolete; + + -- Save the working library. + Libraries.Save_Work_Library; + end Do_Compile; Nbr_Parse : Natural := 0; function Parse (Filename : String_Acc) return Boolean is Res : Iir_Design_File; - New_Design_File : Iir_Design_File; Design : Iir_Design_Unit; Next_Design : Iir_Design_Unit; - - -- The vhdl filename to compile. - Vhdl_File : Name_Id; begin if Nbr_Parse = 0 then -- Initialize only once... Libraries.Load_Std_Library; - -- Here, time_base can be set. + -- Here, time_base can be set. Translation.Initialize; - Canon.Canon_Flag_Add_Labels := True; - if Flags.List_All and then Flags.List_Annotate then - Disp_Vhdl.Disp_Vhdl (Std_Package.Std_Standard_Unit); - end if; - - if Action = Action_Anaelab and then Anaelab_Files /= null - then + if Action = Action_Anaelab and then Anaelab_Files /= null then Libraries.Load_Work_Library (True); else Libraries.Load_Work_Library (False); @@ -354,86 +478,15 @@ package body Ortho_Front is Filename.all & """ ignored)"); return False; end if; - Vhdl_File := Name_Table.Get_Identifier (Filename.all); - - Translation.Translate_Standard (False); - - Flags.Flag_Elaborate := False; - Res := Libraries.Load_File (Vhdl_File); - if Errorout.Nbr_Errors > 0 then - raise Compilation_Error; - end if; - - -- Analyze all design units. - -- FIXME: outdate the design file? - New_Design_File := Null_Iir; - Design := Get_First_Design_Unit (Res); - while not Is_Null (Design) loop - -- Sem, canon, annotate a design unit. - Back_End.Finish_Compilation (Design, True); - - Next_Design := Get_Chain (Design); - if Errorout.Nbr_Errors = 0 then - Set_Chain (Design, Null_Iir); - Libraries.Add_Design_Unit_Into_Library (Design); - New_Design_File := Get_Design_File (Design); - end if; - - Design := Next_Design; - end loop; - - if Errorout.Nbr_Errors > 0 then - raise Compilation_Error; - end if; - - -- Do late analysis checks. - Design := Get_First_Design_Unit (New_Design_File); - while not Is_Null (Design) loop - Sem.Sem_Analysis_Checks_List - (Design, Is_Warning_Enabled (Warnid_Delayed_Checks)); - Design := Get_Chain (Design); - end loop; - - -- Compile only now. - if not Is_Null (New_Design_File) then - -- Note: the order of design unit is kept. - Design := Get_First_Design_Unit (New_Design_File); - while not Is_Null (Design) loop - if not Is_Obsolete (Design) then - - if Get_Kind (Get_Library_Unit (Design)) - = Iir_Kind_Configuration_Declaration - then - -- Defer code generation of configuration declaration. - -- (default binding may change between analysis and - -- elaboration). - Translation.Translate (Design, False); - else - Translation.Translate (Design, True); - end if; - - if Errorout.Nbr_Errors > 0 then - -- This can happen (foreign attribute). - raise Compilation_Error; - end if; - end if; - - Design := Get_Chain (Design); - end loop; - end if; - - -- Save the working library. - Libraries.Save_Work_Library; + Do_Compile (Name_Table.Get_Identifier (Filename.all)); end case; + if Flag_Expect_Failure then return False; else return True; end if; exception - --when File_Error => - -- Error_Msg_Option ("cannot open file '" & Filename.all & "'"); - -- return False; when Compilation_Error | Parse_Error => if Flag_Expect_Failure then diff --git a/src/vhdl/translate/trans-chap12.adb b/src/vhdl/translate/trans-chap12.adb index 931a34990..28883babb 100644 --- a/src/vhdl/translate/trans-chap12.adb +++ b/src/vhdl/translate/trans-chap12.adb @@ -243,24 +243,25 @@ package body Trans.Chap12 is end loop; -- Default config. - Config := Get_Library_Unit - (Get_Default_Configuration_Declaration (Arch)); - Config_Info := Get_Info (Config); - if Config_Info /= null then - -- Do not create a trampoline for the default_config if it is not - -- used. - Start_Procedure_Decl - (Inter_List, Create_Identifier ("DEFAULT_CONFIG"), - O_Storage_Public); - New_Interface_Decl (Inter_List, Instance, Wki_Instance, - Arch_Info.Block_Decls_Ptr_Type); - Finish_Subprogram_Decl (Inter_List, Subprg); - - Start_Subprogram_Body (Subprg); - Start_Association (Constr, Config_Info.Config_Subprg); - New_Association (Constr, New_Obj_Value (Instance)); - New_Procedure_Call (Constr); + Config := Get_Default_Configuration_Declaration (Arch); + if Is_Valid (Config) then + Config_Info := Get_Info (Get_Library_Unit (Config)); + if Config_Info /= null then + -- Do not create a trampoline for the default_config if it is not + -- used. + Start_Procedure_Decl + (Inter_List, Create_Identifier ("DEFAULT_CONFIG"), + O_Storage_Public); + New_Interface_Decl (Inter_List, Instance, Wki_Instance, + Arch_Info.Block_Decls_Ptr_Type); + Finish_Subprogram_Decl (Inter_List, Subprg); + + Start_Subprogram_Body (Subprg); + Start_Association (Constr, Config_Info.Config_Subprg); + New_Association (Constr, New_Obj_Value (Instance)); + New_Procedure_Call (Constr); Finish_Subprogram_Body; + end if; end if; Pop_Identifier_Prefix (Arch_Mark); diff --git a/src/vhdl/translate/trans-chap2.adb b/src/vhdl/translate/trans-chap2.adb index 74bb8edeb..f011020f1 100644 --- a/src/vhdl/translate/trans-chap2.adb +++ b/src/vhdl/translate/trans-chap2.adb @@ -1348,8 +1348,7 @@ package body Trans.Chap2 is Instantiate_Info_Package (Inst); Info := Get_Info (Inst); - -- FIXME: if the instantiation occurs within a package declaration, - -- the variable must be declared extern (and public in the body). + -- Create the variable containing data for the package instance. Info.Package_Instance_Body_Var := Create_Var (Create_Var_Identifier (Inst), Get_Scope_Type (Pkg_Info.Package_Body_Scope)); diff --git a/src/vhdl/translate/trans_be.adb b/src/vhdl/translate/trans_be.adb index 2198d48da..9fac3a799 100644 --- a/src/vhdl/translate/trans_be.adb +++ b/src/vhdl/translate/trans_be.adb @@ -16,134 +16,12 @@ -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. with Iirs; use Iirs; -with Nodes_Meta; -with Iir_Chains; -with Disp_Tree; -with Disp_Vhdl; -with Sem; -with Canon; with Translation; with Errorout; use Errorout; -with Post_Sems; -with Flags; with Ada.Text_IO; with Back_End; package body Trans_Be is - procedure Finish_Compilation - (Unit : Iir_Design_Unit; Main : Boolean := False) - is - use Ada.Text_IO; - Lib_Unit : constant Iir := Get_Library_Unit (Unit); - begin - if (Main or Flags.Dump_All) and then Flags.Dump_Parse then - Disp_Tree.Disp_Tree (Unit); - end if; - - -- Semantic analysis. - if Flags.Verbose then - Report_Msg (Msgid_Note, Semantic, +Lib_Unit, - "analyse %n", (1 => +Lib_Unit)); - end if; - Sem.Semantic (Unit); - - if (Main or Flags.Dump_All) and then Flags.Dump_Sem then - Disp_Tree.Disp_Tree (Unit); - end if; - - if Errorout.Nbr_Errors > 0 then - raise Compilation_Error; - end if; - - if (Main or Flags.List_All) and then Flags.List_Sem then - Disp_Vhdl.Disp_Vhdl (Unit); - end if; - - -- Post checks - ---------------- - - Post_Sems.Post_Sem_Checks (Unit); - - if Errorout.Nbr_Errors > 0 then - raise Compilation_Error; - end if; - - -- Canonalisation. - ------------------ - if Flags.Verbose then - Report_Msg (Msgid_Note, Semantic, +Lib_Unit, - "canonicalize %n", (1 => +Lib_Unit)); - end if; - - Canon.Canonicalize (Unit); - - -- FIXME: for Main only ? - if Get_Kind (Lib_Unit) = Iir_Kind_Package_Declaration - and then not Get_Need_Body (Lib_Unit) - and then Get_Need_Instance_Bodies (Lib_Unit) - then - -- Create the bodies for instances - Set_Package_Instantiation_Bodies_Chain - (Lib_Unit, - Canon.Create_Instantiation_Bodies (Lib_Unit, Lib_Unit)); - elsif Get_Kind (Lib_Unit) = Iir_Kind_Package_Body - and then Get_Need_Instance_Bodies (Get_Package (Lib_Unit)) - then - Iir_Chains.Append_Chain - (Lib_Unit, Nodes_Meta.Field_Declaration_Chain, - Canon.Create_Instantiation_Bodies (Get_Package (Lib_Unit), - Lib_Unit)); - end if; - - if (Main or Flags.Dump_All) and then Flags.Dump_Canon then - Disp_Tree.Disp_Tree (Unit); - end if; - - if Errorout.Nbr_Errors > 0 then - raise Compilation_Error; - end if; - - if (Main or Flags.List_All) and then Flags.List_Canon then - Disp_Vhdl.Disp_Vhdl (Unit); - end if; - - if Flags.Flag_Elaborate then - if Get_Kind (Lib_Unit) = Iir_Kind_Architecture_Body then - declare - Config : Iir_Design_Unit; - begin - Config := - Canon.Create_Default_Configuration_Declaration (Lib_Unit); - Set_Default_Configuration_Declaration (Lib_Unit, Config); - if (Main or Flags.Dump_All) and then Flags.Dump_Canon then - Disp_Tree.Disp_Tree (Config); - end if; - if (Main or Flags.List_All) and then Flags.List_Canon then - Disp_Vhdl.Disp_Vhdl (Config); - end if; - end; - end if; - - -- Do not translate during elaboration. - -- This is done directly in Translation.Chap12. - return; - end if; - - -- Translation - --------------- - if not Main then - -- Main units (those from the analyzed design file) are translated - -- directly by ortho_front. - - Translation.Translate (Unit, Main); - - if Errorout.Nbr_Errors > 0 then - raise Compilation_Error; - end if; - end if; - - end Finish_Compilation; - procedure Sem_Foreign (Decl : Iir) is use Translation; @@ -190,7 +68,6 @@ package body Trans_Be is procedure Register_Translation_Back_End is begin - Back_End.Finish_Compilation := Finish_Compilation'Access; Back_End.Sem_Foreign := Sem_Foreign'Access; Back_End.Parse_Option := Parse_Option'Access; Back_End.Disp_Option := Disp_Option'Access; diff --git a/src/vhdl/translate/translation.adb b/src/vhdl/translate/translation.adb index 977162565..1a4703f95 100644 --- a/src/vhdl/translate/translation.adb +++ b/src/vhdl/translate/translation.adb @@ -28,6 +28,7 @@ with Std_Package; use Std_Package; with Sem_Specs; with Libraries; with Std_Names; +with Canon; with Trans; with Trans_Decls; use Trans_Decls; with Trans.Chap1; @@ -362,6 +363,9 @@ package body Translation is begin Init_Node_Infos; + -- Set flags for canon. + Canon.Canon_Flag_Add_Labels := True; + -- Force to unnest subprograms is the code generator doesn't support -- nested subprograms. if not Ortho_Nodes.Has_Nested_Subprograms then diff --git a/src/xtools/pnodes.py b/src/xtools/pnodes.py index ce37556ea..4b7e8a5f9 100755 --- a/src/xtools/pnodes.py +++ b/src/xtools/pnodes.py @@ -12,13 +12,13 @@ prefix_name = "Iir_Kind_" prefix_range_name = "Iir_Kinds_" type_name = "Iir_Kind" node_type = "Iir" -conversions = ['uc', 'pos'] +conversions = ['uc', 'pos', 'grp'] class FuncDesc: - def __init__(self, name, field, conv, acc, + def __init__(self, name, fields, conv, acc, pname, ptype, rname, rtype): self.name = name - self.field = field + self.fields = fields # List of physical fields used self.conv = conv self.acc = acc # access: Chain, Chain_Next, Ref, Of_Ref, Maybe_Ref, # Forward_Ref, Maybe_Forward_Ref @@ -229,9 +229,7 @@ def read_kinds(filename): # Read functions funcs = [] - pat_field = re.compile( - ' -- Field: (\w+)' - + '( Of_Ref| Ref| Maybe_Ref| Forward_Ref| Maybe_Forward_Ref| Chain_Next| Chain)?( .*)?\n') + pat_field = re.compile(' -- Field: ([\w,]+)( \w+)?( \(\w+\))?\n') pat_conv = re.compile('^ \((\w+)\)$') pat_func = \ re.compile(' function Get_(\w+) \((\w+) : (\w+)\) return (\w+);\n') @@ -244,10 +242,12 @@ def read_kinds(filename): break m = pat_field.match(l) if m: - # Extract conversion + fields = m.group(1).split(',') + # Extract access modifier acc = m.group(2) if acc: acc = acc.strip() + # Extract conversion conv = m.group(3) if conv: mc = pat_conv.match(conv) @@ -258,7 +258,8 @@ def read_kinds(filename): raise ParseError(lr, 'unknown conversion ' + conv) else: conv = None - + if len(fields) > 1 and conv != 'grp': + raise ParseError(lr, 'bad conversion for multiple fields') # Read function l = lr.get() mf = pat_func.match(l) @@ -280,7 +281,7 @@ def read_kinds(filename): raise ParseError(lr, 'parameter type mismatch with function') if mf.group(4) != mp.group(5): raise ParseError(lr, 'result type mismatch with function') - funcs.append(FuncDesc(mf.group(1), m.group(1), conv, acc, + funcs.append(FuncDesc(mf.group(1), fields, conv, acc, mp.group(2), mp.group(3), mp.group(4), mp.group(5))) @@ -291,7 +292,7 @@ def read_kinds(filename): # (one description may describe several nodes). def read_nodes_fields(lr, names, fields, nodes, funcs_dict): pat_only = re.compile(' -- Only for ' + prefix_name + '(\w+):\n') - pat_field = re.compile(' -- Get/Set_(\w+) \((Alias )?(\w+)\)\n') + pat_field = re.compile(' -- Get/Set_(\w+) \((Alias )?([\w,]+)\)\n') pat_comment = re.compile(' --.*\n') pat_start = re.compile (' -- \w.*\n') @@ -326,21 +327,24 @@ def read_nodes_fields(lr, names, fields, nodes, funcs_dict): # 1) Check the function exists func = m.group(1) alias = m.group(2) - field = m.group(3) + fields = m.group(3).split(',') if func not in funcs_dict: raise ParseError(lr, 'unknown function') func = funcs_dict[func] - if func.field != field: - raise ParseError(lr, 'field mismatch') + if func.fields != fields: + raise ParseError(lr, 'fields mismatch') for c in only_nodes: - if field not in c.fields: - raise ParseError(lr, 'field ' + field + \ - ' does not exist in node') + for f in fields: + if f not in c.fields: + raise ParseError(lr, 'field ' + f + \ + ' does not exist in node') if not alias: - if c.fields[field]: - raise ParseError(lr, 'field already used') - c.fields[field] = func - c.order.append(field) + for f in fields: + if c.fields[f]: + raise ParseError \ + (lr, 'field ' + f + ' already used') + c.fields[f] = func + c.order.append(f) c.attrs[func.name] = func only_nodes = cur_nodes elif pat_start.match(l): @@ -450,36 +454,79 @@ def gen_assert(func): print ' ' + cond print ' ' + msg +def get_field_type(fields, f): + for fld in fields.values(): + if f in fld: + return fld[f] + return None + # Generate Get_XXX/Set_XXX subprograms for FUNC. def gen_get_set(func, nodes, fields): - g = 'Get_' + func.field + ' (' + func.pname + ')' + rtype = func.rtype + # If the function needs several fields, it must be user defined + if func.conv == 'grp': + print ' type %s_Conv is record' % rtype + for f in func.fields: + print ' %s: %s;' % (f, get_field_type(fields, f)) + print ' end record;' + print ' pragma Pack (%s_Conv);' % rtype + print " pragma Assert (%s_Conv'Size = %s'Size);" % (rtype, rtype) + print + else: + f = func.fields[0] + g = 'Get_' + f + ' (' + func.pname + ')' + s = func.rname if func.conv: - field_type = None - for fld in fields.values(): - if func.field in fld: - field_type = fld[func.field] - break if func.conv == 'uc': - g = field_type + '_To_' + func.rtype + ' (' + g + ')' - s = func.rtype + '_To_' + field_type + ' (' + s + ')' + field_type = get_field_type(fields, f) + g = field_type + '_To_' + rtype + ' (' + g + ')' + s = rtype + '_To_' + field_type + ' (' + s + ')' elif func.conv == 'pos': - g = func.rtype + "'Val (" + g + ')' - s = func.rtype + "'Pos (" + s + ')' + g = rtype + "'Val (" + g + ')' + s = rtype + "'Pos (" + s + ')' subprg = ' function Get_' + func.name + ' (' + func.pname \ - + ' : ' + func.ptype + ') return ' + func.rtype - gen_subprg_header(subprg) + + ' : ' + func.ptype + ') return ' + rtype + if func.conv == 'grp': + print subprg + print ' is' + print ' function To_%s is new Ada.Unchecked_Conversion' % \ + func.rtype + print ' (%s_Conv, %s);' % (rtype, rtype); + print ' Conv : %s_Conv;' % rtype + print ' begin' + else: + gen_subprg_header(subprg) gen_assert(func) + if func.conv == 'grp': + for f in func.fields: + print ' Conv.%s := Get_%s (%s);' % (f, f, func.pname) + g = 'To_%s (Conv)' % rtype print ' return ' + g + ';' print ' end Get_' + func.name + ';' print + subprg = ' procedure Set_' + func.name + ' (' \ + func.pname + ' : ' + func.ptype + '; ' \ + func.rname + ' : ' + func.rtype + ')' - gen_subprg_header(subprg) + if func.conv == 'grp': + print subprg + print ' is' + print ' function To_%s_Conv is new Ada.Unchecked_Conversion' % \ + func.rtype + print ' (%s, %s_Conv);' % (rtype, rtype); + print ' Conv : %s_Conv;' % rtype + print ' begin' + else: + gen_subprg_header(subprg) gen_assert(func) - print ' Set_' + func.field + ' (' + func.pname + ', ' + s + ');' + if func.conv == 'grp': + print ' Conv := To_%s_Conv (%s);' % (rtype, func.rname) + for f in func.fields: + print ' Set_%s (%s, Conv.%s);' % (f, func.pname, f) + else: + print ' Set_' + f + ' (' + func.pname + ', ' + s + ');' print ' end Set_' + func.name + ';' print @@ -666,45 +713,35 @@ elif args.action == 'meta_body': elif l == ' -- FIELDS_ARRAY': last = None nodes_types = [node_type, node_type + '_List'] - ref_names = ['Ref', 'Of_Ref', 'Maybe_Ref', 'Forward_Ref', - 'Maybe_Forward_Ref'] for k in kinds: v = nodes[k] if last: print last + ',' last = None print ' -- ' + prefix_name + k + # Get list of physical fields for V, in some order. if flag_keep_order: flds = v.order - elif True: - # first non Iir and no Iir_List - flds = sorted([fk for fk, fv in v.fields.items() \ + else: + # First non Iir and no Iir_List. + flds = sorted([fk for fk, fv in v.fields.items() if fv and fv.rtype not in nodes_types]) # Then Iir and Iir_List in order of appearance flds += (fv for fv in v.order if v.fields[fv].rtype in nodes_types) - else: - # Sort fields: first non Iir and non Iir_List, - # then Iir and Iir_List that aren't references - # then Maybe_Ref - # then Ref and Ref_Of - flds = sorted([fk for fk, fv in v.fields.items() \ - if fv and fv.rtype not in nodes_types]) - flds += sorted([fk for fk, fv in v.fields.items() \ - if fv and fv.rtype in nodes_types \ - and fv.acc not in ref_names]) - flds += sorted([fk for fk, fv in v.fields.items() \ - if fv and fv.rtype in nodes_types\ - and fv.acc in ['Maybe_Ref']]) - flds += sorted([fk for fk, fv in v.fields.items() \ - if fv and fv.rtype in nodes_types\ - and fv.acc in ['Ref', 'Of_Ref', - 'Forward_Ref', - 'Maybe_Forward_Ref']]) + # Print the corresponding node field, but remove duplicate due + # to 'grp'. + fldsn = [] for fk in flds: if last: print last + ',' - last = ' Field_' + v.fields[fk].name + # Remove duplicate + fn = v.fields[fk].name + if fn not in fldsn: + last = ' Field_' + fn + fldsn.append(fn) + else: + last = None if last: print last elif l == ' -- FIELDS_ARRAY_POS': @@ -712,7 +749,8 @@ elif args.action == 'meta_body': last = None for k in kinds: v = nodes[k] - flds = [fk for fk, fv in v.fields.items() if fv] + # Create a set to remove duplicate for 'grp'. + flds = set([fv.name for fk, fv in v.fields.items() if fv]) pos += len(flds) if last: print last + ',' diff --git a/testsuite/gna/bug062/ex.vhdl b/testsuite/gna/bug062/ex.vhdl new file mode 100644 index 000000000..9a63931f2 --- /dev/null +++ b/testsuite/gna/bug062/ex.vhdl @@ -0,0 +1,20 @@ +library ieee; +use ieee.std_logic_1164.all; + +entity ex is + port (clk, en : std_ulogic; + r1: std_ulogic; + r0: out std_ulogic); +end ex; + +architecture behav of ex is +begin + process(clk) + begin + if rising_edge(clk) then + if en = '1' then + r0 <= r1; + end if; + end if; + end process; +end behav; diff --git a/testsuite/gna/bug062/testsuite.sh b/testsuite/gna/bug062/testsuite.sh new file mode 100755 index 000000000..ce437caa3 --- /dev/null +++ b/testsuite/gna/bug062/testsuite.sh @@ -0,0 +1,9 @@ +#! /bin/sh + +. ../../testenv.sh + +$GHDL --file-to-xml ex.vhdl > ex.xml + +rm -f ex.xml + +echo "Test successful" diff --git a/testsuite/gna/issue167/pkg1.vhdl b/testsuite/gna/issue167/pkg1.vhdl new file mode 100644 index 000000000..618e8a7ec --- /dev/null +++ b/testsuite/gna/issue167/pkg1.vhdl @@ -0,0 +1,16 @@ +package p is + component c is + generic ( + -- None of these work in GHDL 1a1d378dcafeca5a18dfa8862ebe412efa1e9718 + -- together with the ports defined below. + g : bit_vector +-- g : bit_vector := x"0" +-- g : bit_vector(3 downto 0) := x"0" +-- g : bit_vector(3 downto 0) + ); + port ( + -- fails if generic 'g' is referenced + x : bit_vector(g'length-1 downto 0) + ); + end component; +end package; diff --git a/testsuite/gna/issue167/pkg2.vhdl b/testsuite/gna/issue167/pkg2.vhdl new file mode 100644 index 000000000..5b528ed03 --- /dev/null +++ b/testsuite/gna/issue167/pkg2.vhdl @@ -0,0 +1,16 @@ +package p is + component c is + generic ( + -- None of these work in GHDL 1a1d378dcafeca5a18dfa8862ebe412efa1e9718 + -- together with the ports defined below. +-- g : bit_vector +-- g : bit_vector := x"0" +-- g : bit_vector(3 downto 0) := x"0" + g : bit_vector(3 downto 0) + ); + port ( + -- fails if generic 'g' is referenced + x : bit_vector(g'length-1 downto 0) + ); + end component; +end package; diff --git a/testsuite/gna/issue167/testsuite.sh b/testsuite/gna/issue167/testsuite.sh new file mode 100755 index 000000000..68926e014 --- /dev/null +++ b/testsuite/gna/issue167/testsuite.sh @@ -0,0 +1,10 @@ +#! /bin/sh + +. ../../testenv.sh + +GHDL_STD_FLAGS=--std=08 +analyze pkg1.vhdl +analyze pkg2.vhdl +clean + +echo "Test successful" |