diff options
| -rw-r--r-- | canon.adb | 30 | ||||
| -rw-r--r-- | configuration.adb | 5 | ||||
| -rw-r--r-- | disp_tree.adb | 122 | ||||
| -rw-r--r-- | disp_vhdl.adb | 28 | ||||
| -rw-r--r-- | errorout.adb | 2 | ||||
| -rw-r--r-- | evaluation.adb | 120 | ||||
| -rw-r--r-- | evaluation.ads | 4 | ||||
| -rw-r--r-- | iirs.adb | 163 | ||||
| -rw-r--r-- | iirs.adb.in | 38 | ||||
| -rw-r--r-- | iirs.ads | 87 | ||||
| -rw-r--r-- | libraries.adb | 70 | ||||
| -rw-r--r-- | libraries/Makefile.inc | 12 | ||||
| -rw-r--r-- | libraries/ieee2008/fixed_generic_pkg-body.vhdl | 20 | ||||
| -rw-r--r-- | nodes_gc.adb | 30 | ||||
| -rw-r--r-- | parse.adb | 34 | ||||
| -rw-r--r-- | sem.adb | 20 | ||||
| -rw-r--r-- | sem_assocs.adb | 2 | ||||
| -rw-r--r-- | sem_expr.adb | 55 | ||||
| -rw-r--r-- | sem_names.adb | 92 | ||||
| -rw-r--r-- | sem_scopes.adb | 27 | ||||
| -rw-r--r-- | sem_stmts.adb | 2 | ||||
| -rw-r--r-- | sem_types.adb | 5 | ||||
| -rw-r--r-- | simulate/elaboration.adb | 22 | ||||
| -rw-r--r-- | translate/gcc/dist-common.sh | 2 | ||||
| -rw-r--r-- | translate/ghdldrv/Makefile | 2 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdlrun.adb | 5 | ||||
| -rw-r--r-- | translate/grt/grt-images.adb | 5 | ||||
| -rw-r--r-- | translate/grt/grt-images.ads | 3 | ||||
| -rw-r--r-- | translate/trans_analyzes.adb | 5 | ||||
| -rw-r--r-- | translate/trans_decls.ads | 1 | ||||
| -rw-r--r-- | translate/translation.adb | 2510 |
31 files changed, 1833 insertions, 1690 deletions
@@ -20,7 +20,6 @@ with Iirs_Utils; use Iirs_Utils; with Types; use Types; with Name_Table; with Sem; -with Std_Names; with Iir_Chains; use Iir_Chains; with Flags; use Flags; with PSL.Nodes; @@ -904,7 +903,7 @@ package body Canon is procedure Canon_Subprogram_Call (Call : Iir) is - Imp : constant Iir := Get_Named_Entity (Get_Implementation (Call)); + Imp : constant Iir := Get_Implementation (Call); Inter_Chain : constant Iir := Get_Interface_Declaration_Chain (Imp); Assoc_Chain : Iir; begin @@ -1225,7 +1224,7 @@ package body Canon is Call_Stmt : Iir_Procedure_Call_Statement; Wait_Stmt : Iir_Wait_Statement; Call : constant Iir_Procedure_Call := Get_Procedure_Call (El); - Imp : constant Iir := Get_Named_Entity (Get_Implementation (Call)); + Imp : constant Iir := Get_Implementation (Call); Assoc_Chain : Iir; Assoc : Iir; Inter : Iir; @@ -2371,10 +2370,10 @@ package body Canon is Conf : Iir_Block_Configuration) is use Iir_Chains.Configuration_Item_Chain_Handling; + Spec : constant Iir := Get_Block_Specification (Conf); + Blk : constant Iir := Get_Block_From_Block_Specification (Spec); + Stmts : constant Iir := Get_Concurrent_Statement_Chain (Blk); El : Iir; - Spec : Iir; - Stmts : Iir; - Blk : Iir; Sub_Blk : Iir; Last_Item : Iir; begin @@ -2382,9 +2381,6 @@ package body Canon is -- canonicalized. -- FIXME: handle indexed/sliced name? - Spec := Get_Block_Specification (Conf); - Blk := Get_Block_From_Block_Specification (Spec); - Stmts := Get_Concurrent_Statement_Chain (Blk); Clear_Instantiation_Configuration (Blk, False); @@ -2412,10 +2408,7 @@ package body Canon is when Iir_Kind_Component_Configuration => Canon_Component_Specification (El, Blk); when Iir_Kind_Block_Configuration => - Sub_Blk := Get_Block_Specification (El); - if Get_Kind (Sub_Blk) = Iir_Kind_Simple_Name then - Sub_Blk := Get_Named_Entity (Sub_Blk); - end if; + Sub_Blk := Strip_Denoting_Name (Get_Block_Specification (El)); case Get_Kind (Sub_Blk) is when Iir_Kind_Block_Statement => Set_Block_Block_Configuration (Sub_Blk, El); @@ -2526,19 +2519,18 @@ package body Canon is Set_Block_Specification (Res, El); Append (Last_Item, Conf, Res); elsif Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then - Blk_Spec := Get_Block_Specification (Blk_Config); - if Get_Kind (Blk_Spec) = Iir_Kind_Simple_Name then - Blk_Spec := Get_Named_Entity (Blk_Spec); - end if; + Blk_Spec := Strip_Denoting_Name + (Get_Block_Specification (Blk_Config)); if Get_Kind (Blk_Spec) /= Iir_Kind_Generate_Statement then -- There are partial configurations. -- Create a default block configuration. Res := Create_Iir (Iir_Kind_Block_Configuration); Location_Copy (Res, El); Set_Parent (Res, Conf); - Blk_Spec := Create_Iir (Iir_Kind_Selected_Name); + Blk_Spec := Create_Iir (Iir_Kind_Indexed_Name); Location_Copy (Blk_Spec, Res); - Set_Identifier (Blk_Spec, Std_Names.Name_Others); + Set_Index_List (Blk_Spec, Iir_List_Others); + Set_Base_Name (Blk_Spec, El); Set_Prefix (Blk_Spec, Build_Simple_Name (El, Res)); Set_Block_Specification (Res, Blk_Spec); Append (Last_Item, Conf, Res); diff --git a/configuration.adb b/configuration.adb index b9391f7eb..f570b692e 100644 --- a/configuration.adb +++ b/configuration.adb @@ -104,7 +104,7 @@ package body Configuration is if El /= Null_Iir then Lib_Unit := Get_Library_Unit (El); if Flag_Build_File_Dependence - or else Get_Kind (Lib_Unit) = Iir_Kind_Package_Declaration + or else Get_Kind (Lib_Unit) in Iir_Kinds_Package_Declaration then Add_Design_Unit (El, Unit); end if; @@ -120,6 +120,9 @@ package body Configuration is -- will set the full package (and not a stub). Libraries.Load_Design_Unit (Unit, From); Lib_Unit := Get_Library_Unit (Unit); + when Iir_Kind_Package_Instantiation_Declaration => + -- The uninstantiated package is part of the dependency. + null; when Iir_Kind_Configuration_Declaration => -- Add entity and architecture. -- find all sub-configuration diff --git a/disp_tree.adb b/disp_tree.adb index 06f0b5039..8078ecbdf 100644 --- a/disp_tree.adb +++ b/disp_tree.adb @@ -502,24 +502,24 @@ package body Disp_Tree is when Iir_Kind_Subnature_Declaration => Put ("subnature_declaration " & Image_Name_Id (Get_Identifier (N))); - when Iir_Kind_Configuration_Declaration => - Put ("configuration_declaration " & - Image_Name_Id (Get_Identifier (N))); - when Iir_Kind_Entity_Declaration => - Put ("entity_declaration " & - Image_Name_Id (Get_Identifier (N))); when Iir_Kind_Package_Declaration => Put ("package_declaration " & Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Package_Instantiation_Declaration => + Put ("package_instantiation_declaration " & + Image_Name_Id (Get_Identifier (N))); when Iir_Kind_Package_Body => Put ("package_body " & Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Configuration_Declaration => + Put ("configuration_declaration " & + Image_Name_Id (Get_Identifier (N))); + when Iir_Kind_Entity_Declaration => + Put ("entity_declaration " & + Image_Name_Id (Get_Identifier (N))); when Iir_Kind_Architecture_Body => Put ("architecture_body " & Image_Name_Id (Get_Identifier (N))); - when Iir_Kind_Package_Instantiation_Declaration => - Put ("package_instantiation_declaration " & - Image_Name_Id (Get_Identifier (N))); when Iir_Kind_Package_Header => Put ("package_header"); when Iir_Kind_Unit_Declaration => @@ -980,8 +980,14 @@ package body Disp_Tree is Disp_Chain (Get_Context_Items (N), Sub_Indent); Header ("date: ", Indent); Put_Line (Date_Type'Image (Get_Date (N))); + Header ("design_unit_source_line: ", Indent); + Put_Line (Int32'Image (Get_Design_Unit_Source_Line (N))); + Header ("design_unit_source_col: ", Indent); + Put_Line (Int32'Image (Get_Design_Unit_Source_Col (N))); Header ("identifier: ", Indent); Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("design_unit_source_pos: ", Indent); + Put_Line (Source_Ptr'Image (Get_Design_Unit_Source_Pos (N))); Header ("library_unit: ", Indent); Disp_Iir (Get_Library_Unit (N), Sub_Indent); Header ("end_location: ", Indent); @@ -1211,7 +1217,7 @@ package body Disp_Tree is Header ("declaration_chain: ", Indent); Disp_Chain (Get_Declaration_Chain (N), Sub_Indent); Header ("configuration_item_chain: ", Indent); - Disp_Iir (Get_Configuration_Item_Chain (N), Sub_Indent); + Disp_Chain (Get_Configuration_Item_Chain (N), Sub_Indent); Header ("prev_block_configuration: ", Indent); Disp_Iir (Get_Prev_Block_Configuration (N), Sub_Indent, True); Header ("block_specification: ", Indent); @@ -1709,80 +1715,103 @@ package body Disp_Tree is Put_Line (Image_Boolean (Get_Visible_Flag (N))); Header ("use_flag: ", Indent); Put_Line (Image_Boolean (Get_Use_Flag (N))); - when Iir_Kind_Configuration_Declaration => + when Iir_Kind_Package_Declaration => Header ("parent: ", Indent); Disp_Iir (Get_Parent (N), Sub_Indent, True); Header ("declaration_chain: ", Indent); Disp_Chain (Get_Declaration_Chain (N), Sub_Indent); - Header ("entity_name: ", Indent); - Disp_Iir (Get_Entity_Name (N), Sub_Indent); + Header ("package_body: ", Indent); + Disp_Iir (Get_Package_Body (N), Sub_Indent, True); Header ("identifier: ", Indent); Put_Line (Image_Name_Id (Get_Identifier (N))); Header ("attribute_value_chain: ", Indent); Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); - Header ("block_configuration: ", Indent); - Disp_Iir (Get_Block_Configuration (N), Sub_Indent); + Header ("package_header: ", Indent); + Disp_Iir (Get_Package_Header (N), Sub_Indent); + Header ("need_body: ", Indent); + Put_Line (Image_Boolean (Get_Need_Body (N))); Header ("visible_flag: ", Indent); Put_Line (Image_Boolean (Get_Visible_Flag (N))); Header ("end_has_reserved_id: ", Indent); Put_Line (Image_Boolean (Get_End_Has_Reserved_Id (N))); Header ("end_has_identifier: ", Indent); Put_Line (Image_Boolean (Get_End_Has_Identifier (N))); - when Iir_Kind_Entity_Declaration => + when Iir_Kind_Package_Instantiation_Declaration => Header ("parent: ", Indent); Disp_Iir (Get_Parent (N), Sub_Indent, True); Header ("declaration_chain: ", Indent); Disp_Chain (Get_Declaration_Chain (N), Sub_Indent); + Header ("package_body: ", Indent); + Disp_Iir (Get_Package_Body (N), Sub_Indent, True); Header ("identifier: ", Indent); Put_Line (Image_Name_Id (Get_Identifier (N))); Header ("attribute_value_chain: ", Indent); Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); - Header ("concurrent_statement_chain: ", Indent); - Disp_Chain (Get_Concurrent_Statement_Chain (N), Sub_Indent); + Header ("uninstantiated_name: ", Indent); + Disp_Iir (Get_Uninstantiated_Name (N), Sub_Indent); Header ("generic_chain: ", Indent); Disp_Chain (Get_Generic_Chain (N), Sub_Indent); - Header ("port_chain: ", Indent); - Disp_Chain (Get_Port_Chain (N), Sub_Indent); - Header ("has_begin: ", Indent); - Put_Line (Image_Boolean (Get_Has_Begin (N))); + Header ("generic_map_aspect_chain: ", Indent); + Disp_Chain (Get_Generic_Map_Aspect_Chain (N), Sub_Indent); Header ("visible_flag: ", Indent); Put_Line (Image_Boolean (Get_Visible_Flag (N))); - Header ("is_within_flag: ", Indent); - Put_Line (Image_Boolean (Get_Is_Within_Flag (N))); Header ("end_has_reserved_id: ", Indent); Put_Line (Image_Boolean (Get_End_Has_Reserved_Id (N))); Header ("end_has_identifier: ", Indent); Put_Line (Image_Boolean (Get_End_Has_Identifier (N))); - when Iir_Kind_Package_Declaration => + when Iir_Kind_Package_Body => Header ("parent: ", Indent); Disp_Iir (Get_Parent (N), Sub_Indent, True); Header ("declaration_chain: ", Indent); Disp_Chain (Get_Declaration_Chain (N), Sub_Indent); - Header ("package_body: ", Indent); - Disp_Iir (Get_Package_Body (N), Sub_Indent); + Header ("identifier: ", Indent); + Put_Line (Image_Name_Id (Get_Identifier (N))); + Header ("package: ", Indent); + Disp_Iir (Get_Package (N), Sub_Indent, True); + Header ("end_has_reserved_id: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Reserved_Id (N))); + Header ("end_has_identifier: ", Indent); + Put_Line (Image_Boolean (Get_End_Has_Identifier (N))); + when Iir_Kind_Configuration_Declaration => + Header ("parent: ", Indent); + Disp_Iir (Get_Parent (N), Sub_Indent, True); + Header ("declaration_chain: ", Indent); + Disp_Chain (Get_Declaration_Chain (N), Sub_Indent); + Header ("entity_name: ", Indent); + Disp_Iir (Get_Entity_Name (N), Sub_Indent); Header ("identifier: ", Indent); Put_Line (Image_Name_Id (Get_Identifier (N))); Header ("attribute_value_chain: ", Indent); Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); - Header ("package_header: ", Indent); - Disp_Iir (Get_Package_Header (N), Sub_Indent); - Header ("need_body: ", Indent); - Put_Line (Image_Boolean (Get_Need_Body (N))); + Header ("block_configuration: ", Indent); + Disp_Iir (Get_Block_Configuration (N), Sub_Indent); Header ("visible_flag: ", Indent); Put_Line (Image_Boolean (Get_Visible_Flag (N))); Header ("end_has_reserved_id: ", Indent); Put_Line (Image_Boolean (Get_End_Has_Reserved_Id (N))); Header ("end_has_identifier: ", Indent); Put_Line (Image_Boolean (Get_End_Has_Identifier (N))); - when Iir_Kind_Package_Body => + when Iir_Kind_Entity_Declaration => Header ("parent: ", Indent); Disp_Iir (Get_Parent (N), Sub_Indent, True); Header ("declaration_chain: ", Indent); Disp_Chain (Get_Declaration_Chain (N), Sub_Indent); Header ("identifier: ", Indent); Put_Line (Image_Name_Id (Get_Identifier (N))); - Header ("package: ", Indent); - Disp_Iir (Get_Package (N), Sub_Indent); + Header ("attribute_value_chain: ", Indent); + Disp_Iir (Get_Attribute_Value_Chain (N), Sub_Indent); + Header ("concurrent_statement_chain: ", Indent); + Disp_Chain (Get_Concurrent_Statement_Chain (N), Sub_Indent); + Header ("generic_chain: ", Indent); + Disp_Chain (Get_Generic_Chain (N), Sub_Indent); + Header ("port_chain: ", Indent); + Disp_Chain (Get_Port_Chain (N), Sub_Indent); + Header ("has_begin: ", Indent); + Put_Line (Image_Boolean (Get_Has_Begin (N))); + Header ("visible_flag: ", Indent); + Put_Line (Image_Boolean (Get_Visible_Flag (N))); + Header ("is_within_flag: ", Indent); + Put_Line (Image_Boolean (Get_Is_Within_Flag (N))); Header ("end_has_reserved_id: ", Indent); Put_Line (Image_Boolean (Get_End_Has_Reserved_Id (N))); Header ("end_has_identifier: ", Indent); @@ -1812,23 +1841,6 @@ package body Disp_Tree is Put_Line (Image_Boolean (Get_End_Has_Reserved_Id (N))); Header ("end_has_identifier: ", Indent); Put_Line (Image_Boolean (Get_End_Has_Identifier (N))); - when Iir_Kind_Package_Instantiation_Declaration => - Header ("parent: ", Indent); - Disp_Iir (Get_Parent (N), Sub_Indent, True); - Header ("uninstantiated_name: ", Indent); - Disp_Iir (Get_Uninstantiated_Name (N), Sub_Indent); - Header ("identifier: ", Indent); - Put_Line (Image_Name_Id (Get_Identifier (N))); - Header ("generic_chain: ", Indent); - Disp_Chain (Get_Generic_Chain (N), Sub_Indent); - Header ("generic_map_aspect_chain: ", Indent); - Disp_Chain (Get_Generic_Map_Aspect_Chain (N), Sub_Indent); - Header ("visible_flag: ", Indent); - Put_Line (Image_Boolean (Get_Visible_Flag (N))); - Header ("end_has_reserved_id: ", Indent); - Put_Line (Image_Boolean (Get_End_Has_Reserved_Id (N))); - Header ("end_has_identifier: ", Indent); - Put_Line (Image_Boolean (Get_End_Has_Identifier (N))); when Iir_Kind_Package_Header => Header ("generic_chain: ", Indent); Disp_Chain (Get_Generic_Chain (N), Sub_Indent); @@ -2074,7 +2086,7 @@ package body Disp_Tree is Header ("return_type_mark: ", Indent); Disp_Iir (Get_Return_Type_Mark (N), Sub_Indent); Header ("subprogram_body: ", Indent); - Disp_Iir (Get_Subprogram_Body (N), Sub_Indent); + Disp_Iir (Get_Subprogram_Body (N), Sub_Indent, True); Header ("seen_flag: ", Indent); Put_Line (Image_Boolean (Get_Seen_Flag (N))); Header ("pure_flag: ", Indent); @@ -2191,7 +2203,7 @@ package body Disp_Tree is Header ("return_type_mark: ", Indent); Disp_Iir (Get_Return_Type_Mark (N), Sub_Indent); Header ("subprogram_body: ", Indent); - Disp_Iir (Get_Subprogram_Body (N), Sub_Indent); + Disp_Iir (Get_Subprogram_Body (N), Sub_Indent, True); Header ("seen_flag: ", Indent); Put_Line (Image_Boolean (Get_Seen_Flag (N))); Header ("passive_flag: ", Indent); @@ -2221,7 +2233,7 @@ package body Disp_Tree is Header ("impure_depth: ", Indent); Put_Line (Iir_Int32'Image (Get_Impure_Depth (N))); Header ("subprogram_specification: ", Indent); - Disp_Iir (Get_Subprogram_Specification (N), Sub_Indent); + Disp_Iir (Get_Subprogram_Specification (N), Sub_Indent, True); Header ("sequential_statement_chain: ", Indent); Disp_Chain (Get_Sequential_Statement_Chain (N), Sub_Indent); Header ("end_has_reserved_id: ", Indent); @@ -2621,7 +2633,7 @@ package body Disp_Tree is Header ("type: ", Indent); Disp_Iir (Get_Type (N), Sub_Indent, True); Header ("selected_element: ", Indent); - Disp_Iir (Get_Selected_Element (N), Sub_Indent); + Disp_Iir (Get_Selected_Element (N), Sub_Indent, True); Header ("base_name: ", Indent); Disp_Iir (Get_Base_Name (N), Sub_Indent, True); Header ("expr_staticness: ", Indent); diff --git a/disp_vhdl.adb b/disp_vhdl.adb index 1f5c8939e..fd3d71062 100644 --- a/disp_vhdl.adb +++ b/disp_vhdl.adb @@ -67,6 +67,7 @@ package body Disp_Vhdl is procedure Disp_Type (A_Type: Iir); procedure Disp_Nature (Nature : Iir); + procedure Disp_Range (Rng : Iir); procedure Disp_Concurrent_Statement (Stmt: Iir); procedure Disp_Concurrent_Statement_Chain (Parent: Iir; Indent : Count); @@ -283,6 +284,9 @@ package body Disp_Vhdl is | Iir_Kind_Component_Declaration | Iir_Kind_Group_Template_Declaration => Disp_Name_Of (Name); + when Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute => + Disp_Range (Name); when others => Error_Kind ("disp_name", Name); end case; @@ -2635,6 +2639,9 @@ package body Disp_Vhdl is when Iir_Kind_Low_Type_Attribute => Disp_Name (Get_Prefix (Expr)); Put ("'low"); + when Iir_Kind_Ascending_Type_Attribute => + Disp_Name (Get_Prefix (Expr)); + Put ("'ascending"); when Iir_Kind_Stable_Attribute => Disp_Parametered_Attribute ("stable", Expr); @@ -3039,15 +3046,18 @@ package body Disp_Vhdl is | Iir_Kind_Architecture_Body => Disp_Name_Of (Spec); when Iir_Kind_Indexed_Name => - Disp_Name_Of (Get_Prefix (Spec)); - Put (" ("); - Disp_Expression (Get_First_Element (Get_Index_List (Spec))); - Put (")"); - when Iir_Kind_Selected_Name => - Disp_Name_Of (Get_Prefix (Spec)); - Put (" ("); - Put (Iirs_Utils.Image_Identifier (Spec)); - Put (")"); + declare + Index_List : constant Iir_List := Get_Index_List (Spec); + begin + Disp_Name_Of (Get_Prefix (Spec)); + Put (" ("); + if Index_List = Iir_List_Others then + Put ("others"); + else + Disp_Expression (Get_First_Element (Index_List)); + end if; + Put (")"); + end; when Iir_Kind_Slice_Name => Disp_Name_Of (Get_Prefix (Spec)); Put (" ("); diff --git a/errorout.adb b/errorout.adb index 2a6d27702..839346528 100644 --- a/errorout.adb +++ b/errorout.adb @@ -589,7 +589,7 @@ package body Errorout is return Disp_Identifier (Node, "entity"); when Iir_Kind_Architecture_Body => return Disp_Identifier (Node, "architecture") & - " of" & Disp_Identifier (Get_Entity (Node), ""); + " of" & Disp_Identifier (Get_Entity_Name (Node), ""); when Iir_Kind_Configuration_Declaration => declare Id : Name_Id; diff --git a/evaluation.adb b/evaluation.adb index 28ae73941..a20d2c68f 100644 --- a/evaluation.adb +++ b/evaluation.adb @@ -193,30 +193,21 @@ package body Evaluation is when Iir_Kind_Integer_Literal => Res := Create_Iir (Iir_Kind_Integer_Literal); Set_Value (Res, Get_Value (Val)); + when Iir_Kind_Floating_Point_Literal => Res := Create_Iir (Iir_Kind_Floating_Point_Literal); Set_Fp_Value (Res, Get_Fp_Value (Val)); + when Iir_Kind_Enumeration_Literal => return Build_Enumeration_Constant (Iir_Index32 (Get_Enum_Pos (Val)), Origin); + when Iir_Kind_Physical_Int_Literal => - declare - Prim_Name : Iir; - begin - Res := Create_Iir (Iir_Kind_Physical_Int_Literal); - Prim_Name := Get_Primary_Unit_Name - (Get_Base_Type (Get_Type (Origin))); - Set_Unit_Name (Res, Prim_Name); - if Get_Named_Entity (Get_Unit_Name (Val)) - = Get_Named_Entity (Prim_Name) - then - Set_Value (Res, Get_Value (Val)); - else - raise Internal_Error; - --Set_Abstract_Literal (Res, Get_Abstract_Literal (Val) - -- * Get_Value (Get_Name (Val))); - end if; - end; + Res := Create_Iir (Iir_Kind_Physical_Int_Literal); + Set_Unit_Name (Res, Get_Primary_Unit_Name + (Get_Base_Type (Get_Type (Origin)))); + Set_Value (Res, Get_Physical_Value (Val)); + when Iir_Kind_Unit_Declaration => Res := Create_Iir (Iir_Kind_Physical_Int_Literal); Set_Value (Res, Get_Physical_Value (Val)); @@ -432,6 +423,18 @@ package body Evaluation is end if; end Free_Eval_Static_Expr; + -- Free the result RES of Eval_String_Literal called with ORIG, if created. + procedure Free_Eval_String_Literal (Res : Iir; Orig : Iir) + is + L : Iir_List; + begin + if Res /= Orig then + L := Get_Simple_Aggregate_List (Res); + Destroy_Iir_List (L); + Free_Iir (Res); + end if; + end Free_Eval_String_Literal; + function Eval_String_Literal (Str : Iir) return Iir is Ptr : String_Fat_Acc; @@ -837,10 +840,7 @@ package body Evaluation is for I in 0 .. Left_Len - 1 loop Append_Element (Res_List, Get_Nth_Element (Left_List, I)); end loop; - if Left_Aggr /= Left then - Destroy_Iir_List (Left_List); - Free_Iir (Left_Aggr); - end if; + Free_Eval_String_Literal (Left_Aggr, Left); end case; -- Right: case Func is @@ -855,10 +855,7 @@ package body Evaluation is for I in 0 .. L - 1 loop Append_Element (Res_List, Get_Nth_Element (Right_List, I)); end loop; - if Right_Aggr /= Right then - Destroy_Iir_List (Right_List); - Free_Iir (Right_Aggr); - end if; + Free_Eval_String_Literal (Right_Aggr, Right); end case; L := Get_Nbr_Elements (Res_List); @@ -1263,8 +1260,15 @@ package body Evaluation is | Iir_Predefined_Array_Sra | Iir_Predefined_Array_Rol | Iir_Predefined_Array_Ror => - return Eval_Shift_Operator - (Eval_String_Literal (Left), Right, Orig, Func); + declare + Left_Aggr : Iir; + Res : Iir; + begin + Left_Aggr := Eval_String_Literal (Left); + Res := Eval_Shift_Operator (Left_Aggr, Right, Orig, Func); + Free_Eval_String_Literal (Left_Aggr, Left); + return Res; + end; when Iir_Predefined_Array_Less | Iir_Predefined_Array_Less_Equal @@ -1810,6 +1814,32 @@ package body Evaluation is end case; end Eval_Type_Conversion; + function Eval_Physical_Literal (Expr : Iir) return Iir + is + Val : Iir; + begin + case Get_Kind (Expr) is + when Iir_Kind_Physical_Fp_Literal => + Val := Expr; + when Iir_Kind_Physical_Int_Literal => + if Get_Named_Entity (Get_Unit_Name (Expr)) + = Get_Primary_Unit (Get_Base_Type (Get_Type (Expr))) + then + return Expr; + else + Val := Expr; + end if; + when Iir_Kind_Unit_Declaration => + Val := Expr; + when Iir_Kinds_Denoting_Name => + Val := Get_Named_Entity (Expr); + pragma Assert (Get_Kind (Val) = Iir_Kind_Unit_Declaration); + when others => + Error_Kind ("eval_physical_literal", Expr); + end case; + return Build_Physical (Get_Physical_Value (Val), Expr); + end Eval_Physical_Literal; + function Eval_Static_Expr (Expr: Iir) return Iir is Res : Iir; @@ -1824,19 +1854,10 @@ package body Evaluation is | Iir_Kind_Floating_Point_Literal | Iir_Kind_String_Literal | Iir_Kind_Bit_String_Literal - | Iir_Kind_Overflow_Literal => + | Iir_Kind_Overflow_Literal + | Iir_Kind_Physical_Int_Literal + | Iir_Kind_Physical_Fp_Literal => return Expr; - when Iir_Kind_Physical_Int_Literal => - if Get_Named_Entity (Get_Unit_Name (Expr)) - = Get_Primary_Unit (Get_Base_Type (Get_Type (Expr))) - then - return Expr; - else - -- Convert to the primary unit. - return Build_Physical (Get_Physical_Value (Expr), Expr); - end if; - when Iir_Kind_Physical_Fp_Literal => - return Build_Physical (Get_Physical_Value (Expr), Expr); when Iir_Kind_Constant_Declaration => Val := Eval_Static_Expr (Get_Default_Value (Expr)); -- Type of the expression should be type of the constant @@ -2128,9 +2149,8 @@ package body Evaluation is when Iir_Kind_Function_Call => declare + Imp : constant Iir := Get_Implementation (Expr); Left, Right : Iir; - Imp : constant Iir := - Get_Named_Entity (Get_Implementation (Expr)); begin -- Note: there can't be association by name. Left := Get_Parameter_Association_Chain (Expr); @@ -2158,9 +2178,7 @@ package body Evaluation is Res : Iir; begin case Get_Kind (Expr) is - when Iir_Kind_Simple_Name - | Iir_Kind_Character_Literal - | Iir_Kind_Selected_Name => + when Iir_Kinds_Denoting_Name => declare Orig : constant Iir := Get_Named_Entity (Expr); begin @@ -2176,6 +2194,8 @@ package body Evaluation is if Res /= Expr and then Get_Literal_Origin (Res) /= Expr then + -- Need to build a constant if the result is a different + -- literal not tied to EXPR. return Build_Constant (Res, Expr); else return Res; @@ -2504,10 +2524,10 @@ package body Evaluation is return Get_Value (Expr); when Iir_Kind_Enumeration_Literal => return Iir_Int64 (Get_Enum_Pos (Expr)); - when Iir_Kind_Physical_Int_Literal => + when Iir_Kind_Physical_Int_Literal + | Iir_Kind_Physical_Fp_Literal + | Iir_Kind_Unit_Declaration => return Get_Physical_Value (Expr); - when Iir_Kind_Unit_Declaration => - return Get_Value (Get_Physical_Unit_Value (Expr)); when Iir_Kinds_Denoting_Name => return Eval_Pos (Get_Named_Entity (Expr)); when others => @@ -2574,7 +2594,7 @@ package body Evaluation is end case; Set_Left_Limit (Res, Get_Right_Limit (Expr)); Set_Right_Limit (Res, Get_Left_Limit (Expr)); - Set_Range_Origin (Res, Expr); + Set_Range_Origin (Res, Rng); Set_Expr_Staticness (Res, Get_Expr_Staticness (Expr)); return Res; end if; @@ -2598,7 +2618,9 @@ package body Evaluation is Res : Iir; begin Res := Eval_Static_Range (Arange); - if Res /= Arange then + if Res /= Arange + and then Get_Range_Origin (Res) /= Arange + then return Build_Constant_Range (Res, Arange); else return Res; diff --git a/evaluation.ads b/evaluation.ads index e22f36a6f..76a40207b 100644 --- a/evaluation.ads +++ b/evaluation.ads @@ -62,6 +62,10 @@ package Evaluation is -- is locally static. function Eval_Expr_If_Static (Expr : Iir) return Iir; + -- Evaluate a physical literal and return a normalized literal (using + -- the primary unit as unit). + function Eval_Physical_Literal (Expr : Iir) return Iir; + -- Return TRUE if literal EXPR is in SUB_TYPE bounds. function Eval_Is_In_Bound (Expr : Iir; Sub_Type : Iir) return Boolean; @@ -149,34 +149,6 @@ package body Iirs is return Iir_Kind'Val (Get_Nkind (An_Iir)); end Get_Kind; - procedure Set_Pos_Line_Off (Design_Unit: Iir_Design_Unit; - Pos : Source_Ptr; Line, Off: Natural) is - begin - Set_Field4 (Design_Unit, Node_Type (Pos)); - Set_Field11 (Design_Unit, Node_Type (Off)); - Set_Field12 (Design_Unit, Node_Type (Line)); - end Set_Pos_Line_Off; - - procedure Get_Pos_Line_Off (Design_Unit: Iir_Design_Unit; - Pos : out Source_Ptr; Line, Off: out Natural) is - begin - Pos := Source_Ptr (Get_Field4 (Design_Unit)); - Off := Natural (Get_Field11 (Design_Unit)); - Line := Natural (Get_Field12 (Design_Unit)); - end Get_Pos_Line_Off; - - ----------- - -- Lists -- - ----------- - - -- Layout of lists: - -- A list is stored into an IIR. - -- There are two bounds for a list: - -- the current number of elements - -- the maximum number of elements. - -- Using a maximum number of element bound (which can be increased) avoid - -- to reallocating memory at each insertion. - function Time_Stamp_Id_To_Iir is new Ada.Unchecked_Conversion (Source => Time_Stamp_Id, Target => Iir); @@ -225,6 +197,16 @@ package body Iirs is function Iir_Int32_To_Iir is new Ada.Unchecked_Conversion (Source => Iir_Int32, Target => Iir); + function Iir_To_Source_Ptr (N : Iir) return Source_Ptr is + begin + return Source_Ptr (N); + end Iir_To_Source_Ptr; + + function Source_Ptr_To_Iir (P : Source_Ptr) return Iir is + begin + return Iir (P); + end Source_Ptr_To_Iir; + function Iir_To_Location_Type (N : Iir) return Location_Type is begin return Location_Type (N); @@ -449,10 +431,10 @@ package body Iirs is | Iir_Kind_Floating_Subtype_Definition | Iir_Kind_Subtype_Definition | Iir_Kind_Scalar_Nature_Definition + | Iir_Kind_Package_Instantiation_Declaration | Iir_Kind_Configuration_Declaration | Iir_Kind_Entity_Declaration | Iir_Kind_Architecture_Body - | Iir_Kind_Package_Instantiation_Declaration | Iir_Kind_Package_Header | Iir_Kind_Unit_Declaration | Iir_Kind_Library_Declaration @@ -954,6 +936,74 @@ package body Iirs is Set_Field7 (Design_Unit, Chain); end Set_Hash_Chain; + procedure Check_Kind_For_Design_Unit_Source_Pos (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_Design_Unit => + null; + when others => + Failed ("Design_Unit_Source_Pos", Target); + end case; + end Check_Kind_For_Design_Unit_Source_Pos; + + function Get_Design_Unit_Source_Pos (Design_Unit : Iir) return Source_Ptr + is + begin + Check_Kind_For_Design_Unit_Source_Pos (Design_Unit); + return Iir_To_Source_Ptr (Get_Field4 (Design_Unit)); + end Get_Design_Unit_Source_Pos; + + procedure Set_Design_Unit_Source_Pos (Design_Unit : Iir; Pos : Source_Ptr) + is + begin + Check_Kind_For_Design_Unit_Source_Pos (Design_Unit); + Set_Field4 (Design_Unit, Source_Ptr_To_Iir (Pos)); + end Set_Design_Unit_Source_Pos; + + procedure Check_Kind_For_Design_Unit_Source_Line (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_Design_Unit => + null; + when others => + Failed ("Design_Unit_Source_Line", Target); + end case; + end Check_Kind_For_Design_Unit_Source_Line; + + function Get_Design_Unit_Source_Line (Design_Unit : Iir) return Int32 is + begin + Check_Kind_For_Design_Unit_Source_Line (Design_Unit); + return Iir_To_Int32 (Get_Field11 (Design_Unit)); + end Get_Design_Unit_Source_Line; + + procedure Set_Design_Unit_Source_Line (Design_Unit : Iir; Line : Int32) is + begin + Check_Kind_For_Design_Unit_Source_Line (Design_Unit); + Set_Field11 (Design_Unit, Int32_To_Iir (Line)); + end Set_Design_Unit_Source_Line; + + procedure Check_Kind_For_Design_Unit_Source_Col (Target : Iir) is + begin + case Get_Kind (Target) is + when Iir_Kind_Design_Unit => + null; + when others => + Failed ("Design_Unit_Source_Col", Target); + end case; + end Check_Kind_For_Design_Unit_Source_Col; + + function Get_Design_Unit_Source_Col (Design_Unit : Iir) return Int32 is + begin + Check_Kind_For_Design_Unit_Source_Col (Design_Unit); + return Iir_To_Int32 (Get_Field12 (Design_Unit)); + end Get_Design_Unit_Source_Col; + + procedure Set_Design_Unit_Source_Col (Design_Unit : Iir; Line : Int32) is + begin + Check_Kind_For_Design_Unit_Source_Col (Design_Unit); + Set_Field12 (Design_Unit, Int32_To_Iir (Line)); + end Set_Design_Unit_Source_Col; + procedure Check_Kind_For_Value (Target : Iir) is begin case Get_Kind (Target) is @@ -1902,9 +1952,10 @@ package body Iirs is | Iir_Kind_Subtype_Declaration | Iir_Kind_Nature_Declaration | Iir_Kind_Subnature_Declaration + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration | Iir_Kind_Configuration_Declaration | Iir_Kind_Entity_Declaration - | Iir_Kind_Package_Declaration | Iir_Kind_Architecture_Body | Iir_Kind_Unit_Declaration | Iir_Kind_Component_Declaration @@ -2064,7 +2115,8 @@ package body Iirs is procedure Check_Kind_For_Package_Body (Target : Iir) is begin case Get_Kind (Target) is - when Iir_Kind_Package_Declaration => + when Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration => null; when others => Failed ("Package_Body", Target); @@ -2288,8 +2340,8 @@ package body Iirs is begin case Get_Kind (Target) is when Iir_Kind_Block_Header - | Iir_Kind_Entity_Declaration | Iir_Kind_Package_Instantiation_Declaration + | Iir_Kind_Entity_Declaration | Iir_Kind_Package_Header | Iir_Kind_Component_Declaration | Iir_Kind_Function_Declaration @@ -3076,12 +3128,12 @@ package body Iirs is procedure Check_Kind_For_Design_Unit (Target : Iir) is begin case Get_Kind (Target) is - when Iir_Kind_Configuration_Declaration - | Iir_Kind_Entity_Declaration - | Iir_Kind_Package_Declaration + when Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration | Iir_Kind_Package_Body - | Iir_Kind_Architecture_Body - | Iir_Kind_Package_Instantiation_Declaration => + | Iir_Kind_Configuration_Declaration + | Iir_Kind_Entity_Declaration + | Iir_Kind_Architecture_Body => null; when others => Failed ("Design_Unit", Target); @@ -3151,10 +3203,11 @@ package body Iirs is when Iir_Kind_Block_Configuration | Iir_Kind_Protected_Type_Declaration | Iir_Kind_Protected_Type_Body - | Iir_Kind_Configuration_Declaration - | Iir_Kind_Entity_Declaration | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration | Iir_Kind_Package_Body + | Iir_Kind_Configuration_Declaration + | Iir_Kind_Entity_Declaration | Iir_Kind_Architecture_Body | Iir_Kind_Function_Body | Iir_Kind_Procedure_Body @@ -3498,12 +3551,12 @@ package body Iirs is | Iir_Kind_Subtype_Declaration | Iir_Kind_Nature_Declaration | Iir_Kind_Subnature_Declaration - | Iir_Kind_Configuration_Declaration - | Iir_Kind_Entity_Declaration | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration | Iir_Kind_Package_Body + | Iir_Kind_Configuration_Declaration + | Iir_Kind_Entity_Declaration | Iir_Kind_Architecture_Body - | Iir_Kind_Package_Instantiation_Declaration | Iir_Kind_Unit_Declaration | Iir_Kind_Library_Declaration | Iir_Kind_Component_Declaration @@ -3639,11 +3692,11 @@ package body Iirs is | Iir_Kind_Subtype_Declaration | Iir_Kind_Nature_Declaration | Iir_Kind_Subnature_Declaration + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration | Iir_Kind_Configuration_Declaration | Iir_Kind_Entity_Declaration - | Iir_Kind_Package_Declaration | Iir_Kind_Architecture_Body - | Iir_Kind_Package_Instantiation_Declaration | Iir_Kind_Unit_Declaration | Iir_Kind_Library_Declaration | Iir_Kind_Component_Declaration @@ -5447,13 +5500,13 @@ package body Iirs is function Get_Uninstantiated_Name (Inst : Iir) return Iir is begin Check_Kind_For_Uninstantiated_Name (Inst); - return Get_Field1 (Inst); + return Get_Field5 (Inst); end Get_Uninstantiated_Name; procedure Set_Uninstantiated_Name (Inst : Iir; Name : Iir) is begin Check_Kind_For_Uninstantiated_Name (Inst); - Set_Field1 (Inst, Name); + Set_Field5 (Inst, Name); end Set_Uninstantiated_Name; procedure Check_Kind_For_Generate_Block_Configuration (Target : Iir) is @@ -5596,12 +5649,12 @@ package body Iirs is | Iir_Kind_Subtype_Declaration | Iir_Kind_Nature_Declaration | Iir_Kind_Subnature_Declaration - | Iir_Kind_Configuration_Declaration - | Iir_Kind_Entity_Declaration | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration | Iir_Kind_Package_Body + | Iir_Kind_Configuration_Declaration + | Iir_Kind_Entity_Declaration | Iir_Kind_Architecture_Body - | Iir_Kind_Package_Instantiation_Declaration | Iir_Kind_Unit_Declaration | Iir_Kind_Component_Declaration | Iir_Kind_Attribute_Declaration @@ -7600,12 +7653,12 @@ package body Iirs is | Iir_Kind_Record_Type_Definition | Iir_Kind_Physical_Type_Definition | Iir_Kind_Protected_Type_Body - | Iir_Kind_Configuration_Declaration - | Iir_Kind_Entity_Declaration | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration | Iir_Kind_Package_Body + | Iir_Kind_Configuration_Declaration + | Iir_Kind_Entity_Declaration | Iir_Kind_Architecture_Body - | Iir_Kind_Package_Instantiation_Declaration | Iir_Kind_Component_Declaration | Iir_Kind_Function_Body | Iir_Kind_Procedure_Body @@ -7638,12 +7691,12 @@ package body Iirs is | Iir_Kind_Record_Type_Definition | Iir_Kind_Physical_Type_Definition | Iir_Kind_Protected_Type_Body - | Iir_Kind_Configuration_Declaration - | Iir_Kind_Entity_Declaration | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration | Iir_Kind_Package_Body + | Iir_Kind_Configuration_Declaration + | Iir_Kind_Entity_Declaration | Iir_Kind_Architecture_Body - | Iir_Kind_Package_Instantiation_Declaration | Iir_Kind_Component_Declaration | Iir_Kind_Function_Body | Iir_Kind_Procedure_Body diff --git a/iirs.adb.in b/iirs.adb.in index 2ed914d05..9c2319a3f 100644 --- a/iirs.adb.in +++ b/iirs.adb.in @@ -149,34 +149,6 @@ package body Iirs is return Iir_Kind'Val (Get_Nkind (An_Iir)); end Get_Kind; - procedure Set_Pos_Line_Off (Design_Unit: Iir_Design_Unit; - Pos : Source_Ptr; Line, Off: Natural) is - begin - Set_Field4 (Design_Unit, Node_Type (Pos)); - Set_Field11 (Design_Unit, Node_Type (Off)); - Set_Field12 (Design_Unit, Node_Type (Line)); - end Set_Pos_Line_Off; - - procedure Get_Pos_Line_Off (Design_Unit: Iir_Design_Unit; - Pos : out Source_Ptr; Line, Off: out Natural) is - begin - Pos := Source_Ptr (Get_Field4 (Design_Unit)); - Off := Natural (Get_Field11 (Design_Unit)); - Line := Natural (Get_Field12 (Design_Unit)); - end Get_Pos_Line_Off; - - ----------- - -- Lists -- - ----------- - - -- Layout of lists: - -- A list is stored into an IIR. - -- There are two bounds for a list: - -- the current number of elements - -- the maximum number of elements. - -- Using a maximum number of element bound (which can be increased) avoid - -- to reallocating memory at each insertion. - function Time_Stamp_Id_To_Iir is new Ada.Unchecked_Conversion (Source => Time_Stamp_Id, Target => Iir); @@ -225,6 +197,16 @@ package body Iirs is function Iir_Int32_To_Iir is new Ada.Unchecked_Conversion (Source => Iir_Int32, Target => Iir); + function Iir_To_Source_Ptr (N : Iir) return Source_Ptr is + begin + return Source_Ptr (N); + end Iir_To_Source_Ptr; + + function Source_Ptr_To_Iir (P : Source_Ptr) return Iir is + begin + return Iir (P); + end Source_Ptr_To_Iir; + function Iir_To_Location_Type (N : Iir) return Location_Type is begin return Location_Type (N); @@ -220,7 +220,11 @@ package Iirs is -- Set the line and the offset in the line, only for the library manager. -- This is valid until the file is really loaded in memory. On loading, -- location will contain all this informations. - -- Get/Set_Pos_Line_Off (Field4,Field11,Field12) + -- Get/Set_Design_Unit_Source_Pos (Field4) + -- + -- Get/Set_Design_Unit_Source_Line (Field11) + -- + -- Get/Set_Design_Unit_Source_Col (Field12) -- -- Get/Set the date state, which indicates whether this design unit is in -- memory or not. @@ -494,7 +498,7 @@ package Iirs is -- Get/Set_Configuration_Item_Chain (Field3) -- -- Note: for default block configurations of iterative generate statement, - -- the block specification is a selected_name, whose identifier is others. + -- the block specification is an indexed_name, whose index_list is others. -- Get/Set_Block_Specification (Field5) -- -- Single linked list of block configuration that apply to the same @@ -825,10 +829,16 @@ package Iirs is -- Get/Set_Parent (Field0) -- Get/Set_Design_Unit (Alias Field0) -- - -- Get/Set_Uninstantiated_Name (Field1) + -- Get/Set_Declaration_Chain (Field1) + -- + -- Get/Set_Package_Body (Field2) -- -- Get/Set_Identifier (Field3) -- + -- Get/Set_Attribute_Value_Chain (Field4) + -- + -- Get/Set_Uninstantiated_Name (Field5) + -- -- Get/Set_Generic_Chain (Field6) -- -- Get/Set_Generic_Map_Aspect_Chain (Field8) @@ -1866,7 +1876,7 @@ package Iirs is -- -- unbounded_array_definition ::= -- ARRAY ( index_subtype_definition { , index_subtype_definition } ) - -- OF element_subtype_indication + -- OF element_subtype_indication -- -- index_subtype_definition ::= type_mark RANGE <> -- @@ -2813,6 +2823,7 @@ package Iirs is -- -- Get/Set_Parameter_Association_Chain (Field2) -- + -- Procedure declaration corresponding to the procedure to call. -- Get/Set_Implementation (Field3) -- -- Get/Set_Method_Object (Field4) @@ -3120,7 +3131,8 @@ package Iirs is -- Get/Set_Named_Entity (Field4) -- Iir_Kind_Selected_Element (Short) - -- A record element selection. + -- A record element selection. This corresponds to a reffined selected + -- names. The production doesn't exist in the VHDL grammar. -- -- Get/Set_Prefix (Field0) -- @@ -3423,12 +3435,12 @@ package Iirs is Iir_Kind_Subtype_Declaration, Iir_Kind_Nature_Declaration, Iir_Kind_Subnature_Declaration, - Iir_Kind_Configuration_Declaration, -- Library_Unit - Iir_Kind_Entity_Declaration, -- Library_Unit - Iir_Kind_Package_Declaration, -- Library_Unit - Iir_Kind_Package_Body, -- Library_Unit - Iir_Kind_Architecture_Body, -- Library_Unit + Iir_Kind_Package_Declaration, Iir_Kind_Package_Instantiation_Declaration, + Iir_Kind_Package_Body, + Iir_Kind_Configuration_Declaration, + Iir_Kind_Entity_Declaration, + Iir_Kind_Architecture_Body, Iir_Kind_Package_Header, Iir_Kind_Unit_Declaration, Iir_Kind_Library_Declaration, @@ -4026,11 +4038,15 @@ package Iirs is -- Iir_Kind_Callees_List; subtype Iir_Kinds_Library_Unit_Declaration is Iir_Kind range - Iir_Kind_Configuration_Declaration .. - --Iir_Kind_Entity_Declaration - --Iir_Kind_Package_Declaration + Iir_Kind_Package_Declaration .. + --Iir_Kind_Package_Instantiation_Declaration --Iir_Kind_Package_Body - --Iir_Kind_Architecture_Body + --Iir_Kind_Configuration_Declaration + --Iir_Kind_Entity_Declaration + Iir_Kind_Architecture_Body; + + subtype Iir_Kinds_Package_Declaration is Iir_Kind range + Iir_Kind_Package_Declaration .. Iir_Kind_Package_Instantiation_Declaration; -- Note: does not include iir_kind_enumeration_literal since it is @@ -4403,12 +4419,12 @@ package Iirs is --Iir_Kind_Subtype_Declaration --Iir_Kind_Nature_Declaration --Iir_Kind_Subnature_Declaration - --Iir_Kind_Configuration_Declaration - --Iir_Kind_Entity_Declaration --Iir_Kind_Package_Declaration + --Iir_Kind_Package_Instantiation_Declaration --Iir_Kind_Package_Body + --Iir_Kind_Configuration_Declaration + --Iir_Kind_Entity_Declaration --Iir_Kind_Architecture_Body - --Iir_Kind_Package_Instantiation_Declaration --Iir_Kind_Package_Header --Iir_Kind_Unit_Declaration --Iir_Kind_Library_Declaration @@ -4962,14 +4978,20 @@ package Iirs is -- Set the line and the offset in the line, only for the library manager. -- This is valid until the file is really loaded in memory. On loading, -- location will contain all this informations. - -- Field: Field4 - -- Field: Field6 - -- Field: Field7 - procedure Set_Pos_Line_Off (Design_Unit: Iir_Design_Unit; - Pos : Source_Ptr; Line, Off: Natural); - procedure Get_Pos_Line_Off (Design_Unit: Iir_Design_Unit; - Pos : out Source_Ptr; Line, Off: out Natural); + -- Display: Image + -- Field: Field4 (uc) + function Get_Design_Unit_Source_Pos (Design_Unit : Iir) return Source_Ptr; + procedure Set_Design_Unit_Source_Pos (Design_Unit : Iir; Pos : Source_Ptr); + + -- Display: Image + -- Field: Field11 (uc) + function Get_Design_Unit_Source_Line (Design_Unit : Iir) return Int32; + procedure Set_Design_Unit_Source_Line (Design_Unit : Iir; Line : Int32); + -- Display: Image + -- Field: Field12 (uc) + function Get_Design_Unit_Source_Col (Design_Unit : Iir) return Int32; + procedure Set_Design_Unit_Source_Col (Design_Unit : Iir; Line : Int32); -- literals. @@ -5177,7 +5199,7 @@ package Iirs is function Get_Prev_Block_Configuration (Target : Iir) return Iir; procedure Set_Prev_Block_Configuration (Target : Iir; Block : Iir); - -- Field: Field3 + -- Field: Field3 Chain function Get_Configuration_Item_Chain (Target : Iir) return Iir; procedure Set_Configuration_Item_Chain (Target : Iir; Chain : Iir); @@ -5207,12 +5229,12 @@ package Iirs is procedure Set_Entity_Name (Arch : Iir; Entity : Iir); -- The package declaration corresponding to the body. - -- Field: Field4 + -- Field: Field4 Ref function Get_Package (Package_Body : Iir) return Iir; procedure Set_Package (Package_Body : Iir; Decl : Iir); -- The package body corresponding to the package declaration. - -- Field: Field2 + -- Field: Field2 Ref function Get_Package_Body (Pkg : Iir) return Iir; procedure Set_Package_Body (Pkg : Iir; Decl : Iir); @@ -5290,7 +5312,7 @@ package Iirs is procedure Set_Interface_Declaration_Chain (Target : Iir; Chain : Iir); pragma Inline (Get_Interface_Declaration_Chain); - -- Field: Field4 + -- Field: Field4 Ref function Get_Subprogram_Specification (Target : Iir) return Iir; procedure Set_Subprogram_Specification (Target : Iir; Spec : Iir); @@ -5298,7 +5320,7 @@ package Iirs is function Get_Sequential_Statement_Chain (Target : Iir) return Iir; procedure Set_Sequential_Statement_Chain (Target : Iir; Chain : Iir); - -- Field: Field9 + -- Field: Field9 Ref function Get_Subprogram_Body (Target : Iir) return Iir; procedure Set_Subprogram_Body (Target : Iir; A_Body : Iir); @@ -5418,7 +5440,7 @@ package Iirs is function Get_Element_Declaration (Target : Iir) return Iir; procedure Set_Element_Declaration (Target : Iir; El : Iir); - -- Field: Field2 + -- Field: Field2 Ref function Get_Selected_Element (Target : Iir) return Iir; procedure Set_Selected_Element (Target : Iir; El : Iir); @@ -5833,7 +5855,7 @@ package Iirs is function Get_Block_Header (Target : Iir) return Iir; procedure Set_Block_Header (Target : Iir; Header : Iir); - -- Field: Field1 + -- Field: Field5 function Get_Uninstantiated_Name (Inst : Iir) return Iir; procedure Set_Uninstantiated_Name (Inst : Iir; Name : Iir); @@ -6072,7 +6094,8 @@ package Iirs is function Get_Procedure_Call (Stmt : Iir) return Iir; procedure Set_Procedure_Call (Stmt : Iir; Call : Iir); - -- Subprogram to be called by a procedure, function call or operator. + -- Subprogram to be called by a procedure, function call or operator. This + -- is the declaration of the subprogram (or a list of during analysis). -- Field: Field3 Ref function Get_Implementation (Target : Iir) return Iir; procedure Set_Implementation (Target : Iir; Decl : Iir); diff --git a/libraries.adb b/libraries.adb index 4696008d7..7fd2b69ef 100644 --- a/libraries.adb +++ b/libraries.adb @@ -18,6 +18,8 @@ with Ada.Text_IO; use Ada.Text_IO; with GNAT.Table; with GNAT.OS_Lib; +with Interfaces.C_Streams; +with System; with Errorout; use Errorout; with Scanner; with Iirs_Utils; use Iirs_Utils; @@ -337,7 +339,7 @@ package body Libraries is Design_File: Iir_Design_File; Library_Unit: Iir; - Line, Col: Natural; + Line, Col: Int32; File_Dir : Name_Id; Pos: Source_Ptr; Date: Date_Type; @@ -511,14 +513,14 @@ package body Libraries is -- Scan position. Scan_Expect (Tok_Identifier); -- at Scan_Expect (Tok_Integer); - Line := Natural (Current_Iir_Int64); + Line := Int32 (Current_Iir_Int64); Scan_Expect (Tok_Left_Paren); Scan_Expect (Tok_Integer); Pos := Source_Ptr (Current_Iir_Int64); Scan_Expect (Tok_Right_Paren); Scan_Expect (Tok_Plus); Scan_Expect (Tok_Integer); - Col := Natural (Current_Iir_Int64); + Col := Int32 (Current_Iir_Int64); Scan_Expect (Tok_On); Scan_Expect (Tok_Integer); Date := Date_Type (Current_Iir_Int64); @@ -536,7 +538,7 @@ package body Libraries is Scan; if False then - Put_Line ("line:" & Natural'Image (Line) + Put_Line ("line:" & Int32'Image (Line) & ", pos:" & Source_Ptr'Image (Pos)); end if; @@ -546,7 +548,9 @@ package body Libraries is -- Keep the position of the design unit. --Set_Location (Design_Unit, Location_Type (File)); --Set_Location (Library_Unit, Location_Type (File)); - Set_Pos_Line_Off (Design_Unit, Pos, Line, Col); + Set_Design_Unit_Source_Pos (Design_Unit, Pos); + Set_Design_Unit_Source_Line (Design_Unit, Line); + Set_Design_Unit_Source_Col (Design_Unit, Col); Set_Date (Design_Unit, Date); if Date > Max_Date then Max_Date := Date; @@ -1110,22 +1114,29 @@ package body Libraries is end Add_Design_File_Into_Library; -- Save the file map of library LIBRARY. - procedure Save_Library (Library: Iir_Library_Declaration) is + procedure Save_Library (Library: Iir_Library_Declaration) + is + use System; + use Interfaces.C_Streams; use GNAT.OS_Lib; - Temp_Name : String_Access; - FD : File_Descriptor; + Temp_Name: constant String := Image (Work_Directory) + & '_' & Back_End.Library_To_File_Name (Library) & ASCII.NUL; + Mode : constant String := 'w' & ASCII.NUL; + Stream : FILEs; Success : Boolean; -- Write a string to the temporary file. - procedure WR (S : String) is + procedure WR (S : String) + is + Close_Res : int; + pragma Unreferenced (Close_Res); begin - if Write (FD, S'Address, S'Length) /= S'Length then + if Integer (fwrite (S'Address, S'Length, 1, Stream)) /= 1 then Error_Msg ("cannot write library file for " & Image_Identifier (Library)); - Close (FD); - Delete_File (Temp_Name.all, Success); + Close_Res := fclose (Stream); + Delete_File (Temp_Name'Address, Success); -- Ignore failure to delete the file. - Free (Temp_Name); raise Option_Error; end if; end WR; @@ -1148,9 +1159,9 @@ package body Libraries is -- Create a temporary file so that the real library is atomically -- updated, and won't be corrupted in case of Control-C, or concurrent -- writes. - Create_Temp_Output_File (FD, Temp_Name); + Stream := fopen (Temp_Name'Address, Mode'Address); - if FD = Invalid_FD then + if Stream = NULL_Stream then Error_Msg ("cannot create library file for " & Image_Identifier (Library)); raise Option_Error; @@ -1228,7 +1239,9 @@ package body Libraries is end case; if Get_Date_State (Design_Unit) = Date_Disk then - Get_Pos_Line_Off (Design_Unit, Pos, Line, Off); + Pos := Get_Design_Unit_Source_Pos (Design_Unit); + Line := Natural (Get_Design_Unit_Source_Line (Design_Unit)); + Off := Natural (Get_Design_Unit_Source_Col (Design_Unit)); else Files_Map.Location_To_Coord (Get_Location (Design_Unit), Source_File, Pos, Line, Off); @@ -1264,7 +1277,12 @@ package body Libraries is Design_File := Get_Chain (Design_File); end loop; - Close (FD); + declare + Fclose_Res : int; + pragma Unreferenced (Fclose_Res); + begin + Fclose_Res := fclose (Stream); + end; -- Rename the temporary file to the library file. -- FIXME: It may fail if they aren't on the same filesystem, but we @@ -1272,17 +1290,21 @@ package body Libraries is declare use Files_Map; File_Name: constant String := Image (Work_Directory) - & Back_End.Library_To_File_Name (Library); + & Back_End.Library_To_File_Name (Library) & ASCII.NUL; Delete_Success : Boolean; begin -- For windows: renames doesn't overwrite destination; so first -- delete it. This can create races condition on Unix: if the -- program is killed between delete and rename, the library is lost. - Delete_File (File_Name, Delete_Success); - Rename_File (Temp_Name.all, File_Name, Success); - Free (Temp_Name); + Delete_File (File_Name'Address, Delete_Success); + Rename_File (Temp_Name'Address, File_Name'Address, Success); if not Success then - Error_Msg ("cannot update library file """ & File_Name & """"); + -- Renaming may fail if the new filename is in a non-existant + -- directory. + Error_Msg ("cannot update library file """ + & File_Name (File_Name'First .. File_Name'Last - 1) + & """"); + Delete_File (Temp_Name'Address, Success); raise Option_Error; end if; end; @@ -1472,7 +1494,9 @@ package body Libraries is Design_Unit); raise Compilation_Error; end if; - Get_Pos_Line_Off (Design_Unit, Pos, Line, Off); + Pos := Get_Design_Unit_Source_Pos (Design_Unit); + Line := Natural (Get_Design_Unit_Source_Line (Design_Unit)); + Off := Natural (Get_Design_Unit_Source_Col (Design_Unit)); Files_Map.File_Add_Line_Number (Get_Current_Source_File, Line, Pos); Set_Current_Position (Pos + Source_Ptr (Off)); Res := Parse.Parse_Design_Unit; diff --git a/libraries/Makefile.inc b/libraries/Makefile.inc index 569506813..ab29cfbec 100644 --- a/libraries/Makefile.inc +++ b/libraries/Makefile.inc @@ -53,16 +53,12 @@ ieee2008/math_real.vhdl ieee2008/math_real-body.vhdl \ ieee2008/math_complex.vhdl ieee2008/math_complex-body.vhdl \ ieee2008/numeric_bit.vhdl ieee2008/numeric_bit-body.vhdl \ ieee2008/numeric_bit_unsigned.vhdl ieee2008/numeric_bit_unsigned-body.vhdl \ -ieee2008/numeric_std.vhdl \ -ieee2008/numeric_std-body.vhdl \ +ieee2008/numeric_std.vhdl ieee2008/numeric_std-body.vhdl \ ieee2008/numeric_std_unsigned.vhdl ieee2008/numeric_std_unsigned-body.vhdl \ ieee2008/fixed_float_types.vhdl \ -ieee2008/fixed_generic_pkg.vhdl \ -ieee2008/fixed_generic_pkg-body.vhdl -# ieee2008/fixed_pkg.vhdl \ -#ieee2008/float_generic_pkg.vhdl -#ieee2008/float_generic_pkg-body.vhdl -# +ieee2008/fixed_generic_pkg.vhdl ieee2008/fixed_generic_pkg-body.vhdl \ +ieee2008/fixed_pkg.vhdl +#ieee2008/float_generic_pkg.vhdl ieee2008/float_generic_pkg-body.vhdl \ #ieee2008/float_pkg.vhdl STD87_BSRCS := $(STD_SRCS:.vhdl=.v87) diff --git a/libraries/ieee2008/fixed_generic_pkg-body.vhdl b/libraries/ieee2008/fixed_generic_pkg-body.vhdl index 24842a964..361b4c7f2 100644 --- a/libraries/ieee2008/fixed_generic_pkg-body.vhdl +++ b/libraries/ieee2008/fixed_generic_pkg-body.vhdl @@ -292,12 +292,13 @@ package body fixed_generic_pkg is arg : UNRESOLVED_ufixed) -- fixed point vector return STD_ULOGIC_VECTOR is - variable result : STD_ULOGIC_VECTOR (arg'length-1 downto 0); + subtype result_subtype is STD_ULOGIC_VECTOR (arg'length-1 downto 0); + variable result : result_subtype; begin if arg'length < 1 then return NSLV; end if; - result := STD_ULOGIC_VECTOR (arg); + result := result_subtype (arg); return result; end function to_sulv; @@ -305,12 +306,15 @@ package body fixed_generic_pkg is arg : UNRESOLVED_sfixed) -- fixed point vector return STD_ULOGIC_VECTOR is - variable result : STD_ULOGIC_VECTOR (arg'length-1 downto 0); + subtype result_subtype is STD_ULOGIC_VECTOR (arg'length-1 downto 0); + variable result : result_subtype; + --variable result : STD_ULOGIC_VECTOR (arg'length-1 downto 0); begin if arg'length < 1 then return NSLV; end if; - result := STD_ULOGIC_VECTOR (arg); + --result := STD_ULOGIC_VECTOR (arg); + result := result_subtype (arg); return result; end function to_sulv; @@ -723,9 +727,10 @@ package body fixed_generic_pkg is is variable result : UNRESOLVED_ufixed (minimum(l'high, r'high) downto mine(l'low, r'low)); + constant rlow : integer := mins(r'low, r'low); variable lresize : UNRESOLVED_ufixed (maximum(l'high, r'low) downto - mins(r'low, r'low)-guard_bits); - variable rresize : UNRESOLVED_ufixed (r'high downto r'low-guard_bits); + rlow-guard_bits); + variable rresize : UNRESOLVED_ufixed (r'high downto rlow-guard_bits); variable dresult : UNRESOLVED_ufixed (rresize'range); variable lslv : UNRESOLVED_UNSIGNED (lresize'length-1 downto 0); variable rslv : UNRESOLVED_UNSIGNED (rresize'length-1 downto 0); @@ -5014,7 +5019,8 @@ package body fixed_generic_pkg is variable c : CHARACTER; begin while L /= null and L.all'length /= 0 loop - if (L.all(1) = ' ' or L.all(1) = NBSP or L.all(1) = HT) then + c := l (l'left); + if (c = ' ' or c = NBSP or c = HT) then read (l, c, readOk); else exit; diff --git a/nodes_gc.adb b/nodes_gc.adb index dfb23b4bf..d433c7931 100644 --- a/nodes_gc.adb +++ b/nodes_gc.adb @@ -214,7 +214,7 @@ package body Nodes_GC is Mark_Iir (Get_Configuration_Name (N)); when Iir_Kind_Block_Configuration => Mark_Chain (Get_Declaration_Chain (N)); - Mark_Iir (Get_Configuration_Item_Chain (N)); + Mark_Chain (Get_Configuration_Item_Chain (N)); Mark_Iir (Get_Block_Specification (N)); when Iir_Kind_Block_Header => Mark_Chain (Get_Generic_Chain (N)); @@ -344,6 +344,18 @@ package body Nodes_GC is | Iir_Kind_Subnature_Declaration => Mark_Iir (Get_Nature (N)); Mark_Iir (Get_Attribute_Value_Chain (N)); + when Iir_Kind_Package_Declaration => + Mark_Chain (Get_Declaration_Chain (N)); + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Iir (Get_Package_Header (N)); + when Iir_Kind_Package_Instantiation_Declaration => + Mark_Chain (Get_Declaration_Chain (N)); + Mark_Iir (Get_Attribute_Value_Chain (N)); + Mark_Iir (Get_Uninstantiated_Name (N)); + Mark_Chain (Get_Generic_Chain (N)); + Mark_Chain (Get_Generic_Map_Aspect_Chain (N)); + when Iir_Kind_Package_Body => + Mark_Chain (Get_Declaration_Chain (N)); when Iir_Kind_Configuration_Declaration => Mark_Chain (Get_Declaration_Chain (N)); Mark_Iir (Get_Entity_Name (N)); @@ -355,24 +367,12 @@ package body Nodes_GC is Mark_Chain (Get_Concurrent_Statement_Chain (N)); Mark_Chain (Get_Generic_Chain (N)); Mark_Chain (Get_Port_Chain (N)); - when Iir_Kind_Package_Declaration => - Mark_Chain (Get_Declaration_Chain (N)); - Mark_Iir (Get_Package_Body (N)); - Mark_Iir (Get_Attribute_Value_Chain (N)); - Mark_Iir (Get_Package_Header (N)); - when Iir_Kind_Package_Body => - Mark_Chain (Get_Declaration_Chain (N)); - Mark_Iir (Get_Package (N)); when Iir_Kind_Architecture_Body => Mark_Chain (Get_Declaration_Chain (N)); Mark_Iir (Get_Entity_Name (N)); Mark_Iir (Get_Attribute_Value_Chain (N)); Mark_Chain (Get_Concurrent_Statement_Chain (N)); Mark_Iir (Get_Default_Configuration_Declaration (N)); - when Iir_Kind_Package_Instantiation_Declaration => - Mark_Iir (Get_Uninstantiated_Name (N)); - Mark_Chain (Get_Generic_Chain (N)); - Mark_Chain (Get_Generic_Map_Aspect_Chain (N)); when Iir_Kind_Package_Header => Mark_Chain (Get_Generic_Chain (N)); Mark_Chain (Get_Generic_Map_Aspect_Chain (N)); @@ -424,7 +424,6 @@ package body Nodes_GC is Mark_Chain (Get_Generic_Chain (N)); Mark_Iir_List (Get_Callees_List (N)); Mark_Iir (Get_Return_Type_Mark (N)); - Mark_Iir (Get_Subprogram_Body (N)); when Iir_Kind_Implicit_Function_Declaration => Mark_Iir (Get_Attribute_Value_Chain (N)); Mark_Chain (Get_Interface_Declaration_Chain (N)); @@ -443,11 +442,9 @@ package body Nodes_GC is Mark_Chain (Get_Generic_Chain (N)); Mark_Iir_List (Get_Callees_List (N)); Mark_Iir (Get_Return_Type_Mark (N)); - Mark_Iir (Get_Subprogram_Body (N)); when Iir_Kind_Function_Body | Iir_Kind_Procedure_Body => Mark_Chain (Get_Declaration_Chain (N)); - Mark_Iir (Get_Subprogram_Specification (N)); Mark_Chain (Get_Sequential_Statement_Chain (N)); when Iir_Kind_Object_Alias_Declaration => Mark_Iir (Get_Name (N)); @@ -559,7 +556,6 @@ package body Nodes_GC is Mark_Iir (Get_Subtype_Indication (N)); when Iir_Kind_Selected_Element => Mark_Iir (Get_Prefix (N)); - Mark_Iir (Get_Selected_Element (N)); when Iir_Kind_Dereference | Iir_Kind_Implicit_Dereference | Iir_Kind_Left_Type_Attribute @@ -933,43 +933,43 @@ package body Parse is -- precond : '(' -- postcond: next token -- - -- [ §4.3.2.1 ] + -- [ LRM93 4.3.2.1 ] -- interface_list ::= interface_element { ; interface_element } -- - -- [ §4.3.2.1 ] + -- [ LRM93 4.3.2.1 ] -- interface_element ::= interface_declaration -- - -- [ §4.3.2 ] + -- [ LRM93 4.3.2 ] -- interface_declaration ::= interface_constant_declaration -- | interface_signal_declaration -- | interface_variable_declaration -- | interface_file_declaration -- -- - -- [ §3.2.2 ] + -- [ LRM93 3.2.2 ] -- identifier_list ::= identifier { , identifier } -- - -- [ §4.3.2 ] + -- [ LRM93 4.3.2 ] -- interface_constant_declaration ::= -- [ CONSTANT ] identifier_list : [ IN ] subtype_indication -- [ := STATIC_expression ] -- - -- [ §4.3.2 ] + -- [ LRM93 4.3.2 ] -- interface_file_declaration ::= FILE identifier_list : subtype_indication -- - -- [ §4.3.2 ] + -- [ LRM93 4.3.2 ] -- interface_signal_declaration ::= -- [ SIGNAL ] identifier_list : [ mode ] subtype_indication [ BUS ] -- [ := STATIC_expression ] -- - -- [ §4.3.2 ] + -- [ LRM93 4.3.2 ] -- interface_variable_declaration ::= -- [ VARIABLE ] identifier_list : [ mode ] subtype_indication -- [ := STATIC_expression ] -- -- The default kind of interface declaration is DEFAULT. function Parse_Interface_Chain (Default: Iir_Kind; Parent : Iir) - return Iir + return Iir is Res, Last : Iir; First, Prev_First : Iir; @@ -1210,12 +1210,10 @@ package body Parse is Res: Iir; El : Iir; begin - -- tok_port must have been scaned. - if Current_Token /= Tok_Port then - raise Program_Error; - end if; - + -- Skip 'port' + pragma Assert (Current_Token = Tok_Port); Scan; + Res := Parse_Interface_Chain (Iir_Kind_Signal_Interface_Declaration, Parent); @@ -1244,12 +1242,10 @@ package body Parse is is Res: Iir; begin - -- tok_port must have been scaned. - if Current_Token /= Tok_Generic then - raise Program_Error; - end if; - + -- Skip 'generic' + pragma Assert (Current_Token = Tok_Generic); Scan; + Res := Parse_Interface_Chain (Iir_Kind_Constant_Interface_Declaration, Parent); Set_Generic_Chain (Parent, Res); @@ -27,6 +27,7 @@ with Sem_Names; use Sem_Names; with Sem_Specs; use Sem_Specs; with Sem_Decls; use Sem_Decls; with Sem_Assocs; use Sem_Assocs; +with Sem_Inst; with Iirs_Utils; use Iirs_Utils; with Flags; use Flags; with Name_Table; @@ -2385,8 +2386,11 @@ package body Sem is -- LRM08 4.9 Package Instantiation Declaration procedure Sem_Package_Instantiation_Declaration (Decl : Iir) is + use Sem_Inst; Name : Iir; Pkg : Iir; + Header : Iir; + Bod : Iir_Design_Unit; begin Sem_Scopes.Add_Name (Decl); Set_Visible_Flag (Decl, True); @@ -2416,7 +2420,21 @@ package body Sem is -- actual with each formal generic (or member thereof) in the -- corresponding package declaration. Each formal generic (or member -- thereof) shall be associated at most once. - Sem_Generic_Association_Chain (Get_Package_Header (Pkg), Decl); + Header := Get_Package_Header (Pkg); + Sem_Generic_Association_Chain (Header, Decl); + + Set_Generic_Chain + (Decl, Instantiate_Declaration_Chain (Get_Generic_Chain (Header))); + Set_Declaration_Chain + (Decl, Instantiate_Declaration_Chain (Get_Declaration_Chain (Pkg))); + + -- FIXME: unless the parent is a package declaration library unit, the + -- design unit depends on the body. + Bod := Libraries.Load_Secondary_Unit + (Get_Design_Unit (Pkg), Null_Identifier, Decl); + if Bod /= Null_Iir then + Add_Dependence (Bod); + end if; end Sem_Package_Instantiation_Declaration; -- LRM 10.4 Use Clauses. diff --git a/sem_assocs.adb b/sem_assocs.adb index 2149007ff..dcec12c98 100644 --- a/sem_assocs.adb +++ b/sem_assocs.adb @@ -1156,7 +1156,7 @@ package body Sem_Assocs is when Iir_Kinds_Function_Declaration => Res := Create_Iir (Iir_Kind_Function_Call); Location_Copy (Res, Conv); - Set_Implementation (Res, Conv); + Set_Implementation (Res, Func); Set_Prefix (Res, Conv); Set_Base_Name (Res, Res); Set_Parameter_Association_Chain (Res, Null_Iir); diff --git a/sem_expr.adb b/sem_expr.adb index e84fecc82..9b8c9bbcb 100644 --- a/sem_expr.adb +++ b/sem_expr.adb @@ -772,16 +772,18 @@ package body Sem_Expr is function Sem_Discrete_Range_Integer (Expr: Iir) return Iir is + Res : Iir; Range_Type : Iir; begin - Range_Type := Sem_Discrete_Range_Expression (Expr, Null_Iir, True); - if Range_Type = Null_Iir then + Res := Sem_Discrete_Range_Expression (Expr, Null_Iir, True); + if Res = Null_Iir then return Null_Iir; end if; if Get_Kind (Expr) /= Iir_Kind_Range_Expression then - return Range_Type; + return Res; end if; - Range_Type := Get_Type (Expr); + + Range_Type := Get_Type (Res); if Range_Type = Convertible_Integer_Type_Definition then -- LRM 3.2.1.1 Index constraints and discrete ranges -- For a discrete range used in a constrained array @@ -792,9 +794,9 @@ package body Sem_Expr is -- implicit conversion) is the type universal_integer. -- FIXME: catch phys/phys. - Set_Type (Expr, Integer_Type_Definition); - if Get_Expr_Staticness (Expr) = Locally then - Eval_Check_Range (Expr, Integer_Subtype_Definition, True); + Set_Type (Res, Integer_Type_Definition); + if Get_Expr_Staticness (Res) = Locally then + Eval_Check_Range (Res, Integer_Subtype_Definition, True); end if; elsif Range_Type = Universal_Integer_Type_Definition then if Vhdl_Std >= Vhdl_08 then @@ -811,14 +813,14 @@ package body Sem_Expr is -- Be tolerant. Warning_Msg_Sem ("universal integer bound must be numeric literal " - & "or attribute", Expr); + & "or attribute", Res); else Error_Msg_Sem ("universal integer bound must be numeric literal " - & "or attribute", Expr); + & "or attribute", Res); end if; - Set_Type (Expr, Integer_Type_Definition); + Set_Type (Res, Integer_Type_Definition); end if; - return Expr; + return Res; end Sem_Discrete_Range_Integer; procedure Set_Function_Call_Staticness (Expr : Iir; Imp : Iir) @@ -1182,7 +1184,7 @@ package body Sem_Expr is (Expr : Iir; A_Type : Iir; Is_Func_Call : Boolean) return Iir is - Imp : constant Iir := Get_Implementation (Expr); + Imp : Iir; Nbr_Inter: Natural; A_Func: Iir; Imp_List: Iir_List; @@ -1195,7 +1197,8 @@ package body Sem_Expr is -- Sem_Name has gathered all the possible names for the prefix of this -- call. Reduce this list to only names that match the types. Nbr_Inter := 0; - Imp_List := Get_Overload_List (Get_Named_Entity (Imp)); + Imp := Get_Implementation (Expr); + Imp_List := Get_Overload_List (Imp); Assoc_Chain := Get_Parameter_Association_Chain (Expr); for I in Natural loop @@ -1248,7 +1251,8 @@ package body Sem_Expr is when 1 => -- Simple case: no overloading. Inter := Get_First_Element (Imp_List); - Free_Iir (Get_Named_Entity (Imp)); + Free_Overload_List (Imp); + Set_Implementation (Expr, Inter); if Is_Func_Call then Set_Type (Expr, Get_Return_Type (Inter)); end if; @@ -1261,7 +1265,6 @@ package body Sem_Expr is raise Internal_Error; end if; Check_Subprogram_Associations (Inter_Chain, Assoc_Chain); - Set_Named_Entity (Imp, Inter); Sem_Subprogram_Call_Finish (Expr, Inter); return Expr; @@ -1326,7 +1329,7 @@ package body Sem_Expr is -- NOTE: the list of possible implementations was already created -- during the transformation of iir_kind_parenthesis_name to -- iir_kind_function_call. - Inter_List := Get_Named_Entity (Get_Implementation (Expr)); + Inter_List := Get_Implementation (Expr); if Get_Kind (Inter_List) = Iir_Kind_Error then return Null_Iir; elsif Is_Overload_List (Inter_List) then @@ -1363,7 +1366,7 @@ package body Sem_Expr is Set_Type (Expr, Get_Return_Type (Inter_List)); end if; Check_Subprogram_Associations (Param_Chain, Assoc_Chain); - Set_Named_Entity (Get_Implementation (Expr), Inter_List); + Set_Implementation (Expr, Inter_List); Sem_Subprogram_Call_Finish (Expr, Inter_List); return Expr; end if; @@ -1438,7 +1441,7 @@ package body Sem_Expr is return Null_Iir; end if; Check_Subprogram_Associations (Param_Chain, Assoc_Chain); - Set_Named_Entity (Get_Implementation (Expr), Res); + Set_Implementation (Expr, Res); Sem_Subprogram_Call_Finish (Expr, Res); return Expr; end Sem_Subprogram_Call; @@ -1456,13 +1459,13 @@ package body Sem_Expr is Name := Get_Prefix (Call); -- FIXME: check for denoting name. Sem_Name (Name); - Set_Implementation (Call, Name); -- Return now if the procedure declaration wasn't found. Imp := Get_Named_Entity (Name); if Is_Error (Imp) then return; end if; + Set_Implementation (Call, Imp); Name_To_Method_Object (Call, Name); Parameters_Chain := Get_Parameter_Association_Chain (Call); @@ -1472,7 +1475,7 @@ package body Sem_Expr is if Sem_Subprogram_Call (Call, Null_Iir) /= Call then return; end if; - Imp := Get_Named_Entity (Get_Implementation (Call)); + Imp := Get_Implementation (Call); if Is_Overload_List (Imp) then -- Failed to resolve overload. return; @@ -3408,6 +3411,18 @@ package body Sem_Expr is Set_Constraint_State (A_Subtype, Fully_Constrained); Set_Type (Aggr, A_Subtype); Set_Literal_Subtype (Aggr, A_Subtype); + else + -- Free unused indexes subtype. + for I in Infos'Range loop + declare + St : constant Iir := Infos (I).Index_Subtype; + begin + if St /= Null_Iir then + Free_Iir (Get_Range_Constraint (St)); + Free_Iir (St); + end if; + end; + end loop; end if; Prev_Info := Null_Iir; diff --git a/sem_names.adb b/sem_names.adb index 17353cdef..3cf273b8c 100644 --- a/sem_names.adb +++ b/sem_names.adb @@ -731,7 +731,7 @@ package body Sem_Names is Rtype : Iir; begin Set_Prefix (Call, Prefix); - Set_Implementation (Call, Prefix); + Set_Implementation (Call, Get_Named_Entity (Prefix)); -- LRM08 8.1 Names -- The name is a simple name or seleted name that does NOT denote a @@ -877,7 +877,12 @@ package body Sem_Names is pragma Assert (Get_Parameter (Attr) = Null_Iir); Set_Parameter (Attr, Parameter); - if Get_Kind (Prefix_Type) = Iir_Kind_Array_Subtype_Definition then + + -- If the corresponding type is known, save it so that it is not + -- necessary to extract it from the object. + if Get_Kind (Prefix_Type) = Iir_Kind_Array_Subtype_Definition + and then Get_Constraint_State (Prefix_Type) = Fully_Constrained + then Set_Index_Subtype (Attr, Index_Type); end if; @@ -1511,6 +1516,7 @@ package body Sem_Names is Finish_Sem_Slice_Name (Res); Free_Parenthesis_Name (Name, Res); when Iir_Kind_Selected_Element => + pragma Assert (Get_Kind (Name) = Iir_Kind_Selected_Name); Xref_Ref (Res, Get_Selected_Element (Res)); Set_Name_Staticness (Res, Get_Name_Staticness (Prefix)); Set_Expr_Staticness (Res, Get_Expr_Staticness (Prefix)); @@ -1740,43 +1746,39 @@ package body Sem_Names is end if; end Error_Selected_Element; - procedure Sem_As_Method_Call (Sub_Name : Iir) + procedure Sem_As_Protected_Item (Sub_Name : Iir) is - Prot_Type : Iir; + Prot_Type : constant Iir := Get_Type (Sub_Name); Method : Iir; - Found : Boolean := False; begin - Prot_Type := Get_Type (Sub_Name); - - -- Build overload list from all declarations in chain, matching name, - -- which are actually functions or procedures. - -- TODO: error here if there's a variable with matching name? - -- currently we warn... - -- Rather than add a "Find_nth_name_in chain" to iirs_utils I have - -- expanded the chain walk here. + -- LRM98 12.3 Visibility + -- s) For a subprogram declared immediately within a given protected + -- type declaration: at the place of the suffix in a selected + -- name whose prefix denotes an object of the protected type. Method := Get_Declaration_Chain (Prot_Type); while Method /= Null_Iir loop - if Get_Identifier (Method) = Suffix then -- found the name - -- Check it's a method. - case Get_Kind (Method) is - when Iir_Kind_Function_Declaration | - Iir_Kind_Procedure_Declaration => - Found := True; + case Get_Kind (Method) is + when Iir_Kind_Function_Declaration | + Iir_Kind_Procedure_Declaration => + if Get_Identifier (Method) = Suffix then Add_Result (Res, Method); - when others => - Warning_Msg_Sem ("sem_as_method_call", Method); - end case; - end if; + end if; + when Iir_Kind_Attribute_Specification + | Iir_Kind_Use_Clause => + null; + when others => + Error_Kind ("sem_as_protected_item", Method); + end case; Method := Get_Chain (Method); end loop; - if not Found then - Error_Msg_Sem - ("no method " & Name_Table.Image (Suffix) & " in " - & Disp_Node (Prot_Type), Name); - return; - end if; - end Sem_As_Method_Call; + end Sem_As_Protected_Item; + procedure Error_Protected_Item (Prot_Type : Iir) is + begin + Error_Msg_Sem + ("no method " & Name_Table.Image (Suffix) & " in " + & Disp_Node (Prot_Type), Name); + end Error_Protected_Item; begin -- Analyze prefix. Sem_Name (Prefix_Name); @@ -1909,7 +1911,10 @@ package body Sem_Names is if Get_Kind (Get_Type (Prefix)) = Iir_Kind_Protected_Type_Declaration then - Sem_As_Method_Call (Prefix); + Sem_As_Protected_Item (Prefix); + if Res = Null_Iir then + Error_Protected_Item (Prefix); + end if; else Sem_As_Selected_Element (Prefix); if Res = Null_Iir then @@ -2189,6 +2194,18 @@ package body Sem_Names is end if; end Sem_Parenthesis_Function; + procedure Error_Parenthesis_Function (Spec : Iir) + is + Match : Boolean; + begin + Error_Msg_Sem + ("cannot match " & Disp_Node (Prefix) & " with actuals", Name); + -- Display error message. + Sem_Association_Chain + (Get_Interface_Declaration_Chain (Spec), + Assoc_Chain, True, Missing_Parameter, Name, Match); + end Error_Parenthesis_Function; + Actual : Iir; Actual_Expr : Iir; begin @@ -2280,17 +2297,7 @@ package body Sem_Names is when Iir_Kinds_Function_Declaration => Sem_Parenthesis_Function (Prefix); if Res = Null_Iir then - Error_Msg_Sem - ("cannot match " & Disp_Node (Prefix) & " with actuals", - Name); - -- Display error message. - declare - Match : Boolean; - begin - Sem_Association_Chain - (Get_Interface_Declaration_Chain (Prefix), - Assoc_Chain, True, Missing_Parameter, Name, Match); - end; + Error_Parenthesis_Function (Prefix); end if; when Iir_Kinds_Object_Declaration @@ -3735,6 +3742,7 @@ package body Sem_Names is | Iir_Kind_Entity_Declaration | Iir_Kind_Configuration_Declaration | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration | Iir_Kind_Library_Declaration | Iir_Kinds_Subprogram_Declaration | Iir_Kind_Component_Declaration => diff --git a/sem_scopes.adb b/sem_scopes.adb index 2ff4b4e58..6590e4825 100644 --- a/sem_scopes.adb +++ b/sem_scopes.adb @@ -1183,12 +1183,30 @@ package body Sem_Scopes is is Header : constant Iir := Get_Package_Header (Decl); begin + -- LRM08 12.1 Declarative region + -- d) A package declaration together with the corresponding body + -- + -- GHDL: the formal generic declarations are considered to be in the + -- same declarative region as the package declarations (and therefore + -- in the same scope), even if they don't occur immediately within a + -- package declaration. if Header /= Null_Iir then Add_Declarations (Get_Generic_Chain (Header), Potentially); end if; + Add_Declarations (Get_Declaration_Chain (Decl), Potentially); end Add_Package_Declarations; + procedure Add_Package_Instantiation_Declarations + (Decl: Iir; Potentially : Boolean) is + begin + -- LRM08 4.9 Package instantiation declarations + -- The package instantiation declaration is equivalent to declaration of + -- a generic-mapped package, consisting of a package declaration [...] + Add_Declarations (Get_Generic_Chain (Decl), Potentially); + Add_Declarations (Get_Declaration_Chain (Decl), Potentially); + end Add_Package_Instantiation_Declarations; + -- Add declarations from a package into the current declarative region. -- This is needed when a package body is analysed. procedure Add_Package_Declarations (Decl: Iir_Package_Declaration) is @@ -1265,14 +1283,7 @@ package body Sem_Scopes is when Iir_Kind_Package_Declaration => Add_Package_Declarations (Name, True); when Iir_Kind_Package_Instantiation_Declaration => - declare - Pkg : constant Iir := - Get_Named_Entity (Get_Uninstantiated_Name (Name)); - begin - if Pkg /= Null_Iir then - Add_Package_Declarations (Pkg, True); - end if; - end; + Add_Package_Instantiation_Declarations (Name, True); when Iir_Kind_Error => null; when others => diff --git a/sem_stmts.adb b/sem_stmts.adb index d7079925f..b95b3e510 100644 --- a/sem_stmts.adb +++ b/sem_stmts.adb @@ -1417,7 +1417,7 @@ package body Sem_Stmts is Sem_Procedure_Call (Call, Stmt); if Is_Passive then - Imp := Get_Named_Entity (Get_Implementation (Call)); + Imp := Get_Implementation (Call); if Get_Kind (Imp) = Iir_Kind_Procedure_Declaration then Decl := Get_Interface_Declaration_Chain (Imp); while Decl /= Null_Iir loop diff --git a/sem_types.adb b/sem_types.adb index 8c4c5a48e..6f54e9e3e 100644 --- a/sem_types.adb +++ b/sem_types.adb @@ -387,10 +387,7 @@ package body Sem_Types is Val := Sem_Expression (Get_Physical_Literal (Unit), Def); if Val /= Null_Iir then Set_Physical_Literal (Unit, Val); - Val := Eval_Static_Expr (Val); - if Get_Kind (Val) = Iir_Kind_Unit_Declaration then - Val := Create_Physical_Literal (1, Val); - end if; + Val := Eval_Physical_Literal (Val); Set_Physical_Unit_Value (Unit, Val); -- LRM93 §3.1 diff --git a/simulate/elaboration.adb b/simulate/elaboration.adb index 0abe8113d..dd405ec18 100644 --- a/simulate/elaboration.adb +++ b/simulate/elaboration.adb @@ -1864,16 +1864,18 @@ package body Elaboration is (Item, Sub_Instances (Ind + I - 1)); end loop; when Iir_Kind_Indexed_Name => - Expr := Execute_Expression - (Instance, Get_First_Element (Get_Index_List (Spec))); - Ind := Instance_Slot_Type - (Get_Index_Offset (Expr, Bounds, Spec)); - Sub_Conf (Ind) := True; - Elaborate_Block_Configuration (Item, Sub_Instances (Ind)); - when Iir_Kind_Selected_Name => - -- Must be the only default block configuration - pragma Assert (Default_Item = Null_Iir); - Default_Item := Item; + if Get_Index_List (Spec) = Iir_List_Others then + -- Must be the only default block configuration + pragma Assert (Default_Item = Null_Iir); + Default_Item := Item; + else + Expr := Execute_Expression + (Instance, Get_First_Element (Get_Index_List (Spec))); + Ind := Instance_Slot_Type + (Get_Index_Offset (Expr, Bounds, Spec)); + Sub_Conf (Ind) := True; + Elaborate_Block_Configuration (Item, Sub_Instances (Ind)); + end if; when Iir_Kind_Generate_Statement => -- Must be the only block configuration pragma Assert (Item = Conf_Chain); diff --git a/translate/gcc/dist-common.sh b/translate/gcc/dist-common.sh index d7a4970f7..473ebb142 100644 --- a/translate/gcc/dist-common.sh +++ b/translate/gcc/dist-common.sh @@ -19,6 +19,8 @@ sem_scopes.adb sem_scopes.ads sem_decls.ads sem_decls.adb +sem_inst.ads +sem_inst.adb sem_specs.ads sem_specs.adb sem_stmts.ads diff --git a/translate/ghdldrv/Makefile b/translate/ghdldrv/Makefile index c4464268d..888014bf7 100644 --- a/translate/ghdldrv/Makefile +++ b/translate/ghdldrv/Makefile @@ -166,7 +166,7 @@ grt.links: install.all: install.v87 install.v93 install.standard install.gcc: - $(MAKE) GHDL=ghdl_gcc install.v08 #install.v87 install.v93 install.v08 + $(MAKE) GHDL=ghdl_gcc install.v87 install.v93 install.v08 install.mcode: $(MAKE) GHDL=ghdl_mcode install.v87 install.v93 install.v08 diff --git a/translate/ghdldrv/ghdlrun.adb b/translate/ghdldrv/ghdlrun.adb index d4ac38740..f6237214e 100644 --- a/translate/ghdldrv/ghdlrun.adb +++ b/translate/ghdldrv/ghdlrun.adb @@ -76,6 +76,9 @@ package body Ghdlrun is Translation.Foreign_Hook := Foreign_Hook'Access; + -- FIXME: add a flag to force unnesting. + -- Translation.Flag_Unnest_Subprograms := True; + -- The design is always analyzed in whole. Flags.Flag_Whole_Analyze := True; @@ -541,6 +544,8 @@ package body Ghdlrun is Grt.Images.Ghdl_To_String_E8'Address); Def (Trans_Decls.Ghdl_To_String_E32, Grt.Images.Ghdl_To_String_E32'Address); + Def (Trans_Decls.Ghdl_To_String_Char, + Grt.Images.Ghdl_To_String_Char'Address); Def (Trans_Decls.Ghdl_To_String_P32, Grt.Images.Ghdl_To_String_P32'Address); Def (Trans_Decls.Ghdl_To_String_P64, diff --git a/translate/grt/grt-images.adb b/translate/grt/grt-images.adb index 59830c137..342c98f2a 100644 --- a/translate/grt/grt-images.adb +++ b/translate/grt/grt-images.adb @@ -266,6 +266,11 @@ package body Grt.Images is To_String_Enum (Res, Rti, Ghdl_E32'Pos (Val)); end Ghdl_To_String_E32; + procedure Ghdl_To_String_Char (Res : Std_String_Ptr; Val : Std_Character) is + begin + Return_String (Res, (1 => Val)); + end Ghdl_To_String_Char; + procedure Ghdl_To_String_P32 (Res : Std_String_Ptr; Val : Ghdl_I32; Rti : Ghdl_Rti_Access) renames Ghdl_Image_P32; diff --git a/translate/grt/grt-images.ads b/translate/grt/grt-images.ads index b85f8e6a0..cd8911091 100644 --- a/translate/grt/grt-images.ads +++ b/translate/grt/grt-images.ads @@ -54,6 +54,8 @@ package Grt.Images is (Res : Std_String_Ptr; Val : Ghdl_E8; Rti : Ghdl_Rti_Access); procedure Ghdl_To_String_E32 (Res : Std_String_Ptr; Val : Ghdl_E32; Rti : Ghdl_Rti_Access); + procedure Ghdl_To_String_Char + (Res : Std_String_Ptr; Val : Std_Character); procedure Ghdl_To_String_P32 (Res : Std_String_Ptr; Val : Ghdl_I32; Rti : Ghdl_Rti_Access); procedure Ghdl_To_String_P64 @@ -93,6 +95,7 @@ private pragma Export (Ada, Ghdl_To_String_B1, "__ghdl_to_string_b1"); pragma Export (C, Ghdl_To_String_E8, "__ghdl_to_string_e8"); pragma Export (C, Ghdl_To_String_E32, "__ghdl_to_string_e32"); + pragma Export (C, Ghdl_To_String_Char, "__ghdl_to_string_char"); pragma Export (C, Ghdl_To_String_P32, "__ghdl_to_string_p32"); pragma Export (C, Ghdl_To_String_P64, "__ghdl_to_string_p64"); pragma Export (C, Ghdl_Time_To_String_Unit, "__ghdl_time_to_string_unit"); diff --git a/translate/trans_analyzes.adb b/translate/trans_analyzes.adb index c8fb14e62..cf800f0d4 100644 --- a/translate/trans_analyzes.adb +++ b/translate/trans_analyzes.adb @@ -70,7 +70,7 @@ package body Trans_Analyzes is (Get_Target (Stmt), Extract_Driver_Target'Access); when Iir_Kind_Procedure_Call_Statement => declare - Call : Iir; + Call : constant Iir := Get_Procedure_Call (Stmt); Assoc : Iir; Formal : Iir; Inter : Iir; @@ -78,10 +78,9 @@ package body Trans_Analyzes is -- Very pessimist. Has_After := True; - Call := Get_Procedure_Call (Stmt); Assoc := Get_Parameter_Association_Chain (Call); Inter := Get_Interface_Declaration_Chain - (Get_Named_Entity (Get_Implementation (Call))); + (Get_Implementation (Call)); while Assoc /= Null_Iir loop Formal := Get_Formal (Assoc); if Formal = Null_Iir then diff --git a/translate/trans_decls.ads b/translate/trans_decls.ads index 3ab83b4ec..e104c71c4 100644 --- a/translate/trans_decls.ads +++ b/translate/trans_decls.ads @@ -238,6 +238,7 @@ package Trans_Decls is Ghdl_To_String_B1 : O_Dnode; Ghdl_To_String_E8 : O_Dnode; Ghdl_To_String_E32 : O_Dnode; + Ghdl_To_String_Char : O_Dnode; Ghdl_To_String_P32 : O_Dnode; Ghdl_To_String_P64 : O_Dnode; Ghdl_Time_To_String_Unit : O_Dnode; diff --git a/translate/translation.adb b/translate/translation.adb index fda2c2f45..d43a02f77 100644 --- a/translate/translation.adb +++ b/translate/translation.adb @@ -211,16 +211,55 @@ package body Translation is -- Set the global scope handling. Global_Storage : O_Storage; + -- Scope for variables. This is used both to build instances (so it + -- contains the record type that contains objects declared in that + -- scope) and to use instances (it contains the path to access to these + -- objects). + type Var_Scope_Type is private; + + type Var_Scope_Acc is access all Var_Scope_Type; + for Var_Scope_Acc'Storage_Size use 0; + + Null_Var_Scope : constant Var_Scope_Type; + + -- Return the record type for SCOPE. + function Get_Scope_Type (Scope : Var_Scope_Type) return O_Tnode; + + -- Return the size for instances of SCOPE. + function Get_Scope_Size (Scope : Var_Scope_Type) return O_Cnode; + + -- Return True iff SCOPE is defined. + function Has_Scope_Type (Scope : Var_Scope_Type) return Boolean; + + -- Create an empty and incomplete scope type for SCOPE using NAME. + procedure Predeclare_Scope_Type (Scope : Var_Scope_Acc; Name : O_Ident); + + -- Declare a pointer PTR_TYPE with NAME to scope type SCOPE. + procedure Declare_Scope_Acc + (Scope : Var_Scope_Type; Name : O_Ident; Ptr_Type : out O_Tnode); + -- Start to build an instance. -- If INSTANCE_TYPE is not O_TNODE_NULL, it must be an uncompleted -- record type, that will be completed. - procedure Push_Instance_Factory (Instance_Type : O_Tnode); + procedure Push_Instance_Factory (Scope : Var_Scope_Acc); + -- Manually add a field to the current instance being built. function Add_Instance_Factory_Field (Name : O_Ident; Ftype : O_Tnode) - return O_Fnode; + return O_Fnode; + + -- In the scope being built, add a field NAME that contain sub-scope + -- CHILD. CHILD is modified so that accesses to CHILD objects is done + -- via SCOPE. + procedure Add_Scope_Field + (Name : O_Ident; Child : in out Var_Scope_Type); + + -- Return the offset of field for CHILD in its parent scope. + function Get_Scope_Offset (Child : Var_Scope_Type; Otype : O_Tnode) + return O_Cnode; + -- Finish the building of the current instance and return the type -- built. - procedure Pop_Instance_Factory (Instance_Type : out O_Tnode); + procedure Pop_Instance_Factory (Scope : Var_Scope_Acc); -- Create a new scope, in which variable are created locally -- (ie, on the stack). Always created unlocked. @@ -229,22 +268,31 @@ package body Translation is -- Destroy a local scope. procedure Pop_Local_Factory; - -- Push_scope defines how to access to a variable stored in an instance. - -- Variables defined in SCOPE_TYPE can be accessed via field SCOPE_FIELD + -- Set_Scope defines how to access to variables of SCOPE. + -- Variables defined in SCOPE can be accessed via field SCOPE_FIELD -- in scope SCOPE_PARENT. - procedure Push_Scope (Scope_Type : O_Tnode; - Scope_Field : O_Fnode; Scope_Parent : O_Tnode); + procedure Set_Scope_Via_Field + (Scope : in out Var_Scope_Type; + Scope_Field : O_Fnode; Scope_Parent : Var_Scope_Acc); + -- Variables defined in SCOPE_TYPE can be accessed by dereferencing -- field SCOPE_FIELD defined in SCOPE_PARENT. - procedure Push_Scope_Via_Field_Ptr - (Scope_Type : O_Tnode; - Scope_Field : O_Fnode; Scope_Parent : O_Tnode); + procedure Set_Scope_Via_Field_Ptr + (Scope : in out Var_Scope_Type; + Scope_Field : O_Fnode; Scope_Parent : Var_Scope_Acc); + -- Variables/scopes defined in SCOPE_TYPE can be accessed via -- dereference of parameter SCOPE_PARAM. - procedure Push_Scope (Scope_Type : O_Tnode; Scope_Param : O_Dnode); - -- No more accesses to SCOPE_TYPE are allowed. - -- Scopes must be poped in the reverse order they are pushed. - procedure Pop_Scope (Scope_Type : O_Tnode); + procedure Set_Scope_Via_Param_Ptr + (Scope : in out Var_Scope_Type; Scope_Param : O_Dnode); + + -- Variables/scopes defined in SCOPE_TYPE can be accessed via DECL. + procedure Set_Scope_Via_Decl + (Scope : in out Var_Scope_Type; Decl : O_Dnode); + + -- No more accesses to SCOPE_TYPE are allowed. Scopes must be cleared + -- before being set. + procedure Clear_Scope (Scope : in out Var_Scope_Type); -- Reset the identifier. type Id_Mark_Type is limited private; @@ -291,18 +339,16 @@ package body Translation is -- IE, if the variable is global, prepend the prefix, -- if the variable belong to an instance, no prefix is added. type Var_Ident_Type is private; - --function Create_Var_Identifier (Id : Name_Id; Str : String) - -- return Var_Ident_Type; function Create_Var_Identifier (Id : Iir) return Var_Ident_Type; function Create_Var_Identifier (Id : String) return Var_Ident_Type; function Create_Var_Identifier (Id : Iir; Str : String; Val : Natural) return Var_Ident_Type; function Create_Uniq_Identifier return Var_Ident_Type; - type Var_Type (<>) is limited private; - type Var_Acc is access Var_Type; + type Var_Type is private; + Null_Var : constant Var_Type; - -- Create a variable in the current scope. + -- Create variable NAME of type VTYPE in the current scope. -- If the current scope is the global scope, then a variable is -- created at the top level (using decl_global_storage). -- If the current scope is not the global scope, then a field is added @@ -311,12 +357,12 @@ package body Translation is (Name : Var_Ident_Type; Vtype : O_Tnode; Storage : O_Storage := Global_Storage) - return Var_Acc; + return Var_Type; -- Create a global variable. function Create_Global_Var (Name : O_Ident; Vtype : O_Tnode; Storage : O_Storage) - return Var_Acc; + return Var_Type; -- Create a global constant and initialize it to INITIAL_VALUE. function Create_Global_Const @@ -324,32 +370,29 @@ package body Translation is Vtype : O_Tnode; Storage : O_Storage; Initial_Value : O_Cnode) - return Var_Acc; - procedure Define_Global_Const (Const : Var_Acc; Val : O_Cnode); + return Var_Type; + procedure Define_Global_Const (Const : in out Var_Type; Val : O_Cnode); -- Return the (real) reference to a variable created by Create_Var. - function Get_Var (Var : Var_Acc) return O_Lnode; - - procedure Free_Var (Var : in out Var_Acc); + function Get_Var (Var : Var_Type) return O_Lnode; -- Return a reference to the instance of type ITYPE. - function Get_Instance_Ref (Itype : O_Tnode) return O_Lnode; + function Get_Instance_Ref (Scope : Var_Scope_Type) return O_Lnode; -- Return the address of the instance for block BLOCK. function Get_Instance_Access (Block : Iir) return O_Enode; -- Return the storage for the variable VAR. - function Get_Alloc_Kind_For_Var (Var : Var_Acc) return Allocation_Kind; + function Get_Alloc_Kind_For_Var (Var : Var_Type) return Allocation_Kind; -- Return TRUE iff VAR is stable, ie get_var (VAR) can be referenced -- several times. - function Is_Var_Stable (Var : Var_Acc) return Boolean; + function Is_Var_Stable (Var : Var_Type) return Boolean; -- Used only to generate RTI. - function Is_Var_Field (Var : Var_Acc) return Boolean; - function Get_Var_Field (Var : Var_Acc) return O_Fnode; - function Get_Var_Record (Var : Var_Acc) return O_Tnode; - function Get_Var_Label (Var : Var_Acc) return O_Dnode; + function Is_Var_Field (Var : Var_Type) return Boolean; + function Get_Var_Offset (Var : Var_Type; Otype : O_Tnode) return O_Cnode; + function Get_Var_Label (Var : Var_Type) return O_Dnode; private type Local_Identifier_Type is new Natural; type Id_Mark_Type is record @@ -361,12 +404,6 @@ package body Translation is Id : O_Ident; end record; - -- Kind of variable: - -- VAR_GLOBAL: the variable is a global variable (static or not). - -- VAR_LOCAL: the variable is on the stack. - -- VAR_SCOPE: the variable is in the instance record. - type Var_Kind is (Var_Global, Var_Scope, Var_Local); - -- An instance contains all the data (variable, signals, constant...) -- which are declared by an entity and an architecture. -- (An architecture inherits the data of its entity). @@ -388,22 +425,64 @@ package body Translation is when Global => null; when Instance => + Scope : Var_Scope_Acc; Elements : O_Element_List; - Vars : Var_Acc; end case; end record; - type Var_Type (Kind : Var_Kind) is record + -- Kind of variable: + -- VAR_NONE: the variable doesn't exist. + -- VAR_GLOBAL: the variable is a global variable (static or not). + -- VAR_LOCAL: the variable is on the stack. + -- VAR_SCOPE: the variable is in the instance record. + type Var_Kind is (Var_None, Var_Global, Var_Local, Var_Scope); + + type Var_Type (Kind : Var_Kind := Var_None) is record case Kind is + when Var_None => + null; when Var_Global | Var_Local => E : O_Dnode; when Var_Scope => I_Field : O_Fnode; - I_Type : O_Tnode; - I_Link : Var_Acc; + I_Scope : Var_Scope_Acc; end case; end record; + + Null_Var : constant Var_Type := (Kind => Var_None); + + type Var_Scope_Kind is (Var_Scope_None, + Var_Scope_Ptr, + Var_Scope_Decl, + Var_Scope_Field, + Var_Scope_Field_Ptr); + + type Var_Scope_Type (Kind : Var_Scope_Kind := Var_Scope_None) is record + Scope_Type : O_Tnode := O_Tnode_Null; + + case Kind is + when Var_Scope_None => + -- Not set, cannot be referenced. + null; + when Var_Scope_Ptr + | Var_Scope_Decl => + -- Instance for entity, architecture, component, subprogram, + -- resolver, process, guard function, PSL directive, PSL cover, + -- PSL assert, component instantiation elaborator + D : O_Dnode; + when Var_Scope_Field + | Var_Scope_Field_Ptr => + -- For an entity: the architecture. + -- For an architecture: ptr to a generate subblock. + -- For a subprogram: parent frame + Field : O_Fnode; + Up_Link : Var_Scope_Acc; + end case; + end record; + + Null_Var_Scope : constant Var_Scope_Type := (Scope_Type => O_Tnode_Null, + Kind => Var_Scope_None); end Chap10; use Chap10; @@ -441,17 +520,20 @@ package body Translation is -- overload number if any. procedure Push_Subprg_Identifier (Spec : Iir; Mark : out Id_Mark_Type); --- procedure Translate_Protected_Subprogram_Declaration --- (Def : Iir_Protected_Type_Declaration; Spec : Iir; Block : Iir); - procedure Translate_Package_Declaration (Decl : Iir_Package_Declaration); procedure Translate_Package_Body (Decl : Iir_Package_Body); + procedure Translate_Package_Instantiation_Declaration (Inst : Iir); procedure Elab_Package_Body (Spec : Iir_Package_Declaration; Bod : Iir); -- Elaborate packages that DESIGN_UNIT depends on (except std.standard). procedure Elab_Dependence (Design_Unit: Iir_Design_Unit); + -- Declare an incomplete record type DECL_TYPE and access PTR_TYPE to + -- it. The names are respectively INSTTYPE and INSTPTR. + procedure Declare_Inst_Type_And_Ptr (Scope : Var_Scope_Acc; + Ptr_Type : out O_Tnode); + -- Subprograms instances. -- -- Subprograms declared inside entities, architecture, blocks @@ -470,8 +552,8 @@ package body Translation is type Subprg_Instance_Stack is limited private; -- Declare an instance to be added for subprograms. - -- DECL_TYPE is the type of the instance; this should be a record. This - -- is used by PUSH_SCOPE. + -- DECL is the node for which the instance is created. This is used by + -- PUSH_SCOPE. -- PTR_TYPE is a pointer to DECL_TYPE. -- IDENT is an identifier for the interface. -- The previous instance is stored to PREV. It must be restored with @@ -479,7 +561,7 @@ package body Translation is -- Add_Subprg_Instance_Interfaces will add an interface of name IDENT -- and type PTR_TYPE for every instance declared by -- PUSH_SUBPRG_INSTANCE. - procedure Push_Subprg_Instance (Decl_Type : O_Tnode; + procedure Push_Subprg_Instance (Scope : Var_Scope_Acc; Ptr_Type : O_Tnode; Ident : O_Ident; Prev : out Subprg_Instance_Stack); @@ -496,6 +578,9 @@ package body Translation is procedure Pop_Subprg_Instance (Ident : O_Ident; Prev : Subprg_Instance_Stack); + -- True iff there is currently a subprogram instance. + function Has_Current_Subprg_Instance return Boolean; + -- Contains the subprogram interface for the instance. type Subprg_Instance_Type is private; Null_Subprg_Instance : constant Subprg_Instance_Type; @@ -508,11 +593,19 @@ package body Translation is -- instance. procedure Add_Subprg_Instance_Field (Field : out O_Fnode); - -- Associate values to the instance interfaces during invocation of a + -- Associate values to the instance interface during invocation of a -- subprogram. procedure Add_Subprg_Instance_Assoc (Assocs : in out O_Assoc_List; Vars : Subprg_Instance_Type); + -- Get the value to be associated to the instance interface. + function Get_Subprg_Instance (Vars : Subprg_Instance_Type) + return O_Enode; + + -- True iff VARS is associated with an instance. + function Has_Subprg_Instance (Vars : Subprg_Instance_Type) + return Boolean; + -- Assign the instance field FIELD of VAR. procedure Set_Subprg_Instance_Field (Var : O_Dnode; Field : O_Fnode; Vars : Subprg_Instance_Type); @@ -538,19 +631,19 @@ package body Translation is type Subprg_Instance_Type is record Inter : O_Dnode; Inter_Type : O_Tnode; - Inst_Type : O_Tnode; + Scope : Var_Scope_Acc; end record; Null_Subprg_Instance : constant Subprg_Instance_Type := - (O_Dnode_Null, O_Tnode_Null, O_Tnode_Null); + (O_Dnode_Null, O_Tnode_Null, null); type Subprg_Instance_Stack is record - Decl_Type : O_Tnode; + Scope : Var_Scope_Acc; Ptr_Type : O_Tnode; Ident : O_Ident; end record; Null_Subprg_Instance_Stack : constant Subprg_Instance_Stack := - (O_Tnode_Null, O_Tnode_Null, O_Ident_Nul); + (null, O_Tnode_Null, O_Ident_Nul); Current_Subprg_Instance : Subprg_Instance_Stack := Null_Subprg_Instance_Stack; @@ -570,6 +663,8 @@ package body Translation is -- Elab an unconstrained port. procedure Elab_Unconstrained_Port (Port : Iir; Actual : Iir); + procedure Elab_Generic_Map_Aspect (Mapping : Iir); + -- There are 4 cases of generic/port map: -- 1) component instantiation -- 2) component configuration (association of a component with an entity @@ -759,6 +854,7 @@ package body Translation is Kind_Component, Kind_Field, Kind_Package, + Kind_Package_Instance, Kind_Config, Kind_Assoc, Kind_Str_Choice, @@ -802,7 +898,7 @@ package body Translation is Range_Ptr_Type : O_Tnode; -- Tree for the range record declaration. - Range_Var : Var_Acc; + Range_Var : Var_Type; -- Fields of TYPE_RANGE_TYPE. Range_Left : O_Fnode; @@ -826,24 +922,26 @@ package body Translation is Static_Bounds : Boolean; -- Variable containing the bounds for a constrained array. - Array_Bounds : Var_Acc; + Array_Bounds : Var_Type; -- Variable containing a 1 length bound for unidimensional -- unconstrained arrays. - Array_1bound : Var_Acc; + Array_1bound : Var_Type; -- Variable containing the description for each index. - Array_Index_Desc : Var_Acc; + Array_Index_Desc : Var_Type; when Kind_Type_Record => -- Variable containing the description for each element. - Record_El_Desc : Var_Acc; + Record_El_Desc : Var_Type; when Kind_Type_File => -- Constant containing the signature of the file. File_Signature : O_Dnode; when Kind_Type_Protected => + Prot_Scope : aliased Var_Scope_Type; + -- Init procedure for the protected type. Prot_Init_Subprg : O_Dnode; Prot_Init_Instance : Chap2.Subprg_Instance_Type; @@ -878,14 +976,14 @@ package body Translation is Bounds_Field => (O_Fnode_Null, O_Fnode_Null), Bounds_Vector => null, Static_Bounds => False, - Array_Bounds => null, - Array_1bound => null, - Array_Index_Desc => null); + Array_Bounds => Null_Var, + Array_1bound => Null_Var, + Array_Index_Desc => Null_Var); Ortho_Info_Type_Record_Init : constant Ortho_Info_Type_Type := (Kind => Kind_Type_Record, Rti_Max_Depth => 0, - Record_El_Desc => null); + Record_El_Desc => Null_Var); Ortho_Info_Type_File_Init : constant Ortho_Info_Type_Type := (Kind => Kind_Type_File, @@ -895,6 +993,7 @@ package body Translation is Ortho_Info_Type_Prot_Init : constant Ortho_Info_Type_Type := (Kind => Kind_Type_Protected, Rti_Max_Depth => 0, + Prot_Scope => Null_Var_Scope, Prot_Init_Subprg => O_Dnode_Null, Prot_Init_Instance => Chap2.Null_Subprg_Instance, Prot_Final_Subprg => O_Dnode_Null, @@ -981,10 +1080,8 @@ package body Translation is -- Additional informations for a resolving function. type Subprg_Resolv_Info is record Resolv_Func : O_Dnode; - -- Base block which the function was defined in. - Resolv_Block : Iir; -- Parameter nodes. - Var_Instance : O_Dnode; + Var_Instance : Chap2.Subprg_Instance_Type; -- Signals Var_Vals : O_Dnode; @@ -1097,7 +1194,7 @@ package body Translation is -- Variable containing the size of the type. -- This is defined only for types whose size is only known at -- running time (and not a compile-time). - Size_Var : Var_Acc; + Size_Var : Var_Type; -- Variable containing the alignment of the type. -- Only defined for recods and for Mode_Value. @@ -1108,7 +1205,7 @@ package body Translation is -- doesn't fit in the whole machinery (in particular, there is no -- easy way to compute it once). As the overhead is very low, no need -- to bother with this issue. - Align_Var : Var_Acc; + Align_Var : Var_Type; Builder_Need_Func : Boolean; @@ -1143,7 +1240,7 @@ package body Translation is type Direct_Driver_Type is record Sig : Iir; - Var : Var_Acc; + Var : Var_Type; end record; type Direct_Driver_Arr is array (Natural range <>) of Direct_Driver_Type; type Direct_Drivers_Acc is access Direct_Driver_Arr; @@ -1226,14 +1323,17 @@ package body Translation is -- procedure. RES_INTERFACE is the interface for this pointer. Res_Interface : O_Dnode := O_Dnode_Null; - -- For a procedure with a result interface: + -- Field in the frame for a pointer to the RESULT structure. + Res_Record_Var : Var_Type := Null_Var; + + -- For a subprogram with a result interface: -- Type definition for the record. Res_Record_Type : O_Tnode := O_Tnode_Null; -- Type definition for access to the record. Res_Record_Ptr : O_Tnode := O_Tnode_Null; - -- Type of the frame record (used to unnest subprograms). - Subprg_Frame_Type : O_Tnode := O_Tnode_Null; + -- Access to the declarations within this subprogram. + Subprg_Frame_Scope : aliased Var_Scope_Type; -- Instances for the subprograms. Subprg_Instance : Chap2.Subprg_Instance_Type := @@ -1254,9 +1354,9 @@ package body Translation is -- For constants: set when the object is defined as a constant. Object_Static : Boolean; -- The object itself. - Object_Var : Var_Acc; + Object_Var : Var_Type; -- Direct driver for signal (if any). - Object_Driver : Var_Acc := null; + Object_Driver : Var_Type := Null_Var; -- RTI constant for the object. Object_Rti : O_Dnode := O_Dnode_Null; -- Function to compute the value of object (used for implicit @@ -1264,11 +1364,11 @@ package body Translation is Object_Function : O_Dnode; when Kind_Alias => - Alias_Var : Var_Acc; + Alias_Var : Var_Type; Alias_Kind : Object_Kind_Type; when Kind_Iterator => - Iterator_Var : Var_Acc; + Iterator_Var : Var_Type; when Kind_Interface => -- Ortho declaration for the interface. If not null, there is @@ -1291,14 +1391,10 @@ package body Translation is when Kind_Disconnect => -- Variable which contains the time_expression of the -- disconnection specification - Disconnect_Var : Var_Acc; + Disconnect_Var : Var_Type; when Kind_Process => - -- Type of process declarations record. - Process_Decls_Type : O_Tnode; - - -- Field in the parent block for the declarations in the process. - Process_Parent_Field : O_Fnode; + Process_Scope : aliased Var_Scope_Type; -- Subprogram for the process. Process_Subprg : O_Dnode; @@ -1308,12 +1404,9 @@ package body Translation is -- RTI for the process. Process_Rti_Const : O_Dnode := O_Dnode_Null; - when Kind_Psl_Directive => - -- Type of assert declarations record. - Psl_Decls_Type : O_Tnode; - -- Field in the parent block for the declarations in the assert. - Psl_Parent_Field : O_Fnode; + when Kind_Psl_Directive => + Psl_Scope : aliased Var_Scope_Type; -- Procedure for the state machine. Psl_Proc_Subprg : O_Dnode; @@ -1327,23 +1420,27 @@ package body Translation is Psl_Vect_Type : O_Tnode; -- State vector variable. - Psl_Vect_Var : Var_Acc; + Psl_Vect_Var : Var_Type; -- Boolean variable (for cover) - Psl_Bool_Var : Var_Acc; + Psl_Bool_Var : Var_Type; -- RTI for the process. Psl_Rti_Const : O_Dnode := O_Dnode_Null; + when Kind_Loop => -- Labels for the loop. -- Used for exit/next from while-loop, and to exit from for-loop. Label_Exit : O_Snode; -- Used to next from for-loop, with an exit statment. Label_Next : O_Snode; + when Kind_Block => + -- Access to declarations of this block. + Block_Scope : aliased Var_Scope_Type; + -- Instance type (ortho record) for declarations contained in the -- block/entity/architecture. - Block_Decls_Type : O_Tnode; Block_Decls_Ptr_Type : O_Tnode; -- For Entity: field in the instance type containing link to @@ -1384,20 +1481,26 @@ package body Translation is -- RTI constant for the block. Block_Rti_Const : O_Dnode := O_Dnode_Null; + when Kind_Component => + -- How to access to component interfaces. + Comp_Scope : aliased Var_Scope_Type; + -- Instance for the component. - Comp_Type : O_Tnode; Comp_Ptr_Type : O_Tnode; -- Field containing a pointer to the instance link. Comp_Link : O_Fnode; -- RTI for the component. Comp_Rti_Const : O_Dnode; + when Kind_Config => -- Subprogram that configure the block. Config_Subprg : O_Dnode; + when Kind_Field => -- Node for a record element declaration. Field_Node : O_Fnode_Array := (O_Fnode_Null, O_Fnode_Null); + when Kind_Package => -- Subprogram which elaborate the package spec/body. -- External units should call the body elaborator. @@ -1405,19 +1508,44 @@ package body Translation is Package_Elab_Spec_Subprg : O_Dnode; Package_Elab_Body_Subprg : O_Dnode; + -- Instance for the elaborators. + Package_Elab_Spec_Instance : Chap2.Subprg_Instance_Type; + Package_Elab_Body_Instance : Chap2.Subprg_Instance_Type; + -- Variable set to true when the package is elaborated. - Package_Elab_Var : O_Dnode; + Package_Elab_Var : Var_Type; -- RTI constant for the package. Package_Rti_Const : O_Dnode; + -- Access to declarations of the spec. + Package_Spec_Scope : aliased Var_Scope_Type; + + -- Instance type for uninstantiated package + Package_Spec_Ptr_Type : O_Tnode; + + Package_Body_Scope : aliased Var_Scope_Type; + Package_Body_Ptr_Type : O_Tnode; + + -- Field to the spec within the body. + Package_Spec_Field : O_Fnode; + -- Local id, set by package declaration, continued by package -- body. Package_Local_Id : Local_Identifier_Type; + + when Kind_Package_Instance => + -- The variable containing the instance. + Package_Instance_Var : Var_Type; + + -- Elaboration procedure for the instance. + Package_Instance_Elab_Subprg : O_Dnode; + when Kind_Assoc => -- Association informations. Assoc_In : Assoc_Conv_Info; Assoc_Out : Assoc_Conv_Info; + when Kind_Str_Choice => -- List of choices, used to sort them. Choice_Chain : Ortho_Info_Acc; @@ -1427,8 +1555,10 @@ package body Translation is Choice_Expr : Iir; -- Corresponding choice. Choice_Parent : Iir; + when Kind_Design_File => Design_Filename : O_Dnode; + when Kind_Library => Library_Rti_Const : O_Dnode; end case; @@ -1493,7 +1623,7 @@ package body Translation is -- Create an ortho_info field of kind KIND for iir node TARGET, and -- return it. function Add_Info (Target : Iir; Kind : Ortho_Info_Kind) - return Ortho_Info_Acc + return Ortho_Info_Acc is Res : Ortho_Info_Acc; begin @@ -1508,16 +1638,6 @@ package body Translation is begin Info := Get_Info (Target); if Info /= null then - case Info.Kind is - when Kind_Object => - Free_Var (Info.Object_Var); - when Kind_Alias => - Free_Var (Info.Alias_Var); - when Kind_Iterator => - Free_Var (Info.Iterator_Var); - when others => - null; - end case; Unchecked_Deallocation (Info); Clear_Info (Target); end if; @@ -1530,27 +1650,19 @@ package body Translation is begin case Info.T.Kind is when Kind_Type_Scalar => - Free_Var (Info.T.Range_Var); + null; when Kind_Type_Array => - Free_Var (Info.T.Array_Bounds); if Full then Free (Info.T.Bounds_Vector); - Free_Var (Info.T.Array_1bound); - Free_Var (Info.T.Array_Index_Desc); end if; when Kind_Type_Record => - if Full then - Free_Var (Info.T.Record_El_Desc); - end if; + null; when Kind_Type_File => null; when Kind_Type_Protected => null; end case; if Info.C /= null then - Free_Var (Info.C (Mode_Value).Size_Var); - Free_Var (Info.C (Mode_Signal).Size_Var); - Free_Var (Info.C (Mode_Value).Align_Var); Free_Complex_Type_Info (Info.C); end if; Unchecked_Deallocation (Info); @@ -1702,7 +1814,7 @@ package body Translation is -- Transform VAR to Mnode. function Get_Var - (Var : Var_Acc; Vtype : Type_Info_Acc; Mode : Object_Kind_Type) + (Var : Var_Type; Vtype : Type_Info_Acc; Mode : Object_Kind_Type) return Mnode; -- Return a stabilized node for M. @@ -1767,6 +1879,7 @@ package body Translation is -- std.standard.bit. procedure Translate_Bool_Type_Definition (Def : Iir); + -- Call lock or unlock on a protected object. procedure Call_Ghdl_Protected_Procedure (Type_Def : Iir; Proc : O_Dnode); procedure Translate_Protected_Type_Body (Bod : Iir); @@ -1989,12 +2102,7 @@ package body Translation is procedure Translate_Declaration_Chain (Parent : Iir); -- Translate subprograms in declaration chain of PARENT. - -- For a global subprograms belonging to an instance (ie, subprograms - -- declared in a block, entity or architecture), BLOCK is the info - -- for the base block to which the subprograms belong; null if none; - -- It is used to add an instance parameter. - procedure Translate_Declaration_Chain_Subprograms - (Parent : Iir; Block : Iir); + procedure Translate_Declaration_Chain_Subprograms (Parent : Iir); -- Create subprograms for type/function conversion of signal -- associations. @@ -2908,13 +3016,13 @@ package body Translation is end Is_Stable; -- function Varv2M --- (Var : Var_Acc; Vtype : Type_Info_Acc; Mode : Object_Kind_Type) +-- (Var : Var_Type; Vtype : Type_Info_Acc; Mode : Object_Kind_Type) -- return Mnode is -- begin -- return Lv2M (Get_Var (Var), Vtype, Mode); -- end Varv2M; - function Varv2M (Var : Var_Acc; + function Varv2M (Var : Var_Type; Var_Type : Type_Info_Acc; Mode : Object_Kind_Type; Vtype : O_Tnode; @@ -2972,7 +3080,7 @@ package body Translation is end Lo2M; function Get_Var - (Var : Var_Acc; Vtype : Type_Info_Acc; Mode : Object_Kind_Type) + (Var : Var_Type; Vtype : Type_Info_Acc; Mode : Object_Kind_Type) return Mnode is L : O_Lnode; @@ -3860,14 +3968,10 @@ package body Translation is package body Chap1 is procedure Start_Block_Decl (Blk : Iir) is - Info : Block_Info_Acc; + Info : constant Block_Info_Acc := Get_Info (Blk); begin - Info := Get_Info (Blk); - New_Uncomplete_Record_Type (Info.Block_Decls_Type); - New_Type_Decl (Create_Identifier ("INSTTYPE"), Info.Block_Decls_Type); - Info.Block_Decls_Ptr_Type := New_Access_Type (Info.Block_Decls_Type); - New_Type_Decl (Create_Identifier ("INSTPTR"), - Info.Block_Decls_Ptr_Type); + Chap2.Declare_Inst_Type_And_Ptr + (Info.Block_Scope'Access, Info.Block_Decls_Ptr_Type); end Start_Block_Decl; procedure Translate_Entity_Init (Entity : Iir) @@ -3913,7 +4017,7 @@ package body Translation is begin Info := Add_Info (Entity, Kind_Block); Chap1.Start_Block_Decl (Entity); - Push_Instance_Factory (Info.Block_Decls_Type); + Push_Instance_Factory (Info.Block_Scope'Access); -- Entity link (RTI and pointer to parent). Info.Block_Link_Field := Add_Instance_Factory_Field @@ -3925,9 +4029,9 @@ package body Translation is Chap9.Translate_Block_Declarations (Entity, Entity); - Pop_Instance_Factory (Info.Block_Decls_Type); + Pop_Instance_Factory (Info.Block_Scope'Access); - Chap2.Push_Subprg_Instance (Info.Block_Decls_Type, + Chap2.Push_Subprg_Instance (Info.Block_Scope'Access, Info.Block_Decls_Ptr_Type, Wki_Instance, Prev_Subprg_Instance); @@ -3950,7 +4054,7 @@ package body Translation is if Global_Storage = O_Storage_External then -- Entity declaration subprograms. - Chap4.Translate_Declaration_Chain_Subprograms (Entity, Entity); + Chap4.Translate_Declaration_Chain_Subprograms (Entity); else -- Entity declaration and process subprograms. Chap9.Translate_Block_Subprograms (Entity, Entity); @@ -4001,39 +4105,32 @@ package body Translation is -- entity via the entity field of the instance. procedure Push_Architecture_Scope (Arch : Iir; Instance : O_Dnode) is - Arch_Info : Block_Info_Acc; - Entity : Iir; - Entity_Info : Block_Info_Acc; + Arch_Info : constant Block_Info_Acc := Get_Info (Arch); + Entity : constant Iir := Get_Entity (Arch); + Entity_Info : constant Block_Info_Acc := Get_Info (Entity); begin - Arch_Info := Get_Info (Arch); - Entity := Get_Entity (Arch); - Entity_Info := Get_Info (Entity); - - Push_Scope (Arch_Info.Block_Decls_Type, Instance); - Push_Scope (Entity_Info.Block_Decls_Type, - Arch_Info.Block_Parent_Field, Arch_Info.Block_Decls_Type); + Set_Scope_Via_Param_Ptr (Arch_Info.Block_Scope, Instance); + Set_Scope_Via_Field (Entity_Info.Block_Scope, + Arch_Info.Block_Parent_Field, + Arch_Info.Block_Scope'Access); end Push_Architecture_Scope; -- Pop scopes created by Push_Architecture_Scope. procedure Pop_Architecture_Scope (Arch : Iir) is - Arch_Info : Block_Info_Acc; - Entity : Iir; - Entity_Info : Block_Info_Acc; + Arch_Info : constant Block_Info_Acc := Get_Info (Arch); + Entity : constant Iir := Get_Entity (Arch); + Entity_Info : constant Block_Info_Acc := Get_Info (Entity); begin - Arch_Info := Get_Info (Arch); - Entity := Get_Entity (Arch); - Entity_Info := Get_Info (Entity); - - Pop_Scope (Entity_Info.Block_Decls_Type); - Pop_Scope (Arch_Info.Block_Decls_Type); + Clear_Scope (Entity_Info.Block_Scope); + Clear_Scope (Arch_Info.Block_Scope); end Pop_Architecture_Scope; procedure Translate_Architecture_Body (Arch : Iir) is + Entity : constant Iir := Get_Entity (Arch); + Entity_Info : constant Block_Info_Acc := Get_Info (Entity); Info : Block_Info_Acc; - Entity : Iir; - Entity_Info : Block_Info_Acc; Interface_List : O_Inter_List; Constr : O_Assoc_List; Instance : O_Dnode; @@ -4046,16 +4143,17 @@ package body Translation is Info := Add_Info (Arch, Kind_Block); Start_Block_Decl (Arch); - Push_Instance_Factory (Info.Block_Decls_Type); + Push_Instance_Factory (Info.Block_Scope'Access); - Entity := Get_Entity (Arch); - Entity_Info := Get_Info (Entity); + -- We cannot use Add_Scope_Field here, because the entity is not a + -- child scope of the architecture. Info.Block_Parent_Field := Add_Instance_Factory_Field - (Get_Identifier ("ENTITY"), Entity_Info.Block_Decls_Type); + (Get_Identifier ("ENTITY"), + Get_Scope_Type (Entity_Info.Block_Scope)); Chap9.Translate_Block_Declarations (Arch, Arch); - Pop_Instance_Factory (Info.Block_Decls_Type); + Pop_Instance_Factory (Info.Block_Scope'Access); -- Declare the constant containing the size of the instance. New_Const_Decl @@ -4064,8 +4162,7 @@ package body Translation is if Global_Storage /= O_Storage_External then Start_Const_Value (Info.Block_Instance_Size); Finish_Const_Value - (Info.Block_Instance_Size, - New_Sizeof (Info.Block_Decls_Type, Ghdl_Index_Type)); + (Info.Block_Instance_Size, Get_Scope_Size (Info.Block_Scope)); end if; -- Elaborator. @@ -4085,17 +4182,18 @@ package body Translation is return; end if; - Chap2.Push_Subprg_Instance (Info.Block_Decls_Type, + -- Create process subprograms. + Chap2.Push_Subprg_Instance (Info.Block_Scope'Access, Info.Block_Decls_Ptr_Type, Wki_Instance, Prev_Subprg_Instance); + Set_Scope_Via_Field (Entity_Info.Block_Scope, + Info.Block_Parent_Field, + Info.Block_Scope'Access); - -- Create process subprograms. - Push_Scope (Entity_Info.Block_Decls_Type, - Info.Block_Parent_Field, Info.Block_Decls_Type); Chap9.Translate_Block_Subprograms (Arch, Arch); - Pop_Scope (Entity_Info.Block_Decls_Type); + Clear_Scope (Entity_Info.Block_Scope); Chap2.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance); -- Elaborator body. @@ -4223,10 +4321,10 @@ package body Translation is if Get_Kind (Base_Block) = Iir_Kind_Architecture_Body then Push_Architecture_Scope (Base_Block, Base_Instance); else - Push_Scope (Base_Info.Block_Decls_Type, Base_Instance); + Set_Scope_Via_Param_Ptr (Base_Info.Block_Scope, Base_Instance); end if; - Push_Scope (Comp_Info.Comp_Type, Instance); + Set_Scope_Via_Param_Ptr (Comp_Info.Comp_Scope, Instance); if Conf_Info /= null then Clear_Info (Cfg); @@ -4239,12 +4337,12 @@ package body Translation is Set_Info (Cfg, Info); end if; - Pop_Scope (Comp_Info.Comp_Type); + Clear_Scope (Comp_Info.Comp_Scope); if Get_Kind (Base_Block) = Iir_Kind_Architecture_Body then Pop_Architecture_Scope (Base_Block); else - Pop_Scope (Base_Info.Block_Decls_Type); + Clear_Scope (Base_Info.Block_Scope); end if; Pop_Local_Factory; @@ -4255,7 +4353,9 @@ package body Translation is -- Create subprogram specifications for each configuration_specification -- in BLOCK_CONFIG and its sub-blocks. - -- ARCH is the architecture being configured. + -- BLOCK is the block being configured (initially the architecture), + -- BASE_BLOCK is the root block giving the instance (initially the + -- architecture) -- NUM is an integer used to generate uniq names. procedure Translate_Block_Configuration_Decls (Block_Config : Iir_Block_Configuration; @@ -4264,10 +4364,6 @@ package body Translation is Num : in out Iir_Int32) is El : Iir; - Mark : Id_Mark_Type; - Blk : Iir; - Block_Info : constant Block_Info_Acc := Get_Info (Block); - Blk_Info : Block_Info_Acc; begin El := Get_Configuration_Item_Chain (Block_Config); while El /= Null_Iir loop @@ -4277,31 +4373,33 @@ package body Translation is Translate_Component_Configuration_Decl (El, Block, Base_Block, Num); when Iir_Kind_Block_Configuration => - Blk := Get_Block_From_Block_Specification - (Get_Block_Specification (El)); - Push_Identifier_Prefix (Mark, Get_Identifier (Blk)); - Blk_Info := Get_Info (Blk); - case Get_Kind (Blk) is - when Iir_Kind_Generate_Statement => - Push_Scope_Via_Field_Ptr - (Block_Info.Block_Decls_Type, - Blk_Info.Block_Origin_Field, - Blk_Info.Block_Decls_Type); - Translate_Block_Configuration_Decls - (El, Blk, Blk, Num); - Pop_Scope (Block_Info.Block_Decls_Type); - when Iir_Kind_Block_Statement => - Push_Scope (Blk_Info.Block_Decls_Type, - Blk_Info.Block_Parent_Field, - Block_Info.Block_Decls_Type); - Translate_Block_Configuration_Decls - (El, Blk, Base_Block, Num); - Pop_Scope (Blk_Info.Block_Decls_Type); - when others => - Error_Kind - ("translate_block_configuration_decls(2)", Blk); - end case; - Pop_Identifier_Prefix (Mark); + declare + Mark : Id_Mark_Type; + Base_Info : constant Block_Info_Acc := + Get_Info (Base_Block); + Blk : constant Iir := Get_Block_From_Block_Specification + (Get_Block_Specification (El)); + Blk_Info : constant Block_Info_Acc := Get_Info (Blk); + begin + Push_Identifier_Prefix (Mark, Get_Identifier (Blk)); + case Get_Kind (Blk) is + when Iir_Kind_Generate_Statement => + Set_Scope_Via_Field_Ptr + (Base_Info.Block_Scope, + Blk_Info.Block_Origin_Field, + Blk_Info.Block_Scope'Access); + Translate_Block_Configuration_Decls + (El, Blk, Blk, Num); + Clear_Scope (Base_Info.Block_Scope); + when Iir_Kind_Block_Statement => + Translate_Block_Configuration_Decls + (El, Blk, Base_Block, Num); + when others => + Error_Kind + ("translate_block_configuration_decls(2)", Blk); + end case; + Pop_Identifier_Prefix (Mark); + end; when others => Error_Kind ("translate_block_configuration_decls(1)", El); end case; @@ -4346,11 +4444,11 @@ package body Translation is -- The component is really a component and not a -- direct instance. Start_Association (Assoc, Cfg_Info.Config_Subprg); - V := Get_Instance_Ref (Block_Info.Block_Decls_Type); + V := Get_Instance_Ref (Block_Info.Block_Scope); V := New_Selected_Element (V, Info.Block_Link_Field); New_Association (Assoc, New_Address (V, Comp_Info.Comp_Ptr_Type)); - V := Get_Instance_Ref (Base_Info.Block_Decls_Type); + V := Get_Instance_Ref (Base_Info.Block_Scope); New_Association (Assoc, New_Address (V, Base_Info.Block_Decls_Ptr_Type)); @@ -4366,16 +4464,19 @@ package body Translation is procedure Translate_Block_Configuration_Calls (Block_Config : Iir_Block_Configuration; Base_Block : Iir; - Info : Block_Info_Acc); + Base_Info : Block_Info_Acc); procedure Translate_Generate_Block_Configuration_Calls (Block_Config : Iir_Block_Configuration; Parent_Info : Block_Info_Acc) is - Spec : Iir; - Block : Iir_Generate_Statement; - Scheme : Iir; - Info : Block_Info_Acc; + Spec : constant Iir := Get_Block_Specification (Block_Config); + Block : constant Iir := Get_Block_From_Block_Specification (Spec); + Info : constant Block_Info_Acc := Get_Info (Block); + Scheme : constant Iir := Get_Generation_Scheme (Block); + + Type_Info : Type_Info_Acc; + Iter_Type : Iir; -- Generate a call for a iterative generate block whose index is -- INDEX. @@ -4393,7 +4494,7 @@ package body Translation is New_Address (New_Indexed_Element (New_Acc_Value (New_Selected_Element - (Get_Instance_Ref (Parent_Info.Block_Decls_Type), + (Get_Instance_Ref (Parent_Info.Block_Scope), Info.Block_Parent_Field)), Index), Info.Block_Decls_Ptr_Type)); @@ -4411,14 +4512,9 @@ package body Translation is (New_Selected_Acc_Value (New_Obj (Var_Inst), Info.Block_Configured_Field), New_Lit (Ghdl_Bool_True_Node)); - Push_Scope (Info.Block_Decls_Type, Var_Inst); - Push_Scope_Via_Field_Ptr - (Parent_Info.Block_Decls_Type, - Info.Block_Origin_Field, - Info.Block_Decls_Type); + Set_Scope_Via_Param_Ptr (Info.Block_Scope, Var_Inst); Translate_Block_Configuration_Calls (Block_Config, Block, Info); - Pop_Scope (Parent_Info.Block_Decls_Type); - Pop_Scope (Info.Block_Decls_Type); + Clear_Scope (Info.Block_Scope); if Fails then New_Else_Stmt (If_Blk); @@ -4431,65 +4527,60 @@ package body Translation is Close_Temp; end Gen_Subblock_Call; - Type_Info : Type_Info_Acc; - Iter_Type : Iir; + procedure Apply_To_All_Others_Blocks (Is_All : Boolean) + is + Var_I : O_Dnode; + Label : O_Snode; + begin + Start_Declare_Stmt; + New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); + Init_Var (Var_I); + Start_Loop_Stmt (Label); + Gen_Exit_When + (Label, + New_Compare_Op + (ON_Eq, + New_Value (New_Obj (Var_I)), + New_Value + (New_Selected_Element + (Get_Var (Get_Info (Iter_Type).T.Range_Var), + Type_Info.T.Range_Length)), + Ghdl_Bool_Type)); + -- Selected_name is for default configurations, so + -- program should not fail if a block is already + -- configured but continue silently. + Gen_Subblock_Call (New_Value (New_Obj (Var_I)), Is_All); + Inc_Var (Var_I); + Finish_Loop_Stmt (Label); + Finish_Declare_Stmt; + end Apply_To_All_Others_Blocks; begin - Spec := Get_Block_Specification (Block_Config); - Block := Get_Block_From_Block_Specification (Spec); - Info := Get_Info (Block); - Scheme := Get_Generation_Scheme (Block); if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then Iter_Type := Get_Type (Scheme); Type_Info := Get_Info (Get_Base_Type (Iter_Type)); case Get_Kind (Spec) is when Iir_Kind_Generate_Statement - | Iir_Kind_Simple_Name - | Iir_Kind_Selected_Name => - -- Apply for all/remaining blocks. - declare - Var_I : O_Dnode; - Label : O_Snode; - begin - Start_Declare_Stmt; - New_Var_Decl (Var_I, Wki_I, O_Storage_Local, - Ghdl_Index_Type); - Init_Var (Var_I); - Start_Loop_Stmt (Label); - Gen_Exit_When - (Label, - New_Compare_Op - (ON_Eq, - New_Value (New_Obj (Var_I)), - New_Value - (New_Selected_Element - (Get_Var (Get_Info (Iter_Type).T.Range_Var), - Type_Info.T.Range_Length)), - Ghdl_Bool_Type)); - -- Selected_name is for default configurations, so - -- program should not fail if a block is already - -- configured but continue silently. - Gen_Subblock_Call - (New_Value (New_Obj (Var_I)), - Get_Kind (Spec) /= Iir_Kind_Selected_Name); - Inc_Var (Var_I); - Finish_Loop_Stmt (Label); - Finish_Declare_Stmt; - end; + | Iir_Kind_Simple_Name => + Apply_To_All_Others_Blocks (True); when Iir_Kind_Indexed_Name => declare + Index_List : constant Iir_List := Get_Index_List (Spec); Rng : Mnode; begin - Open_Temp; - Rng := Stabilize (Chap3.Type_To_Range (Iter_Type)); - Gen_Subblock_Call - (Chap6.Translate_Index_To_Offset - (Rng, - Chap7.Translate_Expression - (Get_Nth_Element (Get_Index_List (Spec), 0), - Iter_Type), - Scheme, Iter_Type, Spec), - True); - Close_Temp; + if Index_List = Iir_List_Others then + Apply_To_All_Others_Blocks (False); + else + Open_Temp; + Rng := Stabilize (Chap3.Type_To_Range (Iter_Type)); + Gen_Subblock_Call + (Chap6.Translate_Index_To_Offset + (Rng, + Chap7.Translate_Expression + (Get_Nth_Element (Index_List, 0), Iter_Type), + Scheme, Iter_Type, Spec), + True); + Close_Temp; + end if; end; when Iir_Kind_Slice_Name => declare @@ -4577,7 +4668,7 @@ package body Translation is Var := Create_Temp_Init (Info.Block_Decls_Ptr_Type, New_Value (New_Selected_Element - (Get_Instance_Ref (Parent_Info.Block_Decls_Type), + (Get_Instance_Ref (Parent_Info.Block_Scope), Info.Block_Parent_Field))); Start_If_Stmt (If_Blk, @@ -4586,13 +4677,9 @@ package body Translation is New_Obj_Value (Var), New_Lit (New_Null_Access (Info.Block_Decls_Ptr_Type)), Ghdl_Bool_Type)); - Push_Scope (Info.Block_Decls_Type, Var); - Push_Scope_Via_Field_Ptr (Parent_Info.Block_Decls_Type, - Info.Block_Origin_Field, - Info.Block_Decls_Type); + Set_Scope_Via_Param_Ptr (Info.Block_Scope, Var); Translate_Block_Configuration_Calls (Block_Config, Block, Info); - Pop_Scope (Parent_Info.Block_Decls_Type); - Pop_Scope (Info.Block_Decls_Type); + Clear_Scope (Info.Block_Scope); Finish_If_Stmt (If_Blk); Close_Temp; end; @@ -4602,7 +4689,7 @@ package body Translation is procedure Translate_Block_Configuration_Calls (Block_Config : Iir_Block_Configuration; Base_Block : Iir; - Info : Block_Info_Acc) + Base_Info : Block_Info_Acc) is El : Iir; begin @@ -4612,27 +4699,18 @@ package body Translation is when Iir_Kind_Component_Configuration | Iir_Kind_Configuration_Specification => Translate_Component_Configuration_Call - (El, Base_Block, Info); + (El, Base_Block, Base_Info); when Iir_Kind_Block_Configuration => declare - Block : Iir; - Block_Info : Block_Info_Acc; + Block : constant Iir := Strip_Denoting_Name + (Get_Block_Specification (El)); begin - Block := Get_Block_Specification (El); - if Get_Kind (Block) = Iir_Kind_Simple_Name then - Block := Get_Named_Entity (Block); - end if; if Get_Kind (Block) = Iir_Kind_Block_Statement then - Block_Info := Get_Info (Block); - Push_Scope (Block_Info.Block_Decls_Type, - Block_Info.Block_Parent_Field, - Info.Block_Decls_Type); Translate_Block_Configuration_Calls - (El, Base_Block, Block_Info); - Pop_Scope (Block_Info.Block_Decls_Type); + (El, Base_Block, Get_Info (Block)); else Translate_Generate_Block_Configuration_Calls - (El, Info); + (El, Base_Info); end if; end; when others => @@ -4644,10 +4722,12 @@ package body Translation is procedure Translate_Configuration_Declaration (Config : Iir) is + Block_Config : constant Iir_Block_Configuration := + Get_Block_Configuration (Config); + Arch : constant Iir_Architecture_Body := + Get_Block_Specification (Block_Config); + Arch_Info : constant Block_Info_Acc := Get_Info (Arch); Interface_List : O_Inter_List; - Block_Config : Iir_Block_Configuration; - Arch : Iir_Architecture_Body; - Arch_Info : Block_Info_Acc; Config_Info : Config_Info_Acc; Instance : O_Dnode; Num : Iir_Int32; @@ -4658,9 +4738,6 @@ package body Translation is end if; Config_Info := Add_Info (Config, Kind_Config); - Block_Config := Get_Block_Configuration (Config); - Arch := Get_Block_Specification (Block_Config); - Arch_Info := Get_Info (Arch); -- Configurator. Start_Procedure_Decl @@ -5043,9 +5120,6 @@ package body Translation is Frame_Ptr_Type : O_Tnode; Upframe_Field : O_Fnode; - -- Field in the frame for a pointer to the RESULT structure. - Res_Field : O_Fnode := O_Fnode_Null; - Frame : O_Dnode; Frame_Ptr : O_Dnode; @@ -5075,12 +5149,13 @@ package body Translation is if Has_Nested then -- Unnest subprograms. -- Create an instance for the local declarations. - Push_Instance_Factory (O_Tnode_Null); + Push_Instance_Factory (Info.Subprg_Frame_Scope'Access); Add_Subprg_Instance_Field (Upframe_Field); if Info.Res_Record_Ptr /= O_Tnode_Null then - Res_Field := Add_Instance_Factory_Field - (Get_Identifier ("RESULT"), Info.Res_Record_Ptr); + Info.Res_Record_Var := + Create_Var (Create_Var_Identifier ("RESULT"), + Info.Res_Record_Ptr); end if; -- Create fields for parameters. @@ -5104,34 +5179,26 @@ package body Translation is end; Chap4.Translate_Declaration_Chain (Subprg); - Pop_Instance_Factory (Info.Subprg_Frame_Type); + Pop_Instance_Factory (Info.Subprg_Frame_Scope'Access); New_Type_Decl (Create_Identifier ("_FRAMETYPE"), - Info.Subprg_Frame_Type); - Frame_Ptr_Type := New_Access_Type (Info.Subprg_Frame_Type); - New_Type_Decl (Create_Identifier ("_FRAMEPTR"), Frame_Ptr_Type); + Get_Scope_Type (Info.Subprg_Frame_Scope)); + Declare_Scope_Acc + (Info.Subprg_Frame_Scope, + Create_Identifier ("_FRAMEPTR"), Frame_Ptr_Type); Rtis.Generate_Subprogram_Body (Subprg); -- Local frame Chap2.Push_Subprg_Instance - (Info.Subprg_Frame_Type, Frame_Ptr_Type, + (Info.Subprg_Frame_Scope'Access, Frame_Ptr_Type, Wki_Upframe, Prev_Subprg_Instances); -- Link to previous frame Chap2.Start_Prev_Subprg_Instance_Use_Via_Field (Prev_Subprg_Instances, Upframe_Field); - -- Result record - if Info.Res_Record_Ptr /= O_Tnode_Null then - Chap10.Push_Scope_Via_Field_Ptr - (Info.Res_Record_Type, Res_Field, Info.Subprg_Frame_Type); - end if; - Chap4.Translate_Declaration_Chain_Subprograms (Subprg, Null_Iir); + Chap4.Translate_Declaration_Chain_Subprograms (Subprg); - -- Result - if Info.Res_Record_Ptr /= O_Tnode_Null then - Chap10.Pop_Scope (Info.Res_Record_Type); - end if; -- Link to previous frame Chap2.Finish_Prev_Subprg_Instance_Use_Via_Field (Prev_Subprg_Instances, Upframe_Field); @@ -5145,10 +5212,6 @@ package body Translation is Start_Subprg_Instance_Use (Spec); - if Info.Res_Record_Type /= O_Tnode_Null then - Push_Scope (Info.Res_Record_Type, Info.Res_Interface); - end if; - -- Variables will be created on the stack. Push_Local_Factory; @@ -5159,44 +5222,21 @@ package body Translation is -- There is a local scope for temporaries. Open_Local_Temp; - -- Init out parameters passed by value/copy. - declare - Inter : Iir; - Inter_Type : Iir; - Type_Info : Type_Info_Acc; - begin - Inter := Get_Interface_Declaration_Chain (Spec); - while Inter /= Null_Iir loop - if Get_Kind (Inter) = Iir_Kind_Variable_Interface_Declaration - and then Get_Mode (Inter) = Iir_Out_Mode - then - Inter_Type := Get_Type (Inter); - Type_Info := Get_Info (Inter_Type); - if (Type_Info.Type_Mode in Type_Mode_By_Value - or Type_Info.Type_Mode in Type_Mode_By_Copy) - and then Type_Info.Type_Mode /= Type_Mode_File - then - Chap4.Init_Object - (Chap6.Translate_Name (Inter), Inter_Type); - end if; - end if; - Inter := Get_Chain (Inter); - end loop; - end; - if not Has_Nested then Chap4.Translate_Declaration_Chain (Subprg); Rtis.Generate_Subprogram_Body (Subprg); - Chap4.Translate_Declaration_Chain_Subprograms (Subprg, Null_Iir); + Chap4.Translate_Declaration_Chain_Subprograms (Subprg); else New_Var_Decl (Frame, Wki_Frame, O_Storage_Local, - Info.Subprg_Frame_Type); - -- FIXME: Remove this pointer, get a direct access to the frame. + Get_Scope_Type (Info.Subprg_Frame_Scope)); + New_Var_Decl (Frame_Ptr, Get_Identifier ("FRAMEPTR"), O_Storage_Local, Frame_Ptr_Type); New_Assign_Stmt (New_Obj (Frame_Ptr), New_Address (New_Obj (Frame), Frame_Ptr_Type)); - Push_Scope (Info.Subprg_Frame_Type, Frame_Ptr); + + -- FIXME: use direct reference (ie Frame instead of Frame_Ptr) + Set_Scope_Via_Param_Ptr (Info.Subprg_Frame_Scope, Frame_Ptr); -- Set UPFRAME. Chap2.Set_Subprg_Instance_Field @@ -5204,12 +5244,15 @@ package body Translation is if Info.Res_Record_Type /= O_Tnode_Null then -- Initialize the RESULT field - New_Assign_Stmt (New_Selected_Element (New_Obj (Frame), - Res_Field), + New_Assign_Stmt (Get_Var (Info.Res_Record_Var), New_Obj_Value (Info.Res_Interface)); + -- Do not reference the RESULT field in the subprogram body, + -- directly reference the RESULT parameter. + -- FIXME: has a flag (see below for parameters). + Info.Res_Record_Var := Null_Var; end if; - -- Copy parameter to FRAME. + -- Copy parameters to FRAME. declare Inter : Iir; Inter_Info : Inter_Info_Acc; @@ -5233,6 +5276,31 @@ package body Translation is end; end if; + -- Init out parameters passed by value/copy. + declare + Inter : Iir; + Inter_Type : Iir; + Type_Info : Type_Info_Acc; + begin + Inter := Get_Interface_Declaration_Chain (Spec); + while Inter /= Null_Iir loop + if Get_Kind (Inter) = Iir_Kind_Variable_Interface_Declaration + and then Get_Mode (Inter) = Iir_Out_Mode + then + Inter_Type := Get_Type (Inter); + Type_Info := Get_Info (Inter_Type); + if (Type_Info.Type_Mode in Type_Mode_By_Value + or Type_Info.Type_Mode in Type_Mode_By_Copy) + and then Type_Info.Type_Mode /= Type_Mode_File + then + Chap4.Init_Object + (Chap6.Translate_Name (Inter), Inter_Type); + end if; + end if; + Inter := Get_Chain (Inter); + end loop; + end; + Chap4.Elab_Declaration_Chain (Subprg, Final); -- If finalization is required, create a dummy loop around the @@ -5295,17 +5363,13 @@ package body Translation is end if; if Has_Nested then - Pop_Scope (Info.Subprg_Frame_Type); + Clear_Scope (Info.Subprg_Frame_Scope); end if; Chap2.Pop_Subprg_Instance (O_Ident_Nul, Prev_Subprg_Instances); Close_Local_Temp; Pop_Local_Factory; - if Info.Res_Record_Type /= O_Tnode_Null then - Pop_Scope (Info.Res_Record_Type); - end if; - Finish_Subprg_Instance_Use (Spec); Finish_Subprogram_Body; @@ -5313,230 +5377,208 @@ package body Translation is Pop_Identifier_Prefix (Mark); end Translate_Subprogram_Body; --- procedure Translate_Protected_Subprogram_Declaration --- (Def : Iir_Protected_Type_Declaration; Spec : Iir; Block : Iir) --- is --- Interface_List : O_Inter_List; --- Info : Subprg_Info_Acc; --- Tinfo : Type_Info_Acc; --- Inter : Iir; --- Inter_Info : Inter_Info_Acc; --- Prot_Subprg : O_Dnode; --- Prot_Obj : O_Lnode; --- Mark : Id_Mark_Type; --- Constr : O_Assoc_List; --- Inst_Data : Instance_Data; --- Is_Func : Boolean; --- Var_Res : O_Lnode; --- begin --- Chap2.Translate_Subprogram_Declaration (Spec, Block); - --- -- Create protected subprogram --- Info := Get_Info (Spec); --- Push_Subprg_Identifier (Spec, Info, Mark); - --- Is_Func := Is_Subprogram_Ortho_Function (Spec); - --- if Is_Func then --- Tinfo := Get_Info (Get_Return_Type (Spec)); --- Start_Function_Decl (Interface_List, --- Create_Identifier ("PROT"), --- Global_Storage, --- Tinfo.Ortho_Type (Mode_Value)); --- else --- Start_Procedure_Decl (Interface_List, --- Create_Identifier ("PROT"), --- Global_Storage); --- end if; --- Chap2.Create_Subprg_Instance (Interface_List, Inst_Data, Block); - --- -- FIXME: RES record interface. - --- New_Interface_Decl --- (Interface_List, --- Prot_Obj, --- Get_Identifier ("OBJ"), --- Get_Info (Def).Ortho_Ptr_Type (Mode_Value)); - --- Inter := Get_Interface_Declaration_Chain (Spec); --- while Inter /= Null_Iir loop --- Inter_Info := Get_Info (Inter); --- if Inter_Info.Interface_Type /= O_Tnode_Null then --- New_Interface_Decl --- (Interface_List, Inter_Info.Interface_Protected, --- Create_Identifier_Without_Prefix (Inter), --- Inter_Info.Interface_Type); --- end if; --- Inter := Get_Chain (Inter); --- end loop; --- Finish_Subprogram_Decl (Interface_List, Prot_Subprg); - --- if Global_Storage /= O_Storage_External then --- -- Body of the protected subprogram. --- Start_Subprogram_Body (Prot_Subprg); --- Start_Subprg_Instance_Use (Inst_Data); - --- if Is_Func then --- New_Var_Decl (Var_Res, Wki_Res, O_Storage_Local, --- Tinfo.Ortho_Type (Mode_Value)); --- end if; - --- -- Lock the object. --- Start_Association (Constr, Ghdl_Protected_Enter); --- New_Association --- (Constr, New_Convert_Ov (New_Value (Prot_Obj), Ghdl_Ptr_Type)); --- New_Procedure_Call (Constr); - --- -- Call the unprotected method --- Start_Association (Constr, Info.Ortho_Func); --- Add_Subprg_Instance_Assoc (Constr, Inst_Data); --- New_Association (Constr, New_Value (Prot_Obj)); --- Inter := Get_Interface_Declaration_Chain (Spec); --- while Inter /= Null_Iir loop --- Inter_Info := Get_Info (Inter); --- if Inter_Info.Interface_Type /= O_Tnode_Null then --- New_Association --- (Constr, New_Value (Inter_Info.Interface_Protected)); --- end if; --- Inter := Get_Chain (Inter); --- end loop; --- if Is_Func then --- New_Assign_Stmt (Var_Res, New_Function_Call (Constr)); --- else --- New_Procedure_Call (Constr); --- end if; - --- -- Unlock the object. --- Start_Association (Constr, Ghdl_Protected_Leave); --- New_Association --- (Constr, New_Convert_Ov (New_Value (Prot_Obj), Ghdl_Ptr_Type)); --- New_Procedure_Call (Constr); - --- if Is_Func then --- New_Return_Stmt (New_Value (Var_Res)); --- end if; --- Finish_Subprg_Instance_Use (Inst_Data); --- Finish_Subprogram_Body; --- end if; - --- Pop_Identifier_Prefix (Mark); --- end Translate_Protected_Subprogram_Declaration; - procedure Translate_Package_Declaration (Decl : Iir_Package_Declaration) is + Header : constant Iir := Get_Package_Header (Decl); Info : Ortho_Info_Acc; - I_List : O_Inter_List; - --Storage : O_Storage; - begin - Chap4.Translate_Declaration_Chain (Decl); - Chap4.Translate_Declaration_Chain_Subprograms (Decl, Null_Iir); - --- if Chap10.Global_Storage = O_Storage_Public --- and then not Get_Need_Body (Decl) --- then --- Storage := O_Storage_Public; --- else --- Storage := O_Storage_External; --- end if; - + Interface_List : O_Inter_List; + Prev_Subprg_Instance : Chap2.Subprg_Instance_Stack; + begin Info := Add_Info (Decl, Kind_Package); - Start_Procedure_Decl - (I_List, Create_Identifier ("ELAB_SPEC"), Global_Storage); - Finish_Subprogram_Decl (I_List, Info.Package_Elab_Spec_Subprg); + -- Translate declarations. + if Is_Uninstantiated_Package (Decl) then + -- Create an instance for the spec. + Push_Instance_Factory (Info.Package_Spec_Scope'Access); + Chap4.Translate_Generic_Chain (Header); + Chap4.Translate_Declaration_Chain (Decl); + Info.Package_Elab_Var := Create_Var + (Create_Var_Identifier ("ELABORATED"), Ghdl_Bool_Type); + Pop_Instance_Factory (Info.Package_Spec_Scope'Access); + + -- Name the spec instance and create a pointer. + New_Type_Decl (Create_Identifier ("SPECINSTTYPE"), + Get_Scope_Type (Info.Package_Spec_Scope)); + Declare_Scope_Acc (Info.Package_Spec_Scope, + Create_Identifier ("SPECINSTPTR"), + Info.Package_Spec_Ptr_Type); + + -- Create an instance and its pointer for the body. + Chap2.Declare_Inst_Type_And_Ptr + (Info.Package_Body_Scope'Access, Info.Package_Body_Ptr_Type); + + -- Each subprogram has a body instance argument. + Chap2.Push_Subprg_Instance + (Info.Package_Body_Scope'Access, Info.Package_Body_Ptr_Type, + Wki_Instance, Prev_Subprg_Instance); + else + Chap4.Translate_Declaration_Chain (Decl); + Info.Package_Elab_Var := Create_Var + (Create_Var_Identifier ("ELABORATED"), Ghdl_Bool_Type); + end if; + -- Translate subprograms declarations. + Chap4.Translate_Declaration_Chain_Subprograms (Decl); + + -- Declare elaborator for the body. Start_Procedure_Decl - (I_List, Create_Identifier ("ELAB_BODY"), Global_Storage); - Finish_Subprogram_Decl (I_List, Info.Package_Elab_Body_Subprg); + (Interface_List, Create_Identifier ("ELAB_BODY"), Global_Storage); + Chap2.Add_Subprg_Instance_Interfaces + (Interface_List, Info.Package_Elab_Body_Instance); + Finish_Subprogram_Decl + (Interface_List, Info.Package_Elab_Body_Subprg); + + if Is_Uninstantiated_Package (Decl) then + Chap2.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance); - New_Var_Decl (Info.Package_Elab_Var, Create_Identifier ("ELABORATED"), - Chap10.Global_Storage, Ghdl_Bool_Type); + -- The spec elaborator has a spec instance argument. + Chap2.Push_Subprg_Instance + (Info.Package_Spec_Scope'Access, Info.Package_Spec_Ptr_Type, + Wki_Instance, Prev_Subprg_Instance); + end if; + + Start_Procedure_Decl + (Interface_List, Create_Identifier ("ELAB_SPEC"), Global_Storage); + Chap2.Add_Subprg_Instance_Interfaces + (Interface_List, Info.Package_Elab_Spec_Instance); + Finish_Subprogram_Decl + (Interface_List, Info.Package_Elab_Spec_Subprg); if Flag_Rti then + -- Generate RTI. Rtis.Generate_Unit (Decl); end if; if Global_Storage = O_Storage_Public then - -- Generate RTI. + -- Create elaboration procedure for the spec Elab_Package (Decl); end if; + + if Is_Uninstantiated_Package (Decl) then + Chap2.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance); + end if; Save_Local_Identifier (Info.Package_Local_Id); end Translate_Package_Declaration; procedure Translate_Package_Body (Decl : Iir_Package_Body) is - Pkg : Iir_Package_Declaration; + Spec : constant Iir_Package_Declaration := Get_Package (Decl); + Info : constant Ortho_Info_Acc := Get_Info (Spec); + Prev_Subprg_Instance : Chap2.Subprg_Instance_Stack; begin - -- May be called during elaboration to generate RTI. - if Global_Storage = O_Storage_External then - return; - end if; + -- Translate declarations. + if Is_Uninstantiated_Package (Spec) then + Push_Instance_Factory (Info.Package_Body_Scope'Access); + Info.Package_Spec_Field := Add_Instance_Factory_Field + (Get_Identifier ("SPEC"), + Get_Scope_Type (Info.Package_Spec_Scope)); - Pkg := Get_Package (Decl); - Restore_Local_Identifier (Get_Info (Pkg).Package_Local_Id); - Chap4.Translate_Declaration_Chain (Decl); + Chap4.Translate_Declaration_Chain (Decl); + + Pop_Instance_Factory (Info.Package_Body_Scope'Access); + + if Global_Storage = O_Storage_External then + return; + end if; + else + -- May be called during elaboration to generate RTI. + if Global_Storage = O_Storage_External then + return; + end if; + + Restore_Local_Identifier (Get_Info (Spec).Package_Local_Id); + + Chap4.Translate_Declaration_Chain (Decl); + end if; if Flag_Rti then Rtis.Generate_Unit (Decl); end if; - Chap4.Translate_Declaration_Chain_Subprograms (Decl, Null_Iir); + if Is_Uninstantiated_Package (Spec) then + Chap2.Push_Subprg_Instance + (Info.Package_Body_Scope'Access, Info.Package_Body_Ptr_Type, + Wki_Instance, Prev_Subprg_Instance); + Set_Scope_Via_Field (Info.Package_Spec_Scope, + Info.Package_Spec_Field, + Info.Package_Body_Scope'Access); + end if; - Elab_Package_Body (Pkg, Decl); + Chap4.Translate_Declaration_Chain_Subprograms (Decl); + + if Is_Uninstantiated_Package (Spec) then + Clear_Scope (Info.Package_Spec_Scope); + Chap2.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance); + end if; + + Elab_Package_Body (Spec, Decl); end Translate_Package_Body; procedure Elab_Package (Spec : Iir_Package_Declaration) is - Info : Ortho_Info_Acc; + Info : constant Ortho_Info_Acc := Get_Info (Spec); Final : Boolean; Constr : O_Assoc_List; pragma Unreferenced (Final); begin - Info := Get_Info (Spec); Start_Subprogram_Body (Info.Package_Elab_Spec_Subprg); Push_Local_Factory; + Chap2.Start_Subprg_Instance_Use (Info.Package_Elab_Spec_Instance); Elab_Dependence (Get_Design_Unit (Spec)); - -- Register the package. This is done dynamically, as we know only - -- during elaboration that the design depends on a package (a package - -- maybe referenced by an entity which is never map due to generate - -- statements). - Start_Association (Constr, Ghdl_Rti_Add_Package); - New_Association - (Constr, New_Lit (Rtis.New_Rti_Address (Info.Package_Rti_Const))); - New_Procedure_Call (Constr); + if not Is_Uninstantiated_Package (Spec) + and then Get_Kind (Get_Parent (Spec)) = Iir_Kind_Design_Unit + then + -- Register the top level package. This is done dynamically, as + -- we know only during elaboration that the design depends on a + -- package (a package maybe referenced by an entity which is never + -- instantiated due to generate statements). + Start_Association (Constr, Ghdl_Rti_Add_Package); + New_Association + (Constr, + New_Lit (Rtis.New_Rti_Address (Info.Package_Rti_Const))); + New_Procedure_Call (Constr); + end if; Open_Temp; Chap4.Elab_Declaration_Chain (Spec, Final); Close_Temp; + Chap2.Finish_Subprg_Instance_Use (Info.Package_Elab_Spec_Instance); Pop_Local_Factory; Finish_Subprogram_Body; end Elab_Package; procedure Elab_Package_Body (Spec : Iir_Package_Declaration; Bod : Iir) is - Info : Ortho_Info_Acc; + Info : constant Ortho_Info_Acc := Get_Info (Spec); If_Blk : O_If_Block; Constr : O_Assoc_List; Final : Boolean; begin - Info := Get_Info (Spec); Start_Subprogram_Body (Info.Package_Elab_Body_Subprg); Push_Local_Factory; + Chap2.Start_Subprg_Instance_Use (Info.Package_Elab_Body_Instance); + + if Is_Uninstantiated_Package (Spec) then + Set_Scope_Via_Field (Info.Package_Spec_Scope, + Info.Package_Spec_Field, + Info.Package_Body_Scope'Access); + end if; -- If the package was already elaborated, return now, -- else mark the package as elaborated. - Start_If_Stmt (If_Blk, New_Obj_Value (Info.Package_Elab_Var)); + Start_If_Stmt (If_Blk, New_Value (Get_Var (Info.Package_Elab_Var))); New_Return_Stmt; New_Else_Stmt (If_Blk); - New_Assign_Stmt (New_Obj (Info.Package_Elab_Var), + New_Assign_Stmt (Get_Var (Info.Package_Elab_Var), New_Lit (Ghdl_Bool_True_Node)); Finish_If_Stmt (If_Blk); -- Elab Spec. Start_Association (Constr, Info.Package_Elab_Spec_Subprg); + Add_Subprg_Instance_Assoc (Constr, Info.Package_Elab_Spec_Instance); New_Procedure_Call (Constr); if Bod /= Null_Iir then @@ -5546,18 +5588,113 @@ package body Translation is Close_Temp; end if; + if Is_Uninstantiated_Package (Spec) then + Clear_Scope (Info.Package_Spec_Scope); + end if; + + Chap2.Finish_Subprg_Instance_Use (Info.Package_Elab_Body_Instance); Pop_Local_Factory; Finish_Subprogram_Body; end Elab_Package_Body; + procedure Translate_Package_Instantiation_Declaration (Inst : Iir) + is + Spec : constant Iir := + Get_Named_Entity (Get_Uninstantiated_Name (Inst)); + Pkg_Info : constant Ortho_Info_Acc := Get_Info (Spec); + Info : Ortho_Info_Acc; + Interface_List : O_Inter_List; + Constr : O_Assoc_List; + begin + Info := Add_Info (Inst, Kind_Package_Instance); + + -- FIXME: if the instantiation occurs within a package declaration, + -- the variable must be declared extern (and public in the body). + Info.Package_Instance_Var := Create_Var + (Create_Var_Identifier (Inst), + Get_Scope_Type (Pkg_Info.Package_Body_Scope)); + + -- FIXME: this is correct only for global instantiation, and only if + -- there is only one. + Set_Scope_Via_Decl (Pkg_Info.Package_Body_Scope, + Get_Var_Label (Info.Package_Instance_Var)); + Set_Scope_Via_Field (Pkg_Info.Package_Spec_Scope, + Pkg_Info.Package_Spec_Field, + Pkg_Info.Package_Body_Scope'Access); + + -- Declare elaboration procedure + Start_Procedure_Decl + (Interface_List, Create_Identifier ("ELAB"), Global_Storage); + -- Chap2.Add_Subprg_Instance_Interfaces + -- (Interface_List, Info.Package_Instance_Elab_Instance); + Finish_Subprogram_Decl + (Interface_List, Info.Package_Instance_Elab_Subprg); + + if Global_Storage /= O_Storage_Public then + return; + end if; + + -- Elaborator: + Start_Subprogram_Body (Info.Package_Instance_Elab_Subprg); + -- Chap2.Start_Subprg_Instance_Use + -- (Info.Package_Instance_Elab_Instance); + + Elab_Dependence (Get_Design_Unit (Inst)); + + Chap5.Elab_Generic_Map_Aspect (Inst); + + Start_Association (Constr, Pkg_Info.Package_Elab_Body_Subprg); + Add_Subprg_Instance_Assoc + (Constr, Pkg_Info.Package_Elab_Body_Instance); + New_Procedure_Call (Constr); + + -- Chap2.Finish_Subprg_Instance_Use + -- (Info.Package_Instance_Elab_Instance); + Finish_Subprogram_Body; + end Translate_Package_Instantiation_Declaration; + + procedure Elab_Dependence_Package (Pkg : Iir_Package_Declaration) + is + Info : Ortho_Info_Acc; + If_Blk : O_If_Block; + Constr : O_Assoc_List; + begin + -- Std.Standard is pre-elaborated. + if Pkg = Standard_Package then + return; + end if; + + -- Nothing to do for uninstantiated package. + if Is_Uninstantiated_Package (Pkg) then + return; + end if; + + -- Call the package elaborator only if not already elaborated. + Info := Get_Info (Pkg); + Start_If_Stmt + (If_Blk, + New_Monadic_Op (ON_Not, + New_Value (Get_Var (Info.Package_Elab_Var)))); + -- Elaborates only non-elaborated packages. + Start_Association (Constr, Info.Package_Elab_Body_Subprg); + New_Procedure_Call (Constr); + Finish_If_Stmt (If_Blk); + end Elab_Dependence_Package; + + procedure Elab_Dependence_Package_Instantiation (Pkg : Iir) + is + Info : constant Ortho_Info_Acc := Get_Info (Pkg); + Constr : O_Assoc_List; + begin + Start_Association (Constr, Info.Package_Instance_Elab_Subprg); + New_Procedure_Call (Constr); + end Elab_Dependence_Package_Instantiation; + procedure Elab_Dependence (Design_Unit: Iir_Design_Unit) is Depend_List: Iir_Design_Unit_List; Design: Iir; Library_Unit: Iir; - Info : Ortho_Info_Acc; - If_Blk : O_If_Block; - Constr : O_Assoc_List; begin Depend_List := Get_Dependence_List (Design_Unit); @@ -5568,17 +5705,9 @@ package body Translation is Library_Unit := Get_Library_Unit (Design); case Get_Kind (Library_Unit) is when Iir_Kind_Package_Declaration => - if Library_Unit /= Standard_Package then - Info := Get_Info (Library_Unit); - Start_If_Stmt - (If_Blk, New_Monadic_Op - (ON_Not, New_Obj_Value (Info.Package_Elab_Var))); - -- Elaborates only non-elaborated packages. - Start_Association (Constr, - Info.Package_Elab_Body_Subprg); - New_Procedure_Call (Constr); - Finish_If_Stmt (If_Blk); - end if; + Elab_Dependence_Package (Library_Unit); + when Iir_Kind_Package_Instantiation_Declaration => + Elab_Dependence_Package_Instantiation (Library_Unit); when Iir_Kind_Entity_Declaration => -- FIXME: architecture already elaborates its entity. null; @@ -5586,6 +5715,9 @@ package body Translation is null; when Iir_Kind_Architecture_Body => null; + when Iir_Kind_Package_Body => + -- A package instantiation depends on the body. + null; when others => Error_Kind ("elab_dependence", Library_Unit); end case; @@ -5593,28 +5725,35 @@ package body Translation is end loop; end Elab_Dependence; - procedure Clear_Subprg_Instance (Prev : out Subprg_Instance_Stack) - is + procedure Declare_Inst_Type_And_Ptr (Scope : Var_Scope_Acc; + Ptr_Type : out O_Tnode) is + begin + Predeclare_Scope_Type (Scope, Create_Identifier ("INSTTYPE")); + Declare_Scope_Acc + (Scope.all, Create_Identifier ("INSTPTR"), Ptr_Type); + end Declare_Inst_Type_And_Ptr; + + procedure Clear_Subprg_Instance (Prev : out Subprg_Instance_Stack) is begin Prev := Current_Subprg_Instance; Current_Subprg_Instance := Null_Subprg_Instance_Stack; end Clear_Subprg_Instance; - procedure Push_Subprg_Instance (Decl_Type : O_Tnode; + procedure Push_Subprg_Instance (Scope : Var_Scope_Acc; Ptr_Type : O_Tnode; Ident : O_Ident; Prev : out Subprg_Instance_Stack) is begin Prev := Current_Subprg_Instance; - Current_Subprg_Instance := (Decl_Type => Decl_Type, + Current_Subprg_Instance := (Scope => Scope, Ptr_Type => Ptr_Type, Ident => Ident); end Push_Subprg_Instance; function Has_Current_Subprg_Instance return Boolean is begin - return Current_Subprg_Instance.Decl_Type /= O_Tnode_Null; + return Current_Subprg_Instance.Ptr_Type /= O_Tnode_Null; end Has_Current_Subprg_Instance; procedure Pop_Subprg_Instance (Ident : O_Ident; @@ -5634,7 +5773,7 @@ package body Translation is is begin if Has_Current_Subprg_Instance then - Vars.Inst_Type := Current_Subprg_Instance.Decl_Type; + Vars.Scope := Current_Subprg_Instance.Scope; Vars.Inter_Type := Current_Subprg_Instance.Ptr_Type; New_Interface_Decl (Interfaces, Vars.Inter, @@ -5656,15 +5795,25 @@ package body Translation is end if; end Add_Subprg_Instance_Field; + function Has_Subprg_Instance (Vars : Subprg_Instance_Type) + return Boolean is + begin + return Vars.Inter /= O_Dnode_Null; + end Has_Subprg_Instance; + + function Get_Subprg_Instance (Vars : Subprg_Instance_Type) + return O_Enode is + begin + pragma Assert (Has_Subprg_Instance (Vars)); + return New_Address (Get_Instance_Ref (Vars.Scope.all), + Vars.Inter_Type); + end Get_Subprg_Instance; + procedure Add_Subprg_Instance_Assoc - (Assocs : in out O_Assoc_List; Vars : Subprg_Instance_Type) - is - Val : O_Enode; + (Assocs : in out O_Assoc_List; Vars : Subprg_Instance_Type) is begin - if Vars.Inter /= O_Dnode_Null then - Val := New_Address (Get_Instance_Ref (Vars.Inst_Type), - Vars.Inter_Type); - New_Association (Assocs, Val); + if Has_Subprg_Instance (Vars) then + New_Association (Assocs, Get_Subprg_Instance (Vars)); end if; end Add_Subprg_Instance_Assoc; @@ -5672,7 +5821,7 @@ package body Translation is (Var : O_Dnode; Field : O_Fnode; Vars : Subprg_Instance_Type) is begin - if Vars.Inter /= O_Dnode_Null then + if Has_Subprg_Instance (Vars) then New_Assign_Stmt (New_Selected_Acc_Value (New_Obj (Var), Field), New_Obj_Value (Vars.Inter)); end if; @@ -5680,15 +5829,15 @@ package body Translation is procedure Start_Subprg_Instance_Use (Vars : Subprg_Instance_Type) is begin - if Vars.Inter /= O_Dnode_Null then - Push_Scope (Vars.Inst_Type, Vars.Inter); + if Has_Subprg_Instance (Vars) then + Set_Scope_Via_Param_Ptr (Vars.Scope.all, Vars.Inter); end if; end Start_Subprg_Instance_Use; procedure Finish_Subprg_Instance_Use (Vars : Subprg_Instance_Type) is begin - if Vars.Inter /= O_Dnode_Null then - Pop_Scope (Vars.Inst_Type); + if Has_Subprg_Instance (Vars) then + Clear_Scope (Vars.Scope.all); end if; end Finish_Subprg_Instance_Use; @@ -5696,8 +5845,8 @@ package body Translation is (Prev : Subprg_Instance_Stack; Field : O_Fnode) is begin if Field /= O_Fnode_Null then - Push_Scope_Via_Field_Ptr - (Prev.Decl_Type, Field, Current_Subprg_Instance.Decl_Type); + Set_Scope_Via_Field_Ptr (Prev.Scope.all, Field, + Current_Subprg_Instance.Scope); end if; end Start_Prev_Subprg_Instance_Use_Via_Field; @@ -5705,7 +5854,7 @@ package body Translation is (Prev : Subprg_Instance_Stack; Field : O_Fnode) is begin if Field /= O_Fnode_Null then - Pop_Scope (Prev.Decl_Type); + Clear_Scope (Prev.Scope.all); end if; end Finish_Prev_Subprg_Instance_Use_Via_Field; @@ -5775,9 +5924,8 @@ package body Translation is procedure Create_Size_Var (Def : Iir) is - Info : Type_Info_Acc; + Info : constant Type_Info_Acc := Get_Info (Def); begin - Info := Get_Info (Def); Info.C := new Complex_Type_Arr_Info; Info.C (Mode_Value).Size_Var := Create_Var (Create_Var_Identifier ("SIZE"), Ghdl_Index_Type); @@ -6081,16 +6229,15 @@ package body Translation is procedure Translate_Physical_Units (Def : Iir_Physical_Type_Definition) is + Phy_Type : constant O_Tnode := Get_Ortho_Type (Def, Mode_Value); Unit : Iir; Info : Object_Info_Acc; - Phy_Type : O_Tnode; begin - Phy_Type := Get_Ortho_Type (Def, Mode_Value); Unit := Get_Unit_Chain (Def); while Unit /= Null_Iir loop Info := Add_Info (Unit, Kind_Object); - Info.Object_Var := Create_Var (Create_Var_Identifier (Unit), - Phy_Type); + Info.Object_Var := + Create_Var (Create_Var_Identifier (Unit), Phy_Type); Unit := Get_Chain (Unit); end loop; end Translate_Physical_Units; @@ -6489,7 +6636,7 @@ package body Translation is Info.C := new Complex_Type_Arr_Info; -- No size variable for unconstrained array type. for Mode in Object_Kind_Type loop - Info.C (Mode).Size_Var := null; + Info.C (Mode).Size_Var := Null_Var; Info.C (Mode).Builder_Need_Func := El_Tinfo.C (Mode).Builder_Need_Func; end loop; @@ -6652,7 +6799,7 @@ package body Translation is Base_Info : Type_Info_Acc; Val : O_Cnode; begin - if Info.T.Array_Bounds /= null then + if Info.T.Array_Bounds /= Null_Var then return; end if; Base_Info := Get_Info (Get_Base_Type (Def)); @@ -7141,7 +7288,7 @@ package body Translation is Finish_Subprogram_Decl (Inter_List, Info.T.Prot_Init_Subprg); -- Use the object as instance. - Chap2.Push_Subprg_Instance (Info.Ortho_Type (Mode_Value), + Chap2.Push_Subprg_Instance (Info.T.Prot_Scope'Unrestricted_Access, Info.Ortho_Ptr_Type (Mode_Value), Wki_Obj, Prev_Subprg_Instance); @@ -7184,10 +7331,9 @@ package body Translation is Push_Identifier_Prefix (Mark, Get_Identifier (Bod)); -- Create the object type - Push_Instance_Factory (Info.Ortho_Type (Mode_Value)); + Push_Instance_Factory (Info.T.Prot_Scope'Unrestricted_Access); -- First, the previous instance. - Chap2.Add_Subprg_Instance_Field - (Info.T.Prot_Subprg_Instance_Field); + Chap2.Add_Subprg_Instance_Field (Info.T.Prot_Subprg_Instance_Field); -- Then the object lock Info.T.Prot_Lock_Field := Add_Instance_Factory_Field (Get_Identifier ("LOCK"), Ghdl_Ptr_Type); @@ -7195,24 +7341,23 @@ package body Translation is -- Translate declarations. Chap4.Translate_Declaration_Chain (Bod); - Pop_Instance_Factory (Info.Ortho_Type (Mode_Value)); + Pop_Instance_Factory (Info.T.Prot_Scope'Unrestricted_Access); + Info.Ortho_Type (Mode_Value) := Get_Scope_Type (Info.T.Prot_Scope); Pop_Identifier_Prefix (Mark); end Translate_Protected_Type_Body; - -- Call lock or unlock on a protected object. procedure Call_Ghdl_Protected_Procedure (Type_Def : Iir; Proc : O_Dnode) is + Info : constant Type_Info_Acc := Get_Info (Type_Def); Assoc : O_Assoc_List; - Info : Type_Info_Acc; begin - Info := Get_Info (Type_Def); Start_Association (Assoc, Proc); New_Association (Assoc, New_Unchecked_Address (New_Selected_Element - (Get_Instance_Ref (Info.Ortho_Type (Mode_Value)), + (Get_Instance_Ref (Info.T.Prot_Scope), Info.T.Prot_Lock_Field), Ghdl_Ptr_Type)); New_Procedure_Call (Assoc); @@ -7229,14 +7374,14 @@ package body Translation is Push_Identifier_Prefix (Mark, Get_Identifier (Bod)); -- Subprograms of BOD. - Chap2.Push_Subprg_Instance (Info.Ortho_Type (Mode_Value), + Chap2.Push_Subprg_Instance (Info.T.Prot_Scope'Unrestricted_Access, Info.Ortho_Ptr_Type (Mode_Value), Wki_Obj, Prev_Subprg_Instance); Chap2.Start_Prev_Subprg_Instance_Use_Via_Field (Prev_Subprg_Instance, Info.T.Prot_Subprg_Instance_Field); - Chap4.Translate_Declaration_Chain_Subprograms (Bod, Null_Iir); + Chap4.Translate_Declaration_Chain_Subprograms (Bod); Chap2.Finish_Prev_Subprg_Instance_Use_Via_Field (Prev_Subprg_Instance, Info.T.Prot_Subprg_Instance_Field); @@ -7269,7 +7414,7 @@ package body Translation is (Var_Obj, Info.T.Prot_Subprg_Instance_Field, Info.T.Prot_Init_Instance); - Push_Scope (Info.Ortho_Type (Mode_Value), Var_Obj); + Set_Scope_Via_Param_Ptr (Info.T.Prot_Scope, Var_Obj); -- Create lock. Call_Ghdl_Protected_Procedure (Decl, Ghdl_Protected_Init); @@ -7279,7 +7424,7 @@ package body Translation is Chap4.Elab_Declaration_Chain (Bod, Final); Close_Temp; - Pop_Scope (Info.Ortho_Type (Mode_Value)); + Clear_Scope (Info.T.Prot_Scope); New_Return_Stmt (New_Obj_Value (Var_Obj)); Chap2.Finish_Subprg_Instance_Use (Info.T.Prot_Init_Instance); @@ -7527,7 +7672,7 @@ package body Translation is end if; for Kind in Mode_Value .. Type_To_Last_Object_Kind (Def) loop - if Info.C (Kind).Size_Var /= null then + if Info.C (Kind).Size_Var /= Null_Var then case Info.Type_Mode is when Type_Mode_Non_Composite | Type_Mode_Fat_Array @@ -7545,12 +7690,11 @@ package body Translation is procedure Create_Type_Range_Var (Def : Iir) is - Info : Type_Info_Acc; + Info : constant Type_Info_Acc := Get_Info (Def); Base_Info : Type_Info_Acc; Val : O_Cnode; Suffix : String (1 .. 3) := "xTR"; begin - Info := Get_Info (Def); case Get_Kind (Def) is when Iir_Kinds_Subtype_Definition => Suffix (1) := 'S'; -- "STR"; @@ -7806,7 +7950,7 @@ package body Translation is if With_Vars and Get_Type_Staticness (Def) /= Locally then Translate_Physical_Units (Def); else - Info.T.Range_Var := null; + Info.T.Range_Var := Null_Var; end if; when Iir_Kind_Floating_Type_Definition => @@ -7821,7 +7965,7 @@ package body Translation is if With_Vars then Create_Type_Range_Var (Def); else - Info.T.Range_Var := null; + Info.T.Range_Var := Null_Var; end if; when Iir_Kind_Array_Type_Definition => @@ -8454,13 +8598,11 @@ package body Translation is function Get_Object_Size (Obj : Mnode; Obj_Type : Iir) return O_Enode is - Type_Info : Type_Info_Acc; - Kind : Object_Kind_Type; + Type_Info : constant Type_Info_Acc := Get_Type_Info (Obj); + Kind : constant Object_Kind_Type := Get_Object_Kind (Obj); begin - Type_Info := Get_Type_Info (Obj); - Kind := Get_Object_Kind (Obj); if Is_Complex_Type (Type_Info) - and then Type_Info.C (Kind).Size_Var /= null + and then Type_Info.C (Kind).Size_Var /= Null_Var then return New_Value (Get_Var (Type_Info.C (Kind).Size_Var)); end if; @@ -9085,8 +9227,8 @@ package body Translation is case Get_Kind (El) is when Iir_Kind_Variable_Declaration | Iir_Kind_Constant_Interface_Declaration => - Info.Object_Var := Create_Var (Create_Var_Identifier (El), - Obj_Type); + Info.Object_Var := + Create_Var (Create_Var_Identifier (El), Obj_Type); when Iir_Kind_Constant_Declaration => if Get_Deferred_Declaration (El) /= Null_Iir then -- This is a full constant declaration (in a body) of a @@ -9095,7 +9237,7 @@ package body Translation is else Storage := Global_Storage; end if; - if Info.Object_Var = null then + if Info.Object_Var = Null_Var then -- Not a full constant declaration (ie a value for an -- already declared constant). -- Must create the declaration. @@ -9107,7 +9249,8 @@ package body Translation is else Info.Object_Static := False; Info.Object_Var := Create_Var - (Create_Var_Identifier (El), Obj_Type, Global_Storage); + (Create_Var_Identifier (El), + Obj_Type, Global_Storage); end if; end if; if Get_Deferred_Declaration (El) = Null_Iir @@ -9131,23 +9274,21 @@ package body Translation is procedure Create_Signal (Decl : Iir) is + Sig_Type_Def : constant Iir := Get_Type (Decl); Sig_Type : O_Tnode; Type_Info : Type_Info_Acc; Info : Ortho_Info_Acc; - Sig_Type_Def : Iir; begin - Sig_Type_Def := Get_Type (Decl); Chap3.Translate_Object_Subtype (Decl); + Type_Info := Get_Info (Sig_Type_Def); Sig_Type := Get_Object_Type (Type_Info, Mode_Signal); - if Sig_Type = O_Tnode_Null then - raise Internal_Error; - end if; + pragma Assert (Sig_Type /= O_Tnode_Null); Info := Add_Info (Decl, Kind_Object); - Info.Object_Var := Create_Var - (Create_Var_Identifier (Decl), Sig_Type); + Info.Object_Var := + Create_Var (Create_Var_Identifier (Decl), Sig_Type); case Get_Kind (Decl) is when Iir_Kind_Signal_Declaration @@ -9389,20 +9530,18 @@ package body Translation is procedure Elab_Object_Storage (Obj : Iir) is - Obj_Info : Object_Info_Acc; + Obj_Type : constant Iir := Get_Type (Obj); + Obj_Info : constant Object_Info_Acc := Get_Info (Obj); Name_Node : Mnode; - Obj_Type : Iir; Type_Info : Type_Info_Acc; Alloc_Kind : Allocation_Kind; begin -- Elaborate subtype. - Obj_Type := Get_Type (Obj); Chap3.Elab_Object_Subtype (Obj_Type); Type_Info := Get_Info (Obj_Type); - Obj_Info := Get_Info (Obj); -- FIXME: the object type may be a fat array! -- FIXME: fat array + aggregate ? @@ -9693,24 +9832,25 @@ package body Translation is -- Add func and instance. procedure Add_Associations_For_Resolver - (Assoc : in out O_Assoc_List; Func : Iir) + (Assoc : in out O_Assoc_List; Func_Name : Iir) is - Func_Info : Subprg_Info_Acc; - Resolv_Info : Subprg_Resolv_Info_Acc; + Func : constant Iir := Get_Named_Entity (Func_Name); + Func_Info : constant Subprg_Info_Acc := Get_Info (Func); + Resolv_Info : constant Subprg_Resolv_Info_Acc := + Func_Info.Subprg_Resolv; + Val : O_Enode; begin - Func_Info := Get_Info (Get_Named_Entity (Func)); - Resolv_Info := Func_Info.Subprg_Resolv; New_Association (Assoc, New_Lit (New_Subprogram_Address (Resolv_Info.Resolv_Func, Ghdl_Ptr_Type))); - if Resolv_Info.Resolv_Block /= Null_Iir then - New_Association - (Assoc, - New_Convert_Ov (Get_Instance_Access (Resolv_Info.Resolv_Block), - Ghdl_Ptr_Type)); + if Chap2.Has_Subprg_Instance (Resolv_Info.Var_Instance) then + Val := New_Convert_Ov + (Chap2.Get_Subprg_Instance (Resolv_Info.Var_Instance), + Ghdl_Ptr_Type); else - New_Association (Assoc, New_Lit (New_Null_Access (Ghdl_Ptr_Type))); + Val := New_Lit (New_Null_Access (Ghdl_Ptr_Type)); end if; + New_Association (Assoc, Val); end Add_Associations_For_Resolver; type O_If_Block_Acc is access O_If_Block; @@ -9732,7 +9872,7 @@ package body Translation is Targ_Type : Iir; Data : Elab_Signal_Data) is - Type_Info : Type_Info_Acc; + Type_Info : constant Type_Info_Acc := Get_Info (Targ_Type); Create_Subprg : O_Dnode; Conv : O_Tnode; Res : O_Enode; @@ -9743,8 +9883,6 @@ package body Translation is If_Stmt : O_If_Block; Targ_Ptr : O_Dnode; begin - Type_Info := Get_Info (Targ_Type); - if Data.Check_Null then Targ_Ptr := Create_Temp_Init (Ghdl_Signal_Ptr_Ptr, @@ -9953,22 +10091,18 @@ package body Translation is begin Info := Get_Info (Get_Object_Prefix (Sig)); return Info.Kind = Kind_Object - and then Info.Object_Driver /= null; + and then Info.Object_Driver /= Null_Var; end Has_Direct_Driver; procedure Elab_Direct_Driver_Declaration_Storage (Decl : Iir) is - Sig_Type : Iir; - Type_Info : Type_Info_Acc; - Sig_Info : Ortho_Info_Acc; + Sig_Type : constant Iir := Get_Type (Decl); + Sig_Info : constant Ortho_Info_Acc := Get_Info (Decl); + Type_Info : constant Type_Info_Acc := Get_Info (Sig_Type); Name_Node : Mnode; begin Open_Temp; - Sig_Type := Get_Type (Decl); - Sig_Info := Get_Info (Decl); - Type_Info := Get_Info (Sig_Type); - if Type_Info.Type_Mode = Type_Mode_Fat_Array then Name_Node := Get_Var (Sig_Info.Object_Driver, Type_Info, Mode_Value); @@ -10518,7 +10652,7 @@ package body Translation is begin Info := Add_Info (Decl, Kind_Component); Push_Identifier_Prefix (Mark, Get_Identifier (Decl)); - Push_Instance_Factory (O_Tnode_Null); + Push_Instance_Factory (Info.Comp_Scope'Access); Info.Comp_Link := Add_Instance_Factory_Field (Wki_Instance, Rtis.Ghdl_Component_Link_Type); @@ -10527,9 +10661,11 @@ package body Translation is Translate_Generic_Chain (Decl); Translate_Port_Chain (Decl); - Pop_Instance_Factory (Info.Comp_Type); - New_Type_Decl (Create_Identifier ("_COMPTYPE"), Info.Comp_Type); - Info.Comp_Ptr_Type := New_Access_Type (Info.Comp_Type); + Pop_Instance_Factory (Info.Comp_Scope'Access); + New_Type_Decl (Create_Identifier ("_COMPTYPE"), + Get_Scope_Type (Info.Comp_Scope)); + Info.Comp_Ptr_Type := New_Access_Type + (Get_Scope_Type (Info.Comp_Scope)); New_Type_Decl (Create_Identifier ("_COMPPTR"), Info.Comp_Ptr_Type); Pop_Identifier_Prefix (Mark); end Translate_Component_Declaration; @@ -10608,7 +10744,7 @@ package body Translation is end case; end Translate_Declaration; - procedure Translate_Resolution_Function (Func : Iir; Block : Iir) + procedure Translate_Resolution_Function (Func : Iir) is -- Type of the resolution function parameter. El_Type : Iir; @@ -10616,9 +10752,9 @@ package body Translation is Finfo : constant Subprg_Info_Acc := Get_Info (Func); Interface_List : O_Inter_List; Rinfo : constant Subprg_Resolv_Info_Acc := Finfo.Subprg_Resolv; - Block_Info : Block_Info_Acc; Id : O_Ident; Itype : O_Tnode; + Unused_Instance : O_Dnode; begin if Rinfo = null then -- Not a resolution function @@ -10630,17 +10766,15 @@ package body Translation is Start_Procedure_Decl (Interface_List, Id, Global_Storage); -- The instance. - if Block /= Null_Iir then - Block_Info := Get_Info (Block); - Rinfo.Resolv_Block := Block; - Itype := Block_Info.Block_Decls_Ptr_Type; + if Chap2.Has_Current_Subprg_Instance then + Chap2.Add_Subprg_Instance_Interfaces (Interface_List, + Rinfo.Var_Instance); else -- Create a dummy instance parameter - Rinfo.Resolv_Block := Null_Iir; - Itype := Ghdl_Ptr_Type; + New_Interface_Decl (Interface_List, Unused_Instance, + Wki_Instance, Ghdl_Ptr_Type); + Rinfo.Var_Instance := Chap2.Null_Subprg_Instance; end if; - New_Interface_Decl - (Interface_List, Rinfo.Var_Instance, Wki_Instance, Itype); -- The signal. El_Type := Get_Type (Get_Interface_Declaration_Chain (Func)); @@ -10770,7 +10904,7 @@ package body Translation is Update_Data_Record => Read_Source_Update_Data_Record, Finish_Data_Record => Read_Source_Finish_Data_Composite); - procedure Translate_Resolution_Function_Body (Func : Iir; Block : Iir) + procedure Translate_Resolution_Function_Body (Func : Iir) is -- Type of the resolution function parameter. Arr_Type : Iir; @@ -10809,7 +10943,6 @@ package body Translation is Finfo : constant Subprg_Info_Acc := Get_Info (Func); Rinfo : constant Subprg_Resolv_Info_Acc := Finfo.Subprg_Resolv; Assoc : O_Assoc_List; - Block_Info : Block_Info_Acc; Data : Read_Source_Data; begin @@ -10832,9 +10965,8 @@ package body Translation is Index_Tinfo := Get_Info (Index_Type); Start_Subprogram_Body (Rinfo.Resolv_Func); - if Rinfo.Resolv_Block /= Null_Iir then - Block_Info := Get_Info (Block); - Push_Scope (Block_Info.Block_Decls_Type, Rinfo.Var_Instance); + if Chap2.Has_Subprg_Instance (Rinfo.Var_Instance) then + Chap2.Start_Subprg_Instance_Use (Rinfo.Var_Instance); end if; Push_Local_Factory; @@ -10995,8 +11127,8 @@ package body Translation is Close_Temp; Pop_Local_Factory; - if Rinfo.Resolv_Block /= Null_Iir then - Pop_Scope (Block_Info.Block_Decls_Type); + if Chap2.Has_Subprg_Instance (Rinfo.Var_Instance) then + Chap2.Finish_Subprg_Instance_Use (Rinfo.Var_Instance); end if; Finish_Subprogram_Body; end Translate_Resolution_Function_Body; @@ -11036,8 +11168,7 @@ package body Translation is end loop; end Translate_Declaration_Chain; - procedure Translate_Declaration_Chain_Subprograms - (Parent : Iir; Block : Iir) + procedure Translate_Declaration_Chain_Subprograms (Parent : Iir) is El : Iir; Infos : Chap7.Implicit_Subprogram_Infos; @@ -11050,7 +11181,7 @@ package body Translation is -- Translate only if used. if Get_Info (El) /= null then Chap2.Translate_Subprogram_Declaration (El); - Translate_Resolution_Function (El, Block); + Translate_Resolution_Function (El); end if; when Iir_Kind_Function_Body | Iir_Kind_Procedure_Body => @@ -11064,7 +11195,7 @@ package body Translation is then Chap2.Translate_Subprogram_Body (El); Translate_Resolution_Function_Body - (Get_Subprogram_Specification (El), Block); + (Get_Subprogram_Specification (El)); end if; when Iir_Kind_Type_Declaration | Iir_Kind_Anonymous_Type_Declaration => @@ -11244,7 +11375,7 @@ package body Translation is In_Info, Out_Info : Type_Info_Acc; Itype : O_Tnode; El_List : O_Element_List; - Block_Info : Block_Info_Acc; + Block_Info : constant Block_Info_Acc := Get_Info (Base_Block); Stmt_Info : Block_Info_Acc; Entity_Info : Ortho_Info_Acc; Var_Data : O_Dnode; @@ -11292,7 +11423,6 @@ package body Translation is -- Add instance field. Conv_Info.Instance_Block := Base_Block; - Block_Info := Get_Info (Base_Block); New_Record_Field (El_List, Conv_Info.Instance_Field, Wki_Instance, Block_Info.Block_Decls_Ptr_Type); @@ -11355,27 +11485,28 @@ package body Translation is (Block_Info.Block_Decls_Ptr_Type, New_Value_Selected_Acc_Value (New_Obj (Var_Data), Conv_Info.Instance_Field)); - Push_Scope (Block_Info.Block_Decls_Type, V); + Set_Scope_Via_Param_Ptr (Block_Info.Block_Scope, V); -- Add an access to instantiated entity. -- This may be used to do some type checks. if Conv_Info.Instantiated_Entity /= Null_Iir then declare Ptr_Type : O_Tnode; - Decl_Type : O_Tnode; begin if Entity_Info.Kind = Kind_Component then Ptr_Type := Entity_Info.Comp_Ptr_Type; - Decl_Type := Entity_Info.Comp_Type; else Ptr_Type := Entity_Info.Block_Decls_Ptr_Type; - Decl_Type := Entity_Info.Block_Decls_Type; end if; V := Create_Temp_Init (Ptr_Type, New_Value_Selected_Acc_Value (New_Obj (Var_Data), Conv_Info.Instantiated_Field)); - Push_Scope (Decl_Type, V); + if Entity_Info.Kind = Kind_Component then + Set_Scope_Via_Param_Ptr (Entity_Info.Comp_Scope, V); + else + Set_Scope_Via_Param_Ptr (Entity_Info.Block_Scope, V); + end if; end; end if; @@ -11384,11 +11515,11 @@ package body Translation is -- FIXME: what if STMT is a binding_indication ? Stmt_Info := Get_Info (Stmt); if Stmt_Info /= null - and then Stmt_Info.Block_Decls_Type /= O_Tnode_Null + and then Has_Scope_Type (Stmt_Info.Block_Scope) then - Push_Scope (Stmt_Info.Block_Decls_Type, - Stmt_Info.Block_Parent_Field, - Get_Info (Block).Block_Decls_Type); + Set_Scope_Via_Field (Stmt_Info.Block_Scope, + Stmt_Info.Block_Parent_Field, + Get_Info (Block).Block_Scope'Access); end if; -- Read signal value. @@ -11403,7 +11534,7 @@ package body Translation is case Get_Kind (Imp) is when Iir_Kind_Function_Call => - Func := Get_Named_Entity (Get_Implementation (Imp)); + Func := Get_Implementation (Imp); R := Chap7.Translate_Implicit_Conv (R, In_Type, Get_Type (Get_Interface_Declaration_Chain (Func)), @@ -11487,18 +11618,18 @@ package body Translation is Close_Temp; if Stmt_Info /= null - and then Stmt_Info.Block_Decls_Type /= O_Tnode_Null + and then Has_Scope_Type (Stmt_Info.Block_Scope) then - Pop_Scope (Stmt_Info.Block_Decls_Type); + Clear_Scope (Stmt_Info.Block_Scope); end if; if Conv_Info.Instantiated_Entity /= Null_Iir then if Entity_Info.Kind = Kind_Component then - Pop_Scope (Entity_Info.Comp_Type); + Clear_Scope (Entity_Info.Comp_Scope); else - Pop_Scope (Entity_Info.Block_Decls_Type); + Clear_Scope (Entity_Info.Block_Scope); end if; end if; - Pop_Scope (Block_Info.Block_Decls_Type); + Clear_Scope (Block_Info.Block_Scope); Pop_Local_Factory; Finish_Subprogram_Body; @@ -11579,7 +11710,7 @@ package body Translation is then Inst_Info := Get_Info (Info.Instantiated_Entity); Inst_Addr := New_Address - (Get_Instance_Ref (Inst_Info.Comp_Type), + (Get_Instance_Ref (Inst_Info.Comp_Scope), Inst_Info.Comp_Ptr_Type); else Inst_Addr := Get_Instance_Access (Info.Instantiated_Entity); @@ -12208,19 +12339,13 @@ package body Translation is end case; end Inherit_Collapse_Flag; - procedure Elab_Map_Aspect (Mapping : Iir; Block_Parent : Iir) + procedure Elab_Generic_Map_Aspect (Mapping : Iir) is Assoc : Iir; Formal : Iir; - Formal_Base : Iir; - Fb_Type : Iir; - Fbt_Info : Type_Info_Acc; - Collapse_Individual : Boolean := False; Targ : Mnode; begin -- Elab generics, and associate. - -- The generic map must be done before the elaboration of - -- the ports, since a port subtype may depend on a generic. Assoc := Get_Generic_Map_Aspect_Chain (Mapping); while Assoc /= Null_Iir loop Open_Temp; @@ -12275,7 +12400,17 @@ package body Translation is Close_Temp; Assoc := Get_Chain (Assoc); end loop; + end Elab_Generic_Map_Aspect; + procedure Elab_Port_Map_Aspect (Mapping : Iir; Block_Parent : Iir) + is + Assoc : Iir; + Formal : Iir; + Formal_Base : Iir; + Fb_Type : Iir; + Fbt_Info : Type_Info_Acc; + Collapse_Individual : Boolean := False; + begin -- Ports. Assoc := Get_Port_Map_Aspect_Chain (Mapping); while Assoc /= Null_Iir loop @@ -12388,8 +12523,16 @@ package body Translation is Assoc := Get_Chain (Assoc); end loop; - end Elab_Map_Aspect; + end Elab_Port_Map_Aspect; + + procedure Elab_Map_Aspect (Mapping : Iir; Block_Parent : Iir) is + begin + -- The generic map must be done before the elaboration of + -- the ports, since a port subtype may depend on a generic. + Elab_Generic_Map_Aspect (Mapping); + Elab_Port_Map_Aspect (Mapping, Block_Parent); + end Elab_Map_Aspect; end Chap5; package body Chap6 is @@ -13111,25 +13254,46 @@ package body Translation is return Get_Var (Info.Object_Var, Type_Info, Kind); when Kind_Interface => -- For a parameter. - if Info.Interface_Field /= O_Fnode_Null then + if Info.Interface_Field = O_Fnode_Null then + -- Normal case: the parameter was translated as an ortho + -- interface. + case Type_Info.Type_Mode is + when Type_Mode_Unknown => + raise Internal_Error; + when Type_Mode_By_Value => + return Dv2M (Info.Interface_Node, Type_Info, Kind); + when Type_Mode_By_Copy + | Type_Mode_By_Ref => + -- Parameter is passed by reference. + return Dp2M (Info.Interface_Node, Type_Info, Kind); + end case; + else + -- The parameter was put somewhere else. declare + Subprg : constant Iir := Get_Parent (Inter); Subprg_Info : constant Subprg_Info_Acc := - Get_Info (Get_Parent (Inter)); + Get_Info (Subprg); Linter : O_Lnode; begin if Info.Interface_Node = O_Dnode_Null then - -- Passed by copy in the RESULT record. - return Lv2M - (New_Selected_Element - (Get_Instance_Ref (Subprg_Info.Res_Record_Type), - Info.Interface_Field), - Type_Info, Kind); + -- The parameter is passed via a field of the RESULT + -- record parameter. + if Subprg_Info.Res_Record_Var = Null_Var then + Linter := New_Obj (Subprg_Info.Res_Interface); + else + -- Unnesting case. + Linter := Get_Var (Subprg_Info.Res_Record_Var); + end if; + return Lv2M (New_Selected_Element + (New_Acc_Value (Linter), + Info.Interface_Field), + Type_Info, Kind); else - -- Use field in FRAME (instead of direct reference - -- to parameter - used to unnest subprograms). - Linter := - New_Selected_Element - (Get_Instance_Ref (Subprg_Info.Subprg_Frame_Type), + -- Unnesting case: the parameter was copied in the + -- subprogram frame so that nested subprograms can + -- reference it. Use field in FRAME. + Linter := New_Selected_Element + (Get_Instance_Ref (Subprg_Info.Subprg_Frame_Scope), Info.Interface_Field); case Type_Info.Type_Mode is when Type_Mode_Unknown => @@ -13143,17 +13307,6 @@ package body Translation is end case; end if; end; - else - case Type_Info.Type_Mode is - when Type_Mode_Unknown => - raise Internal_Error; - when Type_Mode_By_Value => - return Dv2M (Info.Interface_Node, Type_Info, Kind); - when Type_Mode_By_Copy - | Type_Mode_By_Ref => - -- Parameter is passed by reference. - return Dp2M (Info.Interface_Node, Type_Info, Kind); - end case; end if; when others => raise Internal_Error; @@ -13206,7 +13359,7 @@ package body Translation is -- Info := Get_Info (Name); -- Push_Scope_Soft (Scope_Type, Scope_Param); -- Res := Get_Var (Info.Object_Var, Type_Info, Kind); --- Pop_Scope_Soft (Scope_Type); +-- Clear_Scope_Soft (Scope_Type); -- return Res; -- end Translate_Formal_Interface_Name; @@ -13347,8 +13500,7 @@ package body Translation is -- This can appear as a prefix of a name, therefore, the -- result is always a composite type or an access type. declare - Imp : constant Iir := - Get_Named_Entity (Get_Implementation (Name)); + Imp : constant Iir := Get_Implementation (Name); Obj : Iir; Assoc_Chain : Iir; begin @@ -13673,7 +13825,7 @@ package body Translation is -- of the string (a constrained array type) is STR_TYPE. function Create_String_Literal_Var_Inner (Str : Iir; Element_Type : Iir; Str_Type : O_Tnode) - return Var_Acc + return Var_Type is use Name_Table; @@ -13698,7 +13850,7 @@ package body Translation is end Create_String_Literal_Var_Inner; -- Create a variable (constant) for string or bit string literal STR. - function Create_String_Literal_Var (Str : Iir) return Var_Acc is + function Create_String_Literal_Var (Str : Iir) return Var_Type is use Name_Table; Str_Type : constant Iir := Get_Type (Str); @@ -13731,8 +13883,8 @@ package body Translation is Res_Aggr : O_Record_Aggr_List; Res : O_Cnode; Len : Int32; - Val : Var_Acc; - Bound : Var_Acc; + Val : Var_Type; + Bound : Var_Type; R : O_Enode; begin -- Create the string value. @@ -13774,8 +13926,6 @@ package body Translation is New_Global_Address (Get_Var_Label (Bound), Type_Info.T.Bounds_Ptr_Type)); Finish_Record_Aggr (Res_Aggr, Res); - Free_Var (Val); - Free_Var (Bound); Val := Create_Global_Const (Create_Uniq_Identifier, Type_Info.Ortho_Type (Mode_Value), @@ -13796,7 +13946,6 @@ package body Translation is R := New_Address (Get_Var (Val), Type_Info.Ortho_Ptr_Type (Mode_Value)); - Free_Var (Val); return R; end Translate_Non_Static_String_Literal; @@ -13847,7 +13996,7 @@ package body Translation is function Translate_String_Literal (Str : Iir) return O_Enode is Str_Type : constant Iir := Get_Type (Str); - Var : Var_Acc; + Var : Var_Type; Info : Type_Info_Acc; Res : O_Cnode; R : O_Enode; @@ -13875,7 +14024,6 @@ package body Translation is (Create_Uniq_Identifier, Info.Ortho_Type (Mode_Value), O_Storage_Private, Res); R := New_Address (Get_Var (Var), Info.Ortho_Ptr_Type (Mode_Value)); - Free_Var (Var); return R; else return Translate_Non_Static_String_Literal (Str); @@ -13887,10 +14035,10 @@ package body Translation is is Expr_Info : Type_Info_Acc; Res_Info : Type_Info_Acc; - Val : Var_Acc; + Val : Var_Type; Res : O_Cnode; List : O_Record_Aggr_List; - Bound : Var_Acc; + Bound : Var_Type; begin if Res_Type = Expr_Type then return Expr; @@ -13910,7 +14058,7 @@ package body Translation is (Create_Uniq_Identifier, Expr_Info.Ortho_Type (Mode_Value), O_Storage_Private, Expr); Bound := Expr_Info.T.Array_Bounds; - if Bound = null then + if Bound = Null_Var then Bound := Create_Global_Const (Create_Uniq_Identifier, Expr_Info.T.Bounds_Type, O_Storage_Private, @@ -15597,6 +15745,17 @@ package body Translation is raise Internal_Error; end case; when Iir_Predefined_Enum_To_String => + -- LRM08 5.7 String representations + -- - For a given value of type CHARACTER, [...] + -- + -- So special case for character. + if Get_Base_Type (Left_Type) = Character_Type_Definition then + return Translate_To_String + (Ghdl_To_String_Char, Res_Type, Loc, Left_Tree); + end if; + + -- LRM08 5.7 String representations + -- - For a given value of type other than CHARACTER, [...] declare Conv : O_Tnode; Subprg : O_Dnode; @@ -15902,7 +16061,7 @@ package body Translation is -- Type of the constrained array type. Str_Type : O_Tnode; - Cst : Var_Acc; + Cst : Var_Type; Var_I : O_Dnode; Label : O_Snode; begin @@ -15940,7 +16099,6 @@ package body Translation is Inc_Var (Var_Index); Finish_Loop_Stmt (Label); Close_Temp; - Free_Var (Cst); end; return; when others => @@ -17044,7 +17202,7 @@ package body Translation is (Imp, Get_Operand (Expr), Null_Iir, Res_Type); end if; when Iir_Kind_Function_Call => - Imp := Get_Named_Entity (Get_Implementation (Expr)); + Imp := Get_Implementation (Expr); declare Assoc_Chain : Iir; begin @@ -19404,7 +19562,7 @@ package body Translation is is Iter_Type : Iir; Iter_Base_Type : Iir; - Var_Iter : Var_Acc; + Var_Iter : Var_Type; Constraint : Iir; Cond : O_Enode; Dir : Iir_Direction; @@ -19488,7 +19646,7 @@ package body Translation is Iter_Type : Iir; Iter_Base_Type : Iir; Iter_Type_Info : Type_Info_Acc; - Var_Iter : Var_Acc; + Var_Iter : Var_Type; Constraint : Iir; Deep_Rng : Iir; Deep_Reverse : Boolean; @@ -19560,7 +19718,7 @@ package body Translation is Iter_Type_Info : constant Type_Info_Acc := Get_Info (Iter_Base_Type); Data : For_Loop_Data; It_Info : Ortho_Info_Acc; - Var_Iter : Var_Acc; + Var_Iter : Var_Type; Prev_Loop : Iir; begin Prev_Loop := Current_Loop; @@ -20587,7 +20745,7 @@ package body Translation is procedure Translate_Implicit_Procedure_Call (Call : Iir_Procedure_Call) is - Imp : constant Iir := Get_Named_Entity (Get_Implementation (Call)); + Imp : constant Iir := Get_Implementation (Call); Kind : constant Iir_Predefined_Functions := Get_Implicit_Definition (Imp); Param_Chain : constant Iir := Get_Parameter_Association_Chain (Call); @@ -20785,7 +20943,7 @@ package body Translation is case Get_Kind (Conv) is when Iir_Kind_Function_Call => -- Call conversion function. - Imp := Get_Named_Entity (Get_Implementation (Conv)); + Imp := Get_Implementation (Conv); Conv_Info := Get_Info (Imp); Start_Association (Constr, Conv_Info.Ortho_Func); @@ -20829,7 +20987,7 @@ package body Translation is Iir_Chains.Get_Chain_Length (Assoc_Chain); Params : Mnode_Array (0 .. Nbr_Assoc - 1); E_Params : O_Enode_Array (0 .. Nbr_Assoc - 1); - Imp : constant Iir := Get_Named_Entity (Get_Implementation (Stmt)); + Imp : constant Iir := Get_Implementation (Stmt); Info : constant Subprg_Info_Acc := Get_Info (Imp); Res : O_Dnode; El : Iir; @@ -22066,8 +22224,7 @@ package body Translation is when Iir_Kind_Procedure_Call_Statement => declare Call : constant Iir := Get_Procedure_Call (Stmt); - Imp : constant Iir := - Get_Named_Entity (Get_Implementation (Call)); + Imp : constant Iir := Get_Implementation (Call); begin Canon.Canon_Subprogram_Call (Call); if Get_Kind (Imp) = Iir_Kind_Implicit_Procedure_Declaration @@ -22122,12 +22279,12 @@ package body Translation is Proc_Info : constant Proc_Info_Acc := Get_Info (Proc); Drivers : constant Direct_Drivers_Acc := Proc_Info.Process_Drivers; Info : Ortho_Info_Acc; - Var : Var_Acc; + Var : Var_Type; Sig : Iir; begin for I in Drivers.all'Range loop Var := Drivers (I).Var; - if Var /= null then + if Var /= Null_Var then Sig := Get_Object_Prefix (Drivers (I).Sig); Info := Get_Info (Sig); case Info.Kind is @@ -22147,17 +22304,17 @@ package body Translation is Proc_Info : constant Proc_Info_Acc := Get_Info (Proc); Drivers : constant Direct_Drivers_Acc := Proc_Info.Process_Drivers; Info : Ortho_Info_Acc; - Var : Var_Acc; + Var : Var_Type; Sig : Iir; begin for I in Drivers.all'Range loop Var := Drivers (I).Var; - if Var /= null then + if Var /= Null_Var then Sig := Get_Object_Prefix (Drivers (I).Sig); Info := Get_Info (Sig); case Info.Kind is when Kind_Object => - Info.Object_Driver := null; + Info.Object_Driver := Null_Var; when Kind_Alias => null; when others => @@ -22169,11 +22326,10 @@ package body Translation is procedure Translate_Process_Statement (Proc : Iir; Base : Block_Info_Acc) is + Info : constant Proc_Info_Acc := Get_Info (Proc); Inter_List : O_Inter_List; Instance : O_Dnode; - Info : Proc_Info_Acc; begin - Info := Get_Info (Proc); Start_Procedure_Decl (Inter_List, Create_Identifier ("PROC"), O_Storage_Private); New_Interface_Decl (Inter_List, Instance, Wki_Instance, @@ -22183,12 +22339,12 @@ package body Translation is Start_Subprogram_Body (Info.Process_Subprg); Push_Local_Factory; -- Push scope for architecture declarations. - Push_Scope (Base.Block_Decls_Type, Instance); + Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance); Chap8.Translate_Statements_Chain (Get_Sequential_Statement_Chain (Proc)); - Pop_Scope (Base.Block_Decls_Type); + Clear_Scope (Base.Block_Scope); Pop_Local_Factory; Finish_Subprogram_Body; end Translate_Process_Statement; @@ -22212,11 +22368,11 @@ package body Translation is Start_Subprogram_Body (Info.Object_Function); Push_Local_Factory; - Push_Scope (Base.Block_Decls_Type, Instance); + Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance); Open_Temp; New_Return_Stmt (Chap7.Translate_Expression (Guard_Expr)); Close_Temp; - Pop_Scope (Base.Block_Decls_Type); + Clear_Scope (Base.Block_Scope); Pop_Local_Factory; Finish_Subprogram_Body; end Translate_Implicit_Guard_Signal; @@ -22232,13 +22388,13 @@ package body Translation is Has_Conv_Record : Boolean := False; begin Info := Add_Info (Inst, Kind_Block); - Info.Block_Decls_Type := O_Tnode_Null; + if Is_Component_Instantiation (Inst) then -- Via a component declaration. Comp_Info := Get_Info (Get_Named_Entity (Comp)); Info.Block_Link_Field := Add_Instance_Factory_Field (Create_Identifier_Without_Prefix (Inst), - Comp_Info.Comp_Type); + Get_Scope_Type (Comp_Info.Comp_Scope)); else -- Direct instantiation. Info.Block_Link_Field := Add_Instance_Factory_Field @@ -22263,7 +22419,7 @@ package body Translation is -- Lazy creation of the record. if not Has_Conv_Record then Has_Conv_Record := True; - Push_Instance_Factory (O_Tnode_Null); + Push_Instance_Factory (Info.Block_Scope'Access); end if; -- FIXME: handle with overload multiple case on the same @@ -22278,14 +22434,14 @@ package body Translation is Assoc := Get_Chain (Assoc); end loop; if Has_Conv_Record then - Pop_Instance_Factory (Info.Block_Decls_Type); + Pop_Instance_Factory (Info.Block_Scope'Access); New_Type_Decl (Create_Identifier (Get_Identifier (Inst), "__CONVS"), - Info.Block_Decls_Type); + Get_Scope_Type (Info.Block_Scope)); Info.Block_Parent_Field := Add_Instance_Factory_Field (Create_Identifier_Without_Prefix (Get_Identifier (Inst), "__CONVS"), - Info.Block_Decls_Type); + Get_Scope_Type (Info.Block_Scope)); end if; end Translate_Component_Instantiation_Statement; @@ -22293,17 +22449,16 @@ package body Translation is is Mark : Id_Mark_Type; Info : Ortho_Info_Acc; - Itype : O_Tnode; - Field : O_Fnode; Drivers : Iir_List; Nbr_Drivers : Natural; Sig : Iir; begin + Info := Add_Info (Proc, Kind_Process); + -- Create process record. Push_Identifier_Prefix (Mark, Get_Identifier (Proc)); - Push_Instance_Factory (O_Tnode_Null); - Info := Add_Info (Proc, Kind_Process); + Push_Instance_Factory (Info.Process_Scope'Access); Chap4.Translate_Declaration_Chain (Proc); if Flag_Direct_Drivers then @@ -22317,7 +22472,7 @@ package body Translation is Info.Process_Drivers := new Direct_Driver_Arr (1 .. Nbr_Drivers); for I in 1 .. Nbr_Drivers loop Sig := Get_Nth_Element (Drivers, I - 1); - Info.Process_Drivers (I) := (Sig => Sig, Var => null); + Info.Process_Drivers (I) := (Sig => Sig, Var => Null_Var); Sig := Get_Object_Prefix (Sig); if Get_Kind (Sig) /= Iir_Kind_Object_Alias_Declaration and then not Get_After_Drivers_Flag (Sig) @@ -22333,17 +22488,14 @@ package body Translation is end loop; Trans_Analyzes.Free_Drivers_List (Drivers); end if; - Pop_Instance_Factory (Itype); - New_Type_Decl (Create_Identifier ("INSTTYPE"), Itype); + Pop_Instance_Factory (Info.Process_Scope'Access); + New_Type_Decl (Create_Identifier ("INSTTYPE"), + Get_Scope_Type (Info.Process_Scope)); Pop_Identifier_Prefix (Mark); -- Create a field in the parent record. - Field := Add_Instance_Factory_Field - (Create_Identifier_Without_Prefix (Proc), Itype); - - -- Set info in child record. - Info.Process_Decls_Type := Itype; - Info.Process_Parent_Field := Field; + Add_Scope_Field (Create_Identifier_Without_Prefix (Proc), + Info.Process_Scope); end Translate_Process_Declarations; procedure Translate_Psl_Directive_Declarations (Stmt : Iir) @@ -22351,44 +22503,39 @@ package body Translation is use PSL.Nodes; use PSL.NFAs; + N : constant NFA := Get_PSL_NFA (Stmt); + Mark : Id_Mark_Type; Info : Ortho_Info_Acc; - Itype : O_Tnode; - Field : O_Fnode; - - N : NFA; begin + Info := Add_Info (Stmt, Kind_Psl_Directive); + -- Create process record. Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); - Push_Instance_Factory (O_Tnode_Null); - Info := Add_Info (Stmt, Kind_Psl_Directive); + Push_Instance_Factory (Info.Psl_Scope'Access); - N := Get_PSL_NFA (Stmt); Labelize_States (N, Info.Psl_Vect_Len); Info.Psl_Vect_Type := New_Constrained_Array_Type (Std_Boolean_Array_Type, New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Info.Psl_Vect_Len))); New_Type_Decl (Create_Identifier ("VECTTYPE"), Info.Psl_Vect_Type); - Info.Psl_Vect_Var := - Create_Var (Create_Var_Identifier ("VECT"), Info.Psl_Vect_Type); + Info.Psl_Vect_Var := Create_Var + (Create_Var_Identifier ("VECT"), Info.Psl_Vect_Type); if Get_Kind (Stmt) = Iir_Kind_Psl_Cover_Statement then - Info.Psl_Bool_Var := - Create_Var (Create_Var_Identifier ("BOOL"), Ghdl_Bool_Type); + Info.Psl_Bool_Var := Create_Var + (Create_Var_Identifier ("BOOL"), Ghdl_Bool_Type); end if; - Pop_Instance_Factory (Itype); - New_Type_Decl (Create_Identifier ("INSTTYPE"), Itype); + Pop_Instance_Factory (Info.Psl_Scope'Access); + New_Type_Decl (Create_Identifier ("INSTTYPE"), + Get_Scope_Type (Info.Psl_Scope)); Pop_Identifier_Prefix (Mark); -- Create a field in the parent record. - Field := Add_Instance_Factory_Field - (Create_Identifier_Without_Prefix (Stmt), Itype); - - -- Set info in child record. - Info.Psl_Decls_Type := Itype; - Info.Psl_Parent_Field := Field; + Add_Scope_Field + (Create_Identifier_Without_Prefix (Stmt), Info.Psl_Scope); end Translate_Psl_Directive_Declarations; function Translate_Psl_Expr (Expr : PSL_Node; Eos : Boolean) @@ -22506,7 +22653,7 @@ package body Translation is Start_Subprogram_Body (Info.Psl_Proc_Subprg); Push_Local_Factory; -- Push scope for architecture declarations. - Push_Scope (Base.Block_Decls_Type, Instance); + Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance); -- New state vector. New_Var_Decl (Var_Nvec, Wki_Res, O_Storage_Local, Info.Psl_Vect_Type); @@ -22638,7 +22785,7 @@ package body Translation is Close_Temp; Finish_If_Stmt (Clk_Blk); - Pop_Scope (Base.Block_Decls_Type); + Clear_Scope (Base.Block_Scope); Pop_Local_Factory; Finish_Subprogram_Body; @@ -22651,7 +22798,7 @@ package body Translation is Start_Subprogram_Body (Info.Psl_Proc_Final_Subprg); Push_Local_Factory; -- Push scope for architecture declarations. - Push_Scope (Base.Block_Decls_Type, Instance); + Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance); S := Get_Final_State (NFA); E := Get_First_Dest_Edge (S); @@ -22682,7 +22829,7 @@ package body Translation is E := Get_Next_Dest_Edge (E); end loop; - Pop_Scope (Base.Block_Decls_Type); + Clear_Scope (Base.Block_Scope); Pop_Local_Factory; Finish_Subprogram_Body; else @@ -22695,7 +22842,7 @@ package body Translation is Start_Subprogram_Body (Info.Psl_Proc_Final_Subprg); Push_Local_Factory; -- Push scope for architecture declarations. - Push_Scope (Base.Block_Decls_Type, Instance); + Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance); Start_If_Stmt (S_Blk, @@ -22705,7 +22852,7 @@ package body Translation is (Stmt, Ghdl_Psl_Cover_Failed, Severity_Level_Error); Finish_If_Stmt (S_Blk); - Pop_Scope (Base.Block_Decls_Type); + Clear_Scope (Base.Block_Scope); Pop_Local_Factory; Finish_Subprogram_Body; @@ -22743,13 +22890,12 @@ package body Translation is Hdr : Iir_Block_Header; Guard : Iir; Mark : Id_Mark_Type; - Field : O_Fnode; begin Push_Identifier_Prefix (Mark, Get_Identifier (El)); Info := Add_Info (El, Kind_Block); Chap1.Start_Block_Decl (El); - Push_Instance_Factory (Info.Block_Decls_Type); + Push_Instance_Factory (Info.Block_Scope'Access); Guard := Get_Guard_Decl (El); if Guard /= Null_Iir then @@ -22765,26 +22911,22 @@ package body Translation is Chap9.Translate_Block_Declarations (El, Origin); - Pop_Instance_Factory (Info.Block_Decls_Type); + Pop_Instance_Factory (Info.Block_Scope'Access); Pop_Identifier_Prefix (Mark); -- Create a field in the parent record. - Field := Add_Instance_Factory_Field + Add_Scope_Field (Create_Identifier_Without_Prefix (El), - Info.Block_Decls_Type); - -- Set info in child record. - Info.Block_Parent_Field := Field; + Info.Block_Scope); end; when Iir_Kind_Generate_Statement => declare + Scheme : constant Iir := Get_Generation_Scheme (El); Info : Block_Info_Acc; Mark : Id_Mark_Type; - Scheme : Iir; Iter_Type : Iir; It_Info : Ortho_Info_Acc; begin - Scheme := Get_Generation_Scheme (El); - Push_Identifier_Prefix (Mark, Get_Identifier (El)); if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then @@ -22794,7 +22936,7 @@ package body Translation is Info := Add_Info (El, Kind_Block); Chap1.Start_Block_Decl (El); - Push_Instance_Factory (Info.Block_Decls_Type); + Push_Instance_Factory (Info.Block_Scope'Access); -- Add a parent field in the current instance. Info.Block_Origin_Field := Add_Instance_Factory_Field @@ -22815,12 +22957,12 @@ package body Translation is Chap9.Translate_Block_Declarations (El, El); - Pop_Instance_Factory (Info.Block_Decls_Type); + Pop_Instance_Factory (Info.Block_Scope'Access); if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then -- Create array type of block_decls_type Info.Block_Decls_Array_Type := New_Array_Type - (Info.Block_Decls_Type, Ghdl_Index_Type); + (Get_Scope_Type (Info.Block_Scope), Ghdl_Index_Type); New_Type_Decl (Create_Identifier ("INSTARRTYPE"), Info.Block_Decls_Array_Type); -- Create access to the array type. @@ -22851,27 +22993,29 @@ package body Translation is procedure Translate_Component_Instantiation_Subprogram (Stmt : Iir; Base : Block_Info_Acc) is - procedure Set_Component_Link (Ref_Type : O_Tnode; + procedure Set_Component_Link (Ref_Scope : Var_Scope_Type; Comp_Field : O_Fnode) is begin New_Assign_Stmt (New_Selected_Element - (New_Selected_Element (Get_Instance_Ref (Ref_Type), Comp_Field), - Rtis.Ghdl_Component_Link_Stmt), + (New_Selected_Element (Get_Instance_Ref (Ref_Scope), + Comp_Field), + Rtis.Ghdl_Component_Link_Stmt), New_Lit (Rtis.Get_Context_Rti (Stmt))); end Set_Component_Link; - Info : Block_Info_Acc; + Info : constant Block_Info_Acc := Get_Info (Stmt); + + Parent : constant Iir := Get_Parent (Stmt); + Parent_Info : constant Block_Info_Acc := Get_Info (Parent); Comp : Iir; Comp_Info : Comp_Info_Acc; - Parent_Info : Block_Info_Acc; Inter_List : O_Inter_List; Instance : O_Dnode; begin -- Create the elaborator for the instantiation. - Info := Get_Info (Stmt); Start_Procedure_Decl (Inter_List, Create_Identifier ("ELAB"), O_Storage_Private); New_Interface_Decl (Inter_List, Instance, Wki_Instance, @@ -22880,46 +23024,45 @@ package body Translation is Start_Subprogram_Body (Info.Block_Elab_Subprg); Push_Local_Factory; - Push_Scope (Base.Block_Decls_Type, Instance); + Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance); New_Debug_Line_Stmt (Get_Line_Number (Stmt)); - Parent_Info := Get_Info (Get_Parent (Stmt)); - -- Add access to the instantiation-specific data. -- This is used only for anonymous subtype variables. - if Info.Block_Decls_Type /= O_Tnode_Null then - Push_Scope (Info.Block_Decls_Type, - Info.Block_Parent_Field, - Parent_Info.Block_Decls_Type); + if Has_Scope_Type (Info.Block_Scope) then + Set_Scope_Via_Field (Info.Block_Scope, + Info.Block_Parent_Field, + Parent_Info.Block_Scope'Access); end if; Comp := Get_Instantiated_Unit (Stmt); if Is_Entity_Instantiation (Stmt) then -- This is a direct instantiation. - Set_Component_Link (Parent_Info.Block_Decls_Type, + Set_Component_Link (Parent_Info.Block_Scope, Info.Block_Link_Field); Translate_Entity_Instantiation (Comp, Stmt, Stmt, Null_Iir); else Comp := Get_Named_Entity (Comp); Comp_Info := Get_Info (Comp); - Push_Scope (Comp_Info.Comp_Type, Info.Block_Link_Field, - Parent_Info.Block_Decls_Type); + Set_Scope_Via_Field (Comp_Info.Comp_Scope, + Info.Block_Link_Field, + Parent_Info.Block_Scope'Access); -- Set the link from component declaration to component -- instantiation statement. - Set_Component_Link (Comp_Info.Comp_Type, Comp_Info.Comp_Link); + Set_Component_Link (Comp_Info.Comp_Scope, Comp_Info.Comp_Link); Chap5.Elab_Map_Aspect (Stmt, Comp); - Pop_Scope (Comp_Info.Comp_Type); + Clear_Scope (Comp_Info.Comp_Scope); end if; - if Info.Block_Decls_Type /= O_Tnode_Null then - Pop_Scope (Info.Block_Decls_Type); + if Has_Scope_Type (Info.Block_Scope) then + Clear_Scope (Info.Block_Scope); end if; - Pop_Scope (Base.Block_Decls_Type); + Clear_Scope (Base.Block_Scope); Pop_Local_Factory; Finish_Subprogram_Body; end Translate_Component_Instantiation_Subprogram; @@ -22927,58 +23070,35 @@ package body Translation is -- Translate concurrent statements into subprograms. procedure Translate_Block_Subprograms (Block : Iir; Base_Block : Iir) is + Base_Info : constant Block_Info_Acc := Get_Info (Base_Block); Stmt : Iir; Mark : Id_Mark_Type; - Block_Info : Block_Info_Acc; - Base_Info : Block_Info_Acc; begin - Base_Info := Get_Info (Base_Block); + Chap4.Translate_Declaration_Chain_Subprograms (Block); - Chap4.Translate_Declaration_Chain_Subprograms (Block, Base_Block); - - Block_Info := Get_Info (Block); Stmt := Get_Concurrent_Statement_Chain (Block); while Stmt /= Null_Iir loop Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); case Get_Kind (Stmt) is when Iir_Kind_Process_Statement | Iir_Kind_Sensitized_Process_Statement => - declare - Info : Proc_Info_Acc; - begin - Info := Get_Info (Stmt); - Push_Scope (Info.Process_Decls_Type, - Info.Process_Parent_Field, - Block_Info.Block_Decls_Type); - if Flag_Direct_Drivers then - Chap9.Set_Direct_Drivers (Stmt); - end if; + if Flag_Direct_Drivers then + Chap9.Set_Direct_Drivers (Stmt); + end if; - Chap4.Translate_Declaration_Chain_Subprograms - (Stmt, Base_Block); - Translate_Process_Statement (Stmt, Base_Info); + Chap4.Translate_Declaration_Chain_Subprograms (Stmt); + Translate_Process_Statement (Stmt, Base_Info); - if Flag_Direct_Drivers then - Chap9.Reset_Direct_Drivers (Stmt); - end if; - Pop_Scope (Info.Process_Decls_Type); - end; + if Flag_Direct_Drivers then + Chap9.Reset_Direct_Drivers (Stmt); + end if; when Iir_Kind_Psl_Default_Clock => null; when Iir_Kind_Psl_Declaration => null; when Iir_Kind_Psl_Assert_Statement | Iir_Kind_Psl_Cover_Statement => - declare - Info : Psl_Info_Acc; - begin - Info := Get_Info (Stmt); - Push_Scope (Info.Psl_Decls_Type, - Info.Psl_Parent_Field, - Block_Info.Block_Decls_Type); - Translate_Psl_Directive_Statement (Stmt, Base_Info); - Pop_Scope (Info.Psl_Decls_Type); - end; + Translate_Psl_Directive_Statement (Stmt, Base_Info); when Iir_Kind_Component_Instantiation_Statement => Chap4.Translate_Association_Subprograms (Stmt, Block, Base_Block, @@ -22988,41 +23108,32 @@ package body Translation is (Stmt, Base_Info); when Iir_Kind_Block_Statement => declare - Info : Block_Info_Acc; - Guard : Iir; - Hdr : Iir; + Guard : constant Iir := Get_Guard_Decl (Stmt); + Hdr : constant Iir := Get_Block_Header (Stmt); begin - Info := Get_Info (Stmt); - Push_Scope (Info.Block_Decls_Type, - Info.Block_Parent_Field, - Block_Info.Block_Decls_Type); - Guard := Get_Guard_Decl (Stmt); if Guard /= Null_Iir then Translate_Implicit_Guard_Signal (Guard, Base_Info); end if; - Hdr := Get_Block_Header (Stmt); if Hdr /= Null_Iir then Chap4.Translate_Association_Subprograms (Hdr, Block, Base_Block, Null_Iir); end if; Translate_Block_Subprograms (Stmt, Base_Block); - Pop_Scope (Info.Block_Decls_Type); end; when Iir_Kind_Generate_Statement => declare - Info : Block_Info_Acc; + Info : constant Block_Info_Acc := Get_Info (Stmt); Prev_Subprg_Instance : Chap2.Subprg_Instance_Stack; begin - Info := Get_Info (Stmt); - Chap2.Push_Subprg_Instance (Info.Block_Decls_Type, + Chap2.Push_Subprg_Instance (Info.Block_Scope'Access, Info.Block_Decls_Ptr_Type, Wki_Instance, Prev_Subprg_Instance); - Push_Scope_Via_Field_Ptr (Base_Info.Block_Decls_Type, - Info.Block_Origin_Field, - Info.Block_Decls_Type); + Set_Scope_Via_Field_Ptr (Base_Info.Block_Scope, + Info.Block_Origin_Field, + Info.Block_Scope'Access); Translate_Block_Subprograms (Stmt, Stmt); - Pop_Scope (Base_Info.Block_Decls_Type); + Clear_Scope (Base_Info.Block_Scope); Chap2.Pop_Subprg_Instance (Wki_Instance, Prev_Subprg_Instance); end; @@ -23184,33 +23295,21 @@ package body Translation is -- New_Procedure_Call (Constr); -- end Register_Scalar_Direct_Driver; - -- PROC: the process to be elaborated - -- BLOCK_INFO: info for the block containing the process -- BASE_INFO: info for the global block - procedure Elab_Process (Proc : Iir; - Block_Info : Block_Info_Acc; - Base_Info : Block_Info_Acc) + procedure Elab_Process (Proc : Iir; Base_Info : Block_Info_Acc) is - Is_Sensitized : Boolean; + Info : constant Proc_Info_Acc := Get_Info (Proc); + Is_Sensitized : constant Boolean := + Get_Kind (Proc) = Iir_Kind_Sensitized_Process_Statement; Subprg : O_Dnode; Constr : O_Assoc_List; - Info : Proc_Info_Acc; List : Iir_List; List_Orig : Iir_List; Final : Boolean; begin New_Debug_Line_Stmt (Get_Line_Number (Proc)); - Is_Sensitized := - Get_Kind (Proc) = Iir_Kind_Sensitized_Process_Statement; - Info := Get_Info (Proc); - - -- Set instance name. - Push_Scope (Info.Process_Decls_Type, - Info.Process_Parent_Field, - Block_Info.Block_Decls_Type); - -- Register process. if Is_Sensitized then if Get_Postponed_Flag (Proc) then @@ -23229,7 +23328,7 @@ package body Translation is Start_Association (Constr, Subprg); New_Association (Constr, New_Unchecked_Address - (Get_Instance_Ref (Base_Info.Block_Decls_Type), Ghdl_Ptr_Type)); + (Get_Instance_Ref (Base_Info.Block_Scope), Ghdl_Ptr_Type)); New_Association (Constr, New_Lit (New_Subprogram_Address (Info.Process_Subprg, @@ -23257,7 +23356,7 @@ package body Translation is Sig := Info.Process_Drivers (I).Sig; Open_Temp; Base := Get_Object_Prefix (Sig); - if Info.Process_Drivers (I).Var /= null then + if Info.Process_Drivers (I).Var /= Null_Var then -- Elaborate direct driver. Done only once. Chap4.Elab_Direct_Driver_Declaration_Storage (Base); end if; @@ -23299,19 +23398,16 @@ package body Translation is Destroy_Iir_List (List); end if; end if; - - Pop_Scope (Info.Process_Decls_Type); end Elab_Process; -- PROC: the process to be elaborated - -- BLOCK_INFO: info for the block containing the process + -- BLOCK: the block containing the process (its parent) -- BASE_INFO: info for the global block procedure Elab_Psl_Directive (Stmt : Iir; - Block_Info : Block_Info_Acc; Base_Info : Block_Info_Acc) is + Info : constant Psl_Info_Acc := Get_Info (Stmt); Constr : O_Assoc_List; - Info : Psl_Info_Acc; List : Iir_List; Clk : PSL_Node; Var_I : O_Dnode; @@ -23319,18 +23415,11 @@ package body Translation is begin New_Debug_Line_Stmt (Get_Line_Number (Stmt)); - Info := Get_Info (Stmt); - - -- Set instance name. - Push_Scope (Info.Psl_Decls_Type, - Info.Psl_Parent_Field, - Block_Info.Block_Decls_Type); - -- Register process. Start_Association (Constr, Ghdl_Sensitized_Process_Register); New_Association (Constr, New_Unchecked_Address - (Get_Instance_Ref (Base_Info.Block_Decls_Type), Ghdl_Ptr_Type)); + (Get_Instance_Ref (Base_Info.Block_Scope), Ghdl_Ptr_Type)); New_Association (Constr, New_Lit (New_Subprogram_Address (Info.Psl_Proc_Subprg, @@ -23351,7 +23440,7 @@ package body Translation is Start_Association (Constr, Ghdl_Finalize_Register); New_Association (Constr, New_Unchecked_Address - (Get_Instance_Ref (Base_Info.Block_Decls_Type), + (Get_Instance_Ref (Base_Info.Block_Scope), Ghdl_Ptr_Type)); New_Association (Constr, @@ -23383,12 +23472,10 @@ package body Translation is Finish_Loop_Stmt (Label); Finish_Declare_Stmt; - if Info.Psl_Bool_Var /= null then + if Info.Psl_Bool_Var /= Null_Var then New_Assign_Stmt (Get_Var (Info.Psl_Bool_Var), New_Lit (Ghdl_Bool_False_Node)); end if; - - Pop_Scope (Info.Psl_Decls_Type); end Elab_Psl_Directive; procedure Elab_Implicit_Guard_Signal @@ -23406,7 +23493,7 @@ package body Translation is Start_Association (Constr, Ghdl_Signal_Create_Guard); New_Association (Constr, New_Unchecked_Address - (Get_Instance_Ref (Block_Info.Block_Decls_Type), Ghdl_Ptr_Type)); + (Get_Instance_Ref (Block_Info.Block_Scope), Ghdl_Ptr_Type)); New_Association (Constr, New_Lit (New_Subprogram_Address (Info.Object_Function, @@ -23553,47 +23640,47 @@ package body Translation is -- 1.5) link instance. declare - procedure Set_Links (Ref_Type : O_Tnode; Link_Field : O_Fnode) + procedure Set_Links (Ref_Scope : Var_Scope_Type; + Link_Field : O_Fnode) is begin -- Set the ghdl_component_link_instance field. New_Assign_Stmt (New_Selected_Element - (New_Selected_Element (Get_Instance_Ref (Ref_Type), - Link_Field), - Rtis.Ghdl_Component_Link_Instance), + (New_Selected_Element (Get_Instance_Ref (Ref_Scope), + Link_Field), + Rtis.Ghdl_Component_Link_Instance), New_Address (New_Selected_Acc_Value - (New_Obj (Var_Sub), - Entity_Info.Block_Link_Field), + (New_Obj (Var_Sub), + Entity_Info.Block_Link_Field), Rtis.Ghdl_Entity_Link_Acc)); -- Set the ghdl_entity_link_parent field. New_Assign_Stmt (New_Selected_Element - (New_Selected_Acc_Value (New_Obj (Var_Sub), - Entity_Info.Block_Link_Field), - Rtis.Ghdl_Entity_Link_Parent), + (New_Selected_Acc_Value (New_Obj (Var_Sub), + Entity_Info.Block_Link_Field), + Rtis.Ghdl_Entity_Link_Parent), New_Address - (New_Selected_Element (Get_Instance_Ref (Ref_Type), - Link_Field), - Rtis.Ghdl_Component_Link_Acc)); + (New_Selected_Element (Get_Instance_Ref (Ref_Scope), + Link_Field), + Rtis.Ghdl_Component_Link_Acc)); end Set_Links; begin case Get_Kind (Parent) is when Iir_Kind_Component_Declaration => -- Instantiation via a component declaration. declare - Comp_Info : Comp_Info_Acc; + Comp_Info : constant Comp_Info_Acc := Get_Info (Parent); begin - Comp_Info := Get_Info (Parent); - Set_Links (Comp_Info.Comp_Type, Comp_Info.Comp_Link); + Set_Links (Comp_Info.Comp_Scope, Comp_Info.Comp_Link); end; when Iir_Kind_Component_Instantiation_Statement => -- Direct instantiation. declare - Parent_Info : Block_Info_Acc; + Parent_Info : constant Block_Info_Acc := + Get_Info (Get_Parent (Parent)); begin - Parent_Info := Get_Info (Get_Parent (Parent)); - Set_Links (Parent_Info.Block_Decls_Type, + Set_Links (Parent_Info.Block_Scope, Get_Info (Parent).Block_Link_Field); end; when others => @@ -23610,9 +23697,9 @@ package body Translation is end; -- Elab map aspects. - Push_Scope (Entity_Info.Block_Decls_Type, Var_Sub); + Set_Scope_Via_Param_Ptr (Entity_Info.Block_Scope, Var_Sub); Chap5.Elab_Map_Aspect (Mapping, Entity); - Pop_Scope (Entity_Info.Block_Decls_Type); + Clear_Scope (Entity_Info.Block_Scope); -- 3) Elab instance. declare @@ -23637,18 +23724,13 @@ package body Translation is procedure Elab_Conditionnal_Generate_Statement (Stmt : Iir_Generate_Statement; Parent : Iir; Base_Block : Iir) is - Scheme : Iir; - Info : Block_Info_Acc; + Scheme : constant Iir := Get_Generation_Scheme (Stmt); + Info : constant Block_Info_Acc := Get_Info (Stmt); + Parent_Info : constant Block_Info_Acc := Get_Info (Parent); Var : O_Dnode; Blk : O_If_Block; V : O_Lnode; - Parent_Info : Block_Info_Acc; - Base_Info : Block_Info_Acc; begin - Parent_Info := Get_Info (Parent); - Base_Info := Get_Info (Base_Block); - Scheme := Get_Generation_Scheme (Stmt); - Info := Get_Info (Stmt); Open_Temp; Var := Create_Temp (Info.Block_Decls_Ptr_Type); @@ -23656,8 +23738,7 @@ package body Translation is New_Assign_Stmt (New_Obj (Var), Gen_Alloc (Alloc_System, - New_Lit (New_Sizeof (Info.Block_Decls_Type, - Ghdl_Index_Type)), + New_Lit (Get_Scope_Size (Info.Block_Scope)), Info.Block_Decls_Ptr_Type)); New_Else_Stmt (Blk); New_Assign_Stmt @@ -23666,7 +23747,7 @@ package body Translation is Finish_If_Stmt (Blk); -- Add a link to child in parent. - V := Get_Instance_Ref (Parent_Info.Block_Decls_Type); + V := Get_Instance_Ref (Parent_Info.Block_Scope); V := New_Selected_Element (V, Info.Block_Parent_Field); New_Assign_Stmt (V, New_Obj_Value (Var)); @@ -23682,13 +23763,9 @@ package body Translation is (New_Selected_Acc_Value (New_Obj (Var), Info.Block_Origin_Field), Get_Instance_Access (Base_Block)); -- Elaborate block - Push_Scope (Info.Block_Decls_Type, Var); - Push_Scope_Via_Field_Ptr (Base_Info.Block_Decls_Type, - Info.Block_Origin_Field, - Info.Block_Decls_Type); + Set_Scope_Via_Param_Ptr (Info.Block_Scope, Var); Elab_Block_Declarations (Stmt, Stmt); - Pop_Scope (Base_Info.Block_Decls_Type); - Pop_Scope (Info.Block_Decls_Type); + Clear_Scope (Info.Block_Scope); Finish_If_Stmt (Blk); Close_Temp; end Elab_Conditionnal_Generate_Statement; @@ -23696,29 +23773,20 @@ package body Translation is procedure Elab_Iterative_Generate_Statement (Stmt : Iir_Generate_Statement; Parent : Iir; Base_Block : Iir) is - Scheme : Iir; - Iter_Type : Iir; - Iter_Base_Type : Iir; - Iter_Type_Info : Type_Info_Acc; - Info : Block_Info_Acc; + Scheme : constant Iir := Get_Generation_Scheme (Stmt); + Iter_Type : constant Iir := Get_Type (Scheme); + Iter_Base_Type : constant Iir := Get_Base_Type (Iter_Type); + Iter_Type_Info : constant Type_Info_Acc := Get_Info (Iter_Base_Type); + Info : constant Block_Info_Acc := Get_Info (Stmt); + Parent_Info : constant Block_Info_Acc := Get_Info (Parent); +-- Base_Info : constant Block_Info_Acc := Get_Info (Base_Block); Var_Inst : O_Dnode; Var_I : O_Dnode; Label : O_Snode; V : O_Lnode; Var : O_Dnode; - Parent_Info : Block_Info_Acc; - Base_Info : Block_Info_Acc; Range_Ptr : O_Dnode; begin - Parent_Info := Get_Info (Parent); - Base_Info := Get_Info (Base_Block); - - Scheme := Get_Generation_Scheme (Stmt); - Iter_Type := Get_Type (Scheme); - Iter_Base_Type := Get_Base_Type (Iter_Type); - Iter_Type_Info := Get_Info (Iter_Base_Type); - Info := Get_Info (Stmt); - Open_Temp; -- Evaluate iterator range. @@ -23738,12 +23806,11 @@ package body Translation is New_Value_Selected_Acc_Value (New_Obj (Range_Ptr), Iter_Type_Info.T.Range_Length), - New_Lit (New_Sizeof (Info.Block_Decls_Type, - Ghdl_Index_Type))), + New_Lit (Get_Scope_Size (Info.Block_Scope))), Info.Block_Decls_Array_Ptr_Type)); -- Add a link to child in parent. - V := Get_Instance_Ref (Parent_Info.Block_Decls_Type); + V := Get_Instance_Ref (Parent_Info.Block_Scope); V := New_Selected_Element (V, Info.Block_Parent_Field); New_Assign_Stmt (V, New_Obj_Value (Var_Inst)); @@ -23775,10 +23842,11 @@ package body Translation is New_Lit (Ghdl_Bool_False_Node)); -- Elaborate block - Push_Scope (Info.Block_Decls_Type, Var); - Push_Scope_Via_Field_Ptr (Base_Info.Block_Decls_Type, - Info.Block_Origin_Field, - Info.Block_Decls_Type); + Set_Scope_Via_Param_Ptr (Info.Block_Scope, Var); + -- Set_Scope_Via_Field_Ptr (Base_Info.Block_Scope, + -- Info.Block_Origin_Field, + -- Info.Block_Scope'Access); + -- Set iterator value. -- FIXME: this could be slighly optimized... declare @@ -23815,8 +23883,8 @@ package body Translation is -- Elaboration. Elab_Block_Declarations (Stmt, Stmt); - Pop_Scope (Base_Info.Block_Decls_Type); - Pop_Scope (Info.Block_Decls_Type); +-- Clear_Scope (Base_Info.Block_Scope); + Clear_Scope (Info.Block_Scope); Inc_Var (Var_I); Finish_Loop_Stmt (Label); @@ -24020,14 +24088,10 @@ package body Translation is procedure Elab_Block_Declarations (Block : Iir; Base_Block : Iir) is - Block_Info : Block_Info_Acc; - Base_Info : Block_Info_Acc; + Base_Info : constant Block_Info_Acc := Get_Info (Base_Block); Stmt : Iir; Final : Boolean; begin - Block_Info := Get_Info (Block); - Base_Info := Get_Info (Base_Block); - New_Debug_Line_Stmt (Get_Line_Number (Block)); case Get_Kind (Block) is @@ -24037,15 +24101,14 @@ package body Translation is null; when Iir_Kind_Block_Statement => declare - Header : Iir_Block_Header; - Guard : Iir; + Header : constant Iir_Block_Header := + Get_Block_Header (Block); + Guard : constant Iir := Get_Guard_Decl (Block); begin - Guard := Get_Guard_Decl (Block); if Guard /= Null_Iir then New_Debug_Line_Stmt (Get_Line_Number (Guard)); Elab_Implicit_Guard_Signal (Block, Base_Info); end if; - Header := Get_Block_Header (Block); if Header /= Null_Iir then New_Debug_Line_Stmt (Get_Line_Number (Header)); Chap5.Elab_Map_Aspect (Header, Block); @@ -24067,38 +24130,30 @@ package body Translation is case Get_Kind (Stmt) is when Iir_Kind_Process_Statement | Iir_Kind_Sensitized_Process_Statement => - Elab_Process (Stmt, Block_Info, Base_Info); + Elab_Process (Stmt, Base_Info); when Iir_Kind_Psl_Default_Clock => null; when Iir_Kind_Psl_Declaration => null; when Iir_Kind_Psl_Assert_Statement | Iir_Kind_Psl_Cover_Statement => - Elab_Psl_Directive (Stmt, Block_Info, Base_Info); + Elab_Psl_Directive (Stmt, Base_Info); when Iir_Kind_Component_Instantiation_Statement => declare - Info : Block_Info_Acc; + Info : constant Block_Info_Acc := Get_Info (Stmt); Constr : O_Assoc_List; begin - Info := Get_Info (Stmt); Start_Association (Constr, Info.Block_Elab_Subprg); New_Association (Constr, Get_Instance_Access (Base_Block)); New_Procedure_Call (Constr); end; - --Elab_Component_Instantiation (Stmt, Block_Info); when Iir_Kind_Block_Statement => declare - Info : Block_Info_Acc; Mark : Id_Mark_Type; begin Push_Identifier_Prefix (Mark, Get_Identifier (Stmt)); - Info := Get_Info (Stmt); - Push_Scope (Info.Block_Decls_Type, - Info.Block_Parent_Field, - Block_Info.Block_Decls_Type); Elab_Block_Declarations (Stmt, Base_Block); - Pop_Scope (Info.Block_Decls_Type); Pop_Identifier_Prefix (Mark); end; when Iir_Kind_Generate_Statement => @@ -24154,29 +24209,39 @@ package body Translation is Unchecked_Deallocation (Old); end Pop_Build_Instance; --- procedure Push_Global_Factory (Storage : O_Storage) --- is --- Inst : Inst_Build_Acc; --- begin --- if Inst_Build /= null then --- raise Internal_Error; --- end if; --- Inst := new Inst_Build_Type (Global); --- Inst.Prev := Inst_Build; --- Inst_Build := Inst; --- Global_Storage := Storage; --- end Push_Global_Factory; + function Get_Scope_Type (Scope : Var_Scope_Type) return O_Tnode is + begin + pragma Assert (Scope.Scope_Type /= O_Tnode_Null); + return Scope.Scope_Type; + end Get_Scope_Type; --- procedure Pop_Global_Factory is --- begin --- if Inst_Build.Kind /= Global then --- raise Internal_Error; --- end if; --- Pop_Build_Instance; --- Global_Storage := O_Storage_Private; --- end Pop_Global_Factory; + function Get_Scope_Size (Scope : Var_Scope_Type) return O_Cnode is + begin + pragma Assert (Scope.Scope_Type /= O_Tnode_Null); + return New_Sizeof (Scope.Scope_Type, Ghdl_Index_Type); + end Get_Scope_Size; - procedure Push_Instance_Factory (Instance_Type : O_Tnode) + function Has_Scope_Type (Scope : Var_Scope_Type) return Boolean is + begin + return Scope.Scope_Type /= O_Tnode_Null; + end Has_Scope_Type; + + procedure Predeclare_Scope_Type (Scope : Var_Scope_Acc; Name : O_Ident) + is + begin + pragma Assert (Scope.Scope_Type = O_Tnode_Null); + New_Uncomplete_Record_Type (Scope.Scope_Type); + New_Type_Decl (Name, Scope.Scope_Type); + end Predeclare_Scope_Type; + + procedure Declare_Scope_Acc + (Scope : Var_Scope_Type; Name : O_Ident; Ptr_Type : out O_Tnode) is + begin + Ptr_Type := New_Access_Type (Get_Scope_Type (Scope)); + New_Type_Decl (Name, Ptr_Type); + end Declare_Scope_Acc; + + procedure Push_Instance_Factory (Scope : Var_Scope_Acc) is Inst : Inst_Build_Acc; begin @@ -24185,16 +24250,16 @@ package body Translation is end if; Inst := new Inst_Build_Type (Instance); Inst.Prev := Inst_Build; - Inst.Prev_Id_Start := Identifier_Start; + Inst.Scope := Scope; + Identifier_Start := Identifier_Len + 1; - if Instance_Type /= O_Tnode_Null then - Start_Uncomplete_Record_Type (Instance_Type, Inst.Elements); + if Scope.Scope_Type /= O_Tnode_Null then + Start_Uncomplete_Record_Type (Scope.Scope_Type, Inst.Elements); else Start_Record_Type (Inst.Elements); end if; - Inst.Vars := null; Inst_Build := Inst; end Push_Instance_Factory; @@ -24207,24 +24272,33 @@ package body Translation is return Res; end Add_Instance_Factory_Field; - procedure Pop_Instance_Factory (Instance_Type : out O_Tnode) + procedure Add_Scope_Field + (Name : O_Ident; Child : in out Var_Scope_Type) + is + Field : O_Fnode; + begin + Field := Add_Instance_Factory_Field (Name, Get_Scope_Type (Child)); + Set_Scope_Via_Field (Child, Field, Inst_Build.Scope); + end Add_Scope_Field; + + function Get_Scope_Offset (Child : Var_Scope_Type; Otype : O_Tnode) + return O_Cnode is + begin + return New_Offsetof (Get_Scope_Type (Child.Up_Link.all), + Child.Field, Otype); + end Get_Scope_Offset; + + procedure Pop_Instance_Factory (Scope : in Var_Scope_Acc) is Res : O_Tnode; - V : Var_Acc; begin if Inst_Build.Kind /= Instance then -- Not matching. raise Internal_Error; end if; Finish_Record_Type (Inst_Build.Elements, Res); - -- Set type of all variable declared in this instance. - V := Inst_Build.Vars; - while V /= null loop - V.I_Type := Res; - V := V.I_Link; - end loop; Pop_Build_Instance; - Instance_Type := Res; + Scope.Scope_Type := Res; end Pop_Instance_Factory; procedure Push_Local_Factory @@ -24281,136 +24355,56 @@ package body Translation is Pop_Build_Instance; end Pop_Local_Factory; - type Scope_Type; - type Scope_Acc is access Scope_Type; - - type Scope_Type is record - -- True if the instance is a pointer. - Is_Ptr : Boolean; - - -- Type of the scope. - Stype : O_Tnode; - - -- Scope is within FIELD of scope PARENT. - Field : O_Fnode; - Parent : O_Tnode; - - -- Previous scope in the stack. - Prev : Scope_Acc; - end record; - - type Scope_Var_Type; - type Scope_Var_Acc is access Scope_Var_Type; - - type Scope_Var_Type is record - -- Type of the scope. - Svtype : O_Tnode; - - -- Variable containing the reference of the scope. - Var : O_Dnode; - - -- Previous variable in the stack. - Prev : Scope_Var_Acc; - end record; - - Scopes : Scope_Acc := null; - -- Chained list of unused scopes, in order to reduce number of - -- dynamic allocation. - Scopes_Old : Scope_Acc := null; - - Scopes_Var : Scope_Var_Acc := null; - -- Chained list of unused var_scopes, to reduce number of allocations. - Scopes_Var_Old : Scope_Var_Acc := null; + procedure Set_Scope_Via_Field + (Scope : in out Var_Scope_Type; + Scope_Field : O_Fnode; Scope_Parent : Var_Scope_Acc) is + begin + pragma Assert (Scope.Kind = Var_Scope_None); + Scope := (Scope_Type => Scope.Scope_Type, + Kind => Var_Scope_Field, + Field => Scope_Field, Up_Link => Scope_Parent); + end Set_Scope_Via_Field; - -- Get a scope, either from the list of free scope or by allocation. - function Get_A_Scope return Scope_Acc is - Res : Scope_Acc; + procedure Set_Scope_Via_Field_Ptr + (Scope : in out Var_Scope_Type; + Scope_Field : O_Fnode; Scope_Parent : Var_Scope_Acc) is begin - if Scopes_Old /= null then - Res := Scopes_Old; - Scopes_Old := Scopes_Old.Prev; - else - Res := new Chap10.Scope_Type; - end if; - return Res; - end Get_A_Scope; + pragma Assert (Scope.Kind = Var_Scope_None); + Scope := (Scope_Type => Scope.Scope_Type, + Kind => Var_Scope_Field_Ptr, + Field => Scope_Field, Up_Link => Scope_Parent); + end Set_Scope_Via_Field_Ptr; - procedure Push_Scope (Scope_Type : O_Tnode; - Scope_Field : O_Fnode; Scope_Parent : O_Tnode) - is - Res : Scope_Acc; + procedure Set_Scope_Via_Param_Ptr + (Scope : in out Var_Scope_Type; Scope_Param : O_Dnode) is begin - Res := Get_A_Scope; - -- FIXME: check that Scope_Parent can be reached ? - Res.all := (Is_Ptr => False, - Stype => Scope_Type, - Field => Scope_Field, - Parent => Scope_Parent, - Prev => Scopes); - Scopes := Res; - end Push_Scope; + pragma Assert (Scope.Kind = Var_Scope_None); + Scope := (Scope_Type => Scope.Scope_Type, + Kind => Var_Scope_Ptr, D => Scope_Param); + end Set_Scope_Via_Param_Ptr; - procedure Push_Scope_Via_Field_Ptr - (Scope_Type : O_Tnode; - Scope_Field : O_Fnode; Scope_Parent : O_Tnode) - is - Res : Scope_Acc; + procedure Set_Scope_Via_Decl + (Scope : in out Var_Scope_Type; Decl : O_Dnode) is begin - Res := Get_A_Scope; - Res.all := (Is_Ptr => True, - Stype => Scope_Type, - Field => Scope_Field, - Parent => Scope_Parent, - Prev => Scopes); - Scopes := Res; - end Push_Scope_Via_Field_Ptr; + pragma Assert (Scope.Kind = Var_Scope_None); + Scope := (Scope_Type => Scope.Scope_Type, + Kind => Var_Scope_Decl, D => Decl); + end Set_Scope_Via_Decl; - procedure Push_Scope (Scope_Type : O_Tnode; Scope_Param : O_Dnode) - is - Res : Scope_Var_Acc; + procedure Clear_Scope (Scope : in out Var_Scope_Type) is begin - if Scopes_Var_Old /= null then - Res := Scopes_Var_Old; - Scopes_Var_Old := Res.Prev; - else - Res := new Scope_Var_Type; - end if; - Res.all := (Svtype => Scope_Type, - Var => Scope_Param, - Prev => Scopes_Var); - Scopes_Var := Res; - end Push_Scope; - - procedure Pop_Scope (Scope_Type : O_Tnode) - is - Old : Scope_Acc; - Var_Old : Scope_Var_Acc; - begin - -- Search in var scope. - if Scopes_Var /= null and then Scopes_Var.Svtype = Scope_Type then - Var_Old := Scopes_Var; - Scopes_Var := Var_Old.Prev; - Var_Old.Prev := Scopes_Var_Old; - Scopes_Var_Old := Var_Old; - elsif Scopes.Stype /= Scope_Type then - -- Bad pop order. - raise Internal_Error; - else - Old := Scopes; - Scopes := Old.Prev; - Old.Prev := Scopes_Old; - Scopes_Old := Old; - end if; - end Pop_Scope; + pragma Assert (Scope.Kind /= Var_Scope_None); + Scope := (Scope_Type => Scope.Scope_Type, Kind => Var_Scope_None); + end Clear_Scope; function Create_Global_Var (Name : O_Ident; Vtype : O_Tnode; Storage : O_Storage) - return Var_Acc + return Var_Type is Var : O_Dnode; begin New_Var_Decl (Var, Name, Storage, Vtype); - return new Var_Type'(Kind => Var_Global, E => Var); + return Var_Type'(Kind => Var_Global, E => Var); end Create_Global_Var; function Create_Global_Const @@ -24418,7 +24412,7 @@ package body Translation is Vtype : O_Tnode; Storage : O_Storage; Initial_Value : O_Cnode) - return Var_Acc + return Var_Type is Res : O_Dnode; begin @@ -24429,10 +24423,10 @@ package body Translation is Start_Const_Value (Res); Finish_Const_Value (Res, Initial_Value); end if; - return new Var_Type'(Kind => Var_Global, E => Res); + return Var_Type'(Kind => Var_Global, E => Res); end Create_Global_Const; - procedure Define_Global_Const (Const : Var_Acc; Val : O_Cnode) is + procedure Define_Global_Const (Const : in out Var_Type; Val : O_Cnode) is begin Start_Const_Value (Const.E); Finish_Const_Value (Const.E, Val); @@ -24442,11 +24436,10 @@ package body Translation is (Name : Var_Ident_Type; Vtype : O_Tnode; Storage : O_Storage := Global_Storage) - return Var_Acc + return Var_Type is Res : O_Dnode; Field : O_Fnode; - V : Var_Acc; K : Inst_Build_Kind_Type; begin if Inst_Build = null then @@ -24462,58 +24455,43 @@ package body Translation is -- It is always possible to create a variable in a local scope. -- Create a var. New_Var_Decl (Res, Name.Id, O_Storage_Local, Vtype); - return new Var_Type'(Kind => Var_Local, E => Res); + return Var_Type'(Kind => Var_Local, E => Res); when Instance => -- Create a field. New_Record_Field (Inst_Build.Elements, Field, Name.Id, Vtype); - V := new Var_Type'(Kind => Var_Scope, I_Field => Field, - I_Type => O_Tnode_Null, - I_Link => Inst_Build.Vars); - Inst_Build.Vars := V; - return V; + return Var_Type'(Kind => Var_Scope, I_Field => Field, + I_Scope => Inst_Build.Scope); end case; end Create_Var; -- Get a reference to scope STYPE. If IS_PTR is set, RES is an access -- to the scope, otherwise RES directly designates the scope. - procedure Find_Scope_Type (Stype : O_Tnode; - Res : out O_Lnode; - Is_Ptr : out Boolean) - is - S : Scope_Acc; - Sv : Scope_Var_Acc; - Prev_Res : O_Lnode; - Prev_Ptr : Boolean; - begin - -- Find in var. - Sv := Scopes_Var; - while Sv /= null loop - if Sv.Svtype = Stype then - Res := New_Obj (Sv.Var); - Is_Ptr := True; - return; - end if; - Sv := Sv.Prev; - end loop; - - -- Find in fields. - S := Scopes; - while S /= null loop - if S.Stype = Stype then - Find_Scope_Type (S.Parent, Prev_Res, Prev_Ptr); - if Prev_Ptr then - Prev_Res := New_Acc_Value (Prev_Res); - end if; - Res := New_Selected_Element (Prev_Res, S.Field); - Is_Ptr := S.Is_Ptr; - return; - end if; - S := S.Prev; - end loop; - - -- Not found. - raise Internal_Error; - end Find_Scope_Type; + procedure Find_Scope (Scope : Var_Scope_Type; + Res : out O_Lnode; + Is_Ptr : out Boolean) is + begin + case Scope.Kind is + when Var_Scope_None => + raise Internal_Error; + when Var_Scope_Ptr + | Var_Scope_Decl => + Res := New_Obj (Scope.D); + Is_Ptr := Scope.Kind = Var_Scope_Ptr; + when Var_Scope_Field + | Var_Scope_Field_Ptr => + declare + Parent : O_Lnode; + Parent_Ptr : Boolean; + begin + Find_Scope (Scope.Up_Link.all, Parent, Parent_Ptr); + if Parent_Ptr then + Parent := New_Acc_Value (Parent); + end if; + Res := New_Selected_Element (Parent, Scope.Field); + Is_Ptr := Scope.Kind = Var_Scope_Field_Ptr; + end; + end case; + end Find_Scope; procedure Check_Not_Building is begin @@ -24531,7 +24509,7 @@ package body Translation is Is_Ptr : Boolean; begin Check_Not_Building; - Find_Scope_Type (Info.Block_Decls_Type, Res, Is_Ptr); + Find_Scope (Info.Block_Scope, Res, Is_Ptr); if Is_Ptr then return New_Value (Res); else @@ -24539,13 +24517,13 @@ package body Translation is end if; end Get_Instance_Access; - function Get_Instance_Ref (Itype : O_Tnode) return O_Lnode + function Get_Instance_Ref (Scope : Var_Scope_Type) return O_Lnode is Res : O_Lnode; Is_Ptr : Boolean; begin Check_Not_Building; - Find_Scope_Type (Itype, Res, Is_Ptr); + Find_Scope (Scope, Res, Is_Ptr); if Is_Ptr then return New_Acc_Value (Res); else @@ -24553,22 +24531,23 @@ package body Translation is end if; end Get_Instance_Ref; - function Get_Var (Var : Var_Acc) return O_Lnode + function Get_Var (Var : Var_Type) return O_Lnode is begin case Var.Kind is + when Var_None => + raise Internal_Error; when Var_Local | Var_Global => return New_Obj (Var.E); when Var_Scope => - null; + return New_Selected_Element + (Get_Instance_Ref (Var.I_Scope.all), Var.I_Field); end case; - - return New_Selected_Element (Get_Instance_Ref (Var.I_Type), - Var.I_Field); end Get_Var; - function Get_Alloc_Kind_For_Var (Var : Var_Acc) return Allocation_Kind is + function Get_Alloc_Kind_For_Var (Var : Var_Type) + return Allocation_Kind is begin case Var.Kind is when Var_Local => @@ -24576,10 +24555,12 @@ package body Translation is when Var_Global | Var_Scope => return Alloc_System; + when Var_None => + raise Internal_Error; end case; end Get_Alloc_Kind_For_Var; - function Is_Var_Stable (Var : Var_Acc) return Boolean is + function Is_Var_Stable (Var : Var_Type) return Boolean is begin case Var.Kind is when Var_Local @@ -24587,10 +24568,12 @@ package body Translation is return True; when Var_Scope => return False; + when Var_None => + raise Internal_Error; end case; end Is_Var_Stable; - function Is_Var_Field (Var : Var_Acc) return Boolean is + function Is_Var_Field (Var : Var_Type) return Boolean is begin case Var.Kind is when Var_Local @@ -24598,50 +24581,30 @@ package body Translation is return False; when Var_Scope => return True; + when Var_None => + raise Internal_Error; end case; end Is_Var_Field; - function Get_Var_Field (Var : Var_Acc) return O_Fnode is + function Get_Var_Offset (Var : Var_Type; Otype : O_Tnode) return O_Cnode + is begin - case Var.Kind is - when Var_Local - | Var_Global => - raise Internal_Error; - when Var_Scope => - return Var.I_Field; - end case; - end Get_Var_Field; + return New_Offsetof (Get_Scope_Type (Var.I_Scope.all), + Var.I_Field, Otype); + end Get_Var_Offset; - function Get_Var_Record (Var : Var_Acc) return O_Tnode is - begin - case Var.Kind is - when Var_Local - | Var_Global => - raise Internal_Error; - when Var_Scope => - return Var.I_Type; - end case; - end Get_Var_Record; - - function Get_Var_Label (Var : Var_Acc) return O_Dnode is + function Get_Var_Label (Var : Var_Type) return O_Dnode is begin case Var.Kind is when Var_Local | Var_Global => return Var.E; - when Var_Scope => + when Var_Scope + | Var_None => raise Internal_Error; end case; end Get_Var_Label; - procedure Free_Var (Var : in out Var_Acc) - is - procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation - (Var_Type, Var_Acc); - begin - Unchecked_Deallocation (Var); - end Free_Var; - procedure Save_Local_Identifier (Id : out Local_Identifier_Type) is begin Id := Identifier_Local; @@ -26615,10 +26578,10 @@ package body Translation is Cur_Block := Prev; end Pop_Rti_Node; - function Get_Depth_From_Var (Var : Var_Acc := null) return Rti_Depth_Type + function Get_Depth_From_Var (Var : Var_Type) return Rti_Depth_Type is begin - if Var = null or else Is_Var_Field (Var) then + if Var = Null_Var or else Is_Var_Field (Var) then return Cur_Block.Depth; else return 0; @@ -26626,7 +26589,7 @@ package body Translation is end Get_Depth_From_Var; function Generate_Common - (Kind : O_Cnode; Var : Var_Acc := null; Mode : Natural := 0) + (Kind : O_Cnode; Var : Var_Type := Null_Var; Mode : Natural := 0) return O_Cnode is List : O_Record_Aggr_List; @@ -26691,13 +26654,11 @@ package body Translation is return New_Null_Access (Ghdl_Ptr_Type); end Get_Null_Loc; - function Var_Acc_To_Loc (Var : Var_Acc) return O_Cnode + function Var_Acc_To_Loc (Var : Var_Type) return O_Cnode is begin if Is_Var_Field (Var) then - return New_Offsetof (Get_Var_Record (Var), - Get_Var_Field (Var), - Ghdl_Ptr_Type); + return Get_Var_Offset (Var, Ghdl_Ptr_Type); else return New_Global_Unchecked_Address (Get_Var_Label (Var), Ghdl_Ptr_Type); @@ -27213,7 +27174,7 @@ package body Translation is Val : O_Cnode; Base_Rti : O_Dnode; pragma Unreferenced (Base_Rti); - Bounds : Var_Acc; + Bounds : Var_Type; Name : O_Dnode; Kind : O_Cnode; Mark : Id_Mark_Type; @@ -27264,7 +27225,7 @@ package body Translation is (Kind, Depth, Info.T.Rti_Max_Depth, Type_To_Mode (Atype))); New_Record_Aggr_El (Aggr, New_Name_Address (Name)); New_Record_Aggr_El (Aggr, New_Rti_Address (Base_Info.Type_Rti)); - if Bounds = null then + if Bounds = Null_Var then Val := Get_Null_Loc; else Val := Var_Acc_To_Loc (Bounds); @@ -27276,7 +27237,7 @@ package body Translation is Val := Get_Null_Loc; if Info.Ortho_Type (I) /= O_Tnode_Null then if Is_Complex_Type (Info) then - if Info.C (I).Size_Var /= null then + if Info.C (I).Size_Var /= Null_Var then Val := Var_Acc_To_Loc (Info.C (I).Size_Var); end if; else @@ -27533,7 +27494,7 @@ package body Translation is List : O_Record_Aggr_List; Info : Ortho_Info_Acc; Mark : Id_Mark_Type; - Var : Var_Acc; + Var : Var_Type; Mode : Natural; Has_Id : Boolean; begin @@ -27608,7 +27569,7 @@ package body Translation is Var := Info.Object_Var; when Iir_Kind_Attribute_Declaration => Comm := Ghdl_Rtik_Attribute; - Var := null; + Var := Null_Var; when Iir_Kind_Transaction_Attribute => Comm := Ghdl_Rtik_Attribute_Transaction; Var := Info.Object_Var; @@ -27649,7 +27610,7 @@ package body Translation is end case; New_Record_Aggr_El (List, Generate_Common (Comm, Var, Mode)); New_Record_Aggr_El (List, New_Name_Address (Name)); - if Var = null then + if Var = Null_Var then Val := Get_Null_Loc; else Val := Var_Acc_To_Loc (Var); @@ -27810,7 +27771,8 @@ package body Translation is New_Record_Aggr_El (List, Generate_Common (Ghdl_Rtik_Instance)); New_Record_Aggr_El (List, New_Global_Address (Name, Char_Ptr_Type)); New_Record_Aggr_El - (List, New_Offsetof (Get_Info (Get_Parent (Stmt)).Block_Decls_Type, + (List, New_Offsetof (Get_Scope_Type + (Get_Info (Get_Parent (Stmt)).Block_Scope), Info.Block_Link_Field, Ghdl_Ptr_Type)); New_Record_Aggr_El (List, New_Rti_Address (Parent)); @@ -27991,8 +27953,7 @@ package body Translation is Prev : Rti_Block; Info : Ortho_Info_Acc; - Field : O_Fnode; - Field_Parent : O_Tnode; + Field_Off : O_Cnode; Inst : O_Tnode; begin -- The type of a generator iterator is elaborated in the parent. @@ -28022,7 +27983,7 @@ package body Translation is O_Storage_Public, Ghdl_Rtin_Block); Push_Rti_Node (Prev); - Field := O_Fnode_Null; + Field_Off := O_Cnode_Null; Inst := O_Tnode_Null; Info := Get_Info (Blk); case Get_Kind (Blk) is @@ -28038,9 +27999,10 @@ package body Translation is Generate_Declaration_Chain (Get_Declaration_Chain (Blk)); Generate_Concurrent_Statement_Chain (Get_Concurrent_Statement_Chain (Blk), Rti); - Field := Info.Block_Parent_Field; - Inst := Info.Block_Decls_Type; - Field_Parent := Info.Block_Decls_Type; + Inst := Get_Scope_Type (Info.Block_Scope); + Field_Off := New_Offsetof + (Get_Scope_Type (Info.Block_Scope), + Info.Block_Parent_Field, Ghdl_Ptr_Type); when Iir_Kind_Entity_Declaration => Kind := Ghdl_Rtik_Entity; Generate_Declaration_Chain (Get_Generic_Chain (Blk)); @@ -28048,28 +28010,26 @@ package body Translation is Generate_Declaration_Chain (Get_Declaration_Chain (Blk)); Generate_Concurrent_Statement_Chain (Get_Concurrent_Statement_Chain (Blk), Rti); - Inst := Info.Block_Decls_Type; + Inst := Get_Scope_Type (Info.Block_Scope); when Iir_Kind_Process_Statement | Iir_Kind_Sensitized_Process_Statement => Kind := Ghdl_Rtik_Process; Generate_Declaration_Chain (Get_Declaration_Chain (Blk)); - Field := Info.Process_Parent_Field; - Field_Parent := Get_Info (Get_Parent (Blk)).Block_Decls_Type; - Inst := Info.Process_Decls_Type; + Field_Off := + Get_Scope_Offset (Info.Process_Scope, Ghdl_Ptr_Type); + Inst := Get_Scope_Type (Info.Process_Scope); when Iir_Kind_Block_Statement => Kind := Ghdl_Rtik_Block; declare - Guard : Iir; - Header : Iir; + Guard : constant Iir := Get_Guard_Decl (Blk); + Header : constant Iir := Get_Block_Header (Blk); Guard_Info : Object_Info_Acc; begin - Guard := Get_Guard_Decl (Blk); if Guard /= Null_Iir then Guard_Info := Get_Info (Guard); Generate_Object (Guard, Guard_Info.Object_Rti); Add_Rti_Node (Guard_Info.Object_Rti); end if; - Header := Get_Block_Header (Blk); if Header /= Null_Iir then Generate_Declaration_Chain (Get_Generic_Chain (Header)); Generate_Declaration_Chain (Get_Port_Chain (Header)); @@ -28078,15 +28038,13 @@ package body Translation is Generate_Declaration_Chain (Get_Declaration_Chain (Blk)); Generate_Concurrent_Statement_Chain (Get_Concurrent_Statement_Chain (Blk), Rti); - Field := Info.Block_Parent_Field; - Field_Parent := Get_Info (Get_Parent (Blk)).Block_Decls_Type; - Inst := Info.Block_Decls_Type; + Field_Off := Get_Scope_Offset (Info.Block_Scope, Ghdl_Ptr_Type); + Inst := Get_Scope_Type (Info.Block_Scope); when Iir_Kind_Generate_Statement => declare - Scheme : Iir; + Scheme : constant Iir := Get_Generation_Scheme (Blk); Scheme_Rti : O_Dnode := O_Dnode_Null; begin - Scheme := Get_Generation_Scheme (Blk); if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then Generate_Object (Scheme, Scheme_Rti); Add_Rti_Node (Scheme_Rti); @@ -28098,9 +28056,10 @@ package body Translation is Generate_Declaration_Chain (Get_Declaration_Chain (Blk)); Generate_Concurrent_Statement_Chain (Get_Concurrent_Statement_Chain (Blk), Rti); - Field := Info.Block_Parent_Field; - Field_Parent := Get_Info (Get_Parent (Blk)).Block_Decls_Type; - Inst := Info.Block_Decls_Type; + Inst := Get_Scope_Type (Info.Block_Scope); + Field_Off := New_Offsetof + (Get_Scope_Type (Get_Info (Get_Parent (Blk)).Block_Scope), + Info.Block_Parent_Field, Ghdl_Ptr_Type); when others => Error_Kind ("rti.generate_block", Blk); end case; @@ -28113,12 +28072,10 @@ package body Translation is Start_Record_Aggr (List, Ghdl_Rtin_Block); New_Record_Aggr_El (List, Generate_Common (Kind)); New_Record_Aggr_El (List, New_Global_Address (Name, Char_Ptr_Type)); - if Field = O_Fnode_Null then - Res := Get_Null_Loc; - else - Res := New_Offsetof (Field_Parent, Field, Ghdl_Ptr_Type); + if Field_Off = O_Cnode_Null then + Field_Off := Get_Null_Loc; end if; - New_Record_Aggr_El (List, Res); + New_Record_Aggr_El (List, Field_Off); if Parent_Rti = O_Dnode_Null then Res := New_Null_Access (Ghdl_Rti_Access); else @@ -28360,34 +28317,30 @@ package body Translation is function Get_Context_Addr (Node : Iir) return O_Enode is - Node_Info : Ortho_Info_Acc; - - Block_Type : O_Tnode; + Node_Info : constant Ortho_Info_Acc := Get_Info (Node); + Ref : O_Lnode; begin - Node_Info := Get_Info (Node); - case Get_Kind (Node) is when Iir_Kind_Component_Declaration => - Block_Type := Node_Info.Comp_Type; + Ref := Get_Instance_Ref (Node_Info.Comp_Scope); when Iir_Kind_Entity_Declaration | Iir_Kind_Architecture_Body | Iir_Kind_Block_Statement | Iir_Kind_Generate_Statement => - Block_Type := Node_Info.Block_Decls_Type; + Ref := Get_Instance_Ref (Node_Info.Block_Scope); when Iir_Kind_Package_Declaration | Iir_Kind_Package_Body => return New_Lit (New_Null_Access (Ghdl_Ptr_Type)); when Iir_Kind_Process_Statement | Iir_Kind_Sensitized_Process_Statement => - Block_Type := Node_Info.Process_Decls_Type; + Ref := Get_Instance_Ref (Node_Info.Process_Scope); when Iir_Kind_Psl_Assert_Statement | Iir_Kind_Psl_Cover_Statement => - Block_Type := Node_Info.Psl_Decls_Type; + Ref := Get_Instance_Ref (Node_Info.Psl_Scope); when others => Error_Kind ("get_context_addr", Node); end case; - return New_Unchecked_Address (Get_Instance_Ref (Block_Type), - Ghdl_Ptr_Type); + return New_Unchecked_Address (Ref, Ghdl_Ptr_Type); end Get_Context_Addr; procedure Associate_Rti_Context (Assoc : in out O_Assoc_List; Node : Iir) @@ -28500,16 +28453,16 @@ package body Translation is Chap2.Translate_Package_Declaration (El); when Iir_Kind_Package_Body => New_Debug_Comment_Decl ("package body " & Image_Identifier (El)); - --Push_Global_Factory (O_Storage_Private); Chap2.Translate_Package_Body (El); - --Pop_Global_Factory; + when Iir_Kind_Package_Instantiation_Declaration => + New_Debug_Comment_Decl + ("package instantiation " & Image_Identifier (El)); + Chap2.Translate_Package_Instantiation_Declaration (El); when Iir_Kind_Entity_Declaration => New_Debug_Comment_Decl ("entity " & Image_Identifier (El)); - --Set_Global_Storage (O_Storage_Private); Chap1.Translate_Entity_Declaration (El); when Iir_Kind_Architecture_Body => New_Debug_Comment_Decl ("architecture " & Image_Identifier (El)); - --Set_Global_Storage (O_Storage_Private); Chap1.Translate_Architecture_Body (El); when Iir_Kind_Configuration_Declaration => New_Debug_Comment_Decl ("configuration " & Image_Identifier (El)); @@ -29992,6 +29945,9 @@ package body Translation is ("__ghdl_to_string_e8", Ghdl_To_String_E8, Ghdl_I32_Type, Rtis.Ghdl_Rti_Access, Wki_Rti); Create_To_String_Subprogram + ("__ghdl_to_string_char", Ghdl_To_String_Char, + Get_Ortho_Type (Character_Type_Definition, Mode_Value)); + Create_To_String_Subprogram ("__ghdl_to_string_e32", Ghdl_To_String_E32, Ghdl_I32_Type, Rtis.Ghdl_Rti_Access, Wki_Rti); Create_To_String_Subprogram @@ -30221,7 +30177,6 @@ package body Translation is Free_Type_Info (Info, True); when Iir_Kind_Array_Subtype_Definition => if Get_Index_Constraint_Flag (I) then - Free_Var (Info.T.Array_Bounds); Info.T := Ortho_Info_Type_Array_Init; Free_Type_Info (Info, True); end if; @@ -30296,8 +30251,7 @@ package body Translation is New_Assign_Stmt (New_Obj (Arch_Instance), Gen_Alloc (Alloc_System, - New_Lit (New_Sizeof (Arch_Info.Block_Decls_Type, - Ghdl_Index_Type)), + New_Lit (Get_Scope_Size (Arch_Info.Block_Scope)), Arch_Info.Block_Decls_Ptr_Type)); -- Set the top instance. @@ -30349,7 +30303,7 @@ package body Translation is New_Procedure_Call (Assoc); -- init instance - Push_Scope (Entity_Info.Block_Decls_Type, Instance); + Set_Scope_Via_Param_Ptr (Entity_Info.Block_Scope, Instance); Push_Identifier_Prefix (Mark, ""); Chap1.Translate_Entity_Init (Entity); @@ -30366,7 +30320,7 @@ package body Translation is New_Procedure_Call (Assoc); Pop_Identifier_Prefix (Mark); - Pop_Scope (Entity_Info.Block_Decls_Type); + Clear_Scope (Entity_Info.Block_Scope); Finish_Subprogram_Body; Current_Filename_Node := O_Dnode_Null; @@ -30425,8 +30379,7 @@ package body Translation is (Const, Create_Identifier ("INSTSIZE"), O_Storage_Public, Ghdl_Index_Type); Start_Const_Value (Const); - Finish_Const_Value - (Const, New_Sizeof (Arch_Info.Block_Decls_Type, Ghdl_Index_Type)); + Finish_Const_Value (Const, Get_Scope_Size (Arch_Info.Block_Scope)); -- Elaborator. Start_Procedure_Decl @@ -30801,10 +30754,14 @@ package body Translation is Translate (Unit, True); when Iir_Kind_Entity_Declaration | Iir_Kind_Architecture_Body - | Iir_Kind_Package_Declaration => + | Iir_Kind_Package_Declaration + | Iir_Kind_Package_Instantiation_Declaration => + -- For package spec, mark it as 'body is not present', this + -- flag will be set below when the body is translated. Set_Elab_Flag (Unit, False); Translate (Unit, Whole); when Iir_Kind_Package_Body => + -- Mark the spec with 'body is present' flag. Set_Elab_Flag (Get_Design_Unit (Get_Package (Lib_Unit)), True); Translate (Unit, Whole); @@ -30831,7 +30788,8 @@ package body Translation is Gen_Last_Arch (Lib_Unit); when Iir_Kind_Architecture_Body | Iir_Kind_Package_Body - | Iir_Kind_Configuration_Declaration => + | Iir_Kind_Configuration_Declaration + | Iir_Kind_Package_Instantiation_Declaration => null; when others => Error_Kind ("elaborate(2)", Lib_Unit); |