diff options
| author | Tristan Gingold <tgingold@free.fr> | 2015-08-29 07:57:12 +0200 |
|---|---|---|
| committer | Tristan Gingold <tgingold@free.fr> | 2015-08-29 07:57:12 +0200 |
| commit | b75d703676ab830ea3e5731e1965d1d89879a456 (patch) | |
| tree | 1a0a21ba1cce6385715bd2823853ee4ad47905ee /src | |
| parent | 64fa65e1395bef4f05c51bc19d9a46d6003339ee (diff) | |
| download | ghdl-b75d703676ab830ea3e5731e1965d1d89879a456.tar.gz ghdl-b75d703676ab830ea3e5731e1965d1d89879a456.tar.bz2 ghdl-b75d703676ab830ea3e5731e1965d1d89879a456.zip | |
Replace fat accesses by bounds accesses
translate: separate info for signals from object.
Improve some error messages.
Diffstat (limited to 'src')
32 files changed, 1041 insertions, 942 deletions
diff --git a/src/grt/grt-files.adb b/src/grt/grt-files.adb index 46d3cedac..1f037a76e 100644 --- a/src/grt/grt-files.adb +++ b/src/grt/grt-files.adb @@ -384,27 +384,25 @@ package body Grt.Files is end Ghdl_Text_Read_Length; procedure Ghdl_Untruncated_Text_Read - (Params : Ghdl_Untruncated_Text_Read_Params_Acc) + (File : Ghdl_File_Index; Str : Std_String_Ptr; Len : Std_Integer_Acc) is - Str : constant Std_String_Ptr := Params.Str; Stream : C_Files; - Len : int; - Idx : Ghdl_Index_Type; + Max_Len : int; begin - Stream := Get_File (Params.File); - Check_File_Mode (Params.File, True); - Len := int (Str.Bounds.Dim_1.Length); - if fgets (Str.Base (0)'Address, Len, Stream) = Null_Address then + Stream := Get_File (File); + Check_File_Mode (File, True); + Max_Len := int (Str.Bounds.Dim_1.Length); + if fgets (Str.Base (0)'Address, Max_Len, Stream) = Null_Address then Internal_Error ("ghdl_untruncated_text_read: end of file"); end if; + -- Compute the length. for I in Ghdl_Index_Type loop if Str.Base (I) = NUL then - Idx := I; + Len.all := Std_Integer (I); exit; end if; end loop; - Params.Len := Std_Integer (Idx); end Ghdl_Untruncated_Text_Read; procedure File_Close (File : Ghdl_File_Index; Is_Text : Boolean) diff --git a/src/grt/grt-files.ads b/src/grt/grt-files.ads index 3fadc981e..3c6191f36 100644 --- a/src/grt/grt-files.ads +++ b/src/grt/grt-files.ads @@ -75,17 +75,11 @@ package Grt.Files is function Ghdl_Text_Read_Length (File : Ghdl_File_Index; Str : Std_String_Ptr) return Std_Integer; - type Ghdl_Untruncated_Text_Read_Params is record - File : Ghdl_File_Index; - Str : Std_String_Ptr; - Len : Std_Integer; - end record; - - type Ghdl_Untruncated_Text_Read_Params_Acc is - access Ghdl_Untruncated_Text_Read_Params; + type Std_Integer_Acc is access Std_Integer; + pragma Convention (C, Std_Integer_Acc); procedure Ghdl_Untruncated_Text_Read - (Params : Ghdl_Untruncated_Text_Read_Params_Acc); + (File : Ghdl_File_Index; Str : Std_String_Ptr; Len : Std_Integer_Acc); procedure Ghdl_Text_File_Close (File : Ghdl_File_Index); procedure Ghdl_File_Close (File : Ghdl_File_Index); diff --git a/src/grt/grt-lib.adb b/src/grt/grt-lib.adb index b4505adb6..d2b095c67 100644 --- a/src/grt/grt-lib.adb +++ b/src/grt/grt-lib.adb @@ -272,25 +272,25 @@ package body Grt.Lib is end Ghdl_Get_Resolution_Limit; procedure Ghdl_Control_Simulation - (Params : Ghdl_Control_Simulation_Params_Ptr) is + (Stop : Ghdl_B1; Has_Status : Ghdl_B1; Status : Std_Integer) is begin Report_H; -- Report_C (Grt.Options.Progname); Report_C ("simulation "); - if Params.Stop then + if Stop then Report_C ("stopped"); else Report_C ("finished"); end if; Report_C (" @"); Report_Now_C; - if Params.Has_Status then + if Has_Status then Report_C (" with status "); - Report_C (Integer (Params.Status)); + Report_C (Integer (Status)); end if; Report_E (""); - if Params.Has_Status then - Exit_Status := Integer (Params.Status); + if Has_Status then + Exit_Status := Integer (Status); end if; Exit_Simulation; end Ghdl_Control_Simulation; diff --git a/src/grt/grt-lib.ads b/src/grt/grt-lib.ads index dcd2c55b7..82fee91b1 100644 --- a/src/grt/grt-lib.ads +++ b/src/grt/grt-lib.ads @@ -95,17 +95,8 @@ package Grt.Lib is function Ghdl_Get_Resolution_Limit return Std_Time; - type Ghdl_Control_Simulation_Params is record - Stop : Ghdl_B1; - Has_Status : Ghdl_B1; - Status : Std_Integer; - end record; - - type Ghdl_Control_Simulation_Params_Ptr is access - Ghdl_Control_Simulation_Params; - procedure Ghdl_Control_Simulation - (Params : Ghdl_Control_Simulation_Params_Ptr); + (Stop : Ghdl_B1; Has_Status : Ghdl_B1; Status : Std_Integer); private pragma Export (C, Ghdl_Memcpy, "__ghdl_memcpy"); diff --git a/src/grt/grt-values.adb b/src/grt/grt-values.adb index 18a917bd2..e87182791 100644 --- a/src/grt/grt-values.adb +++ b/src/grt/grt-values.adb @@ -119,7 +119,7 @@ package body Grt.Values is end if; end loop; Error_C ("'value: '"); - Error_C_Std (S (Pos .. L)); + Error_C_Std (S (Pos .. L - 1)); Error_C ("' not in enumeration '"); Error_C (Enum_Rti.Name); Error_E ("'"); diff --git a/src/libraries.adb b/src/libraries.adb index 63fbb890b..1b2945f8a 100644 --- a/src/libraries.adb +++ b/src/libraries.adb @@ -1435,7 +1435,11 @@ package body Libraries is procedure Error_Obsolete (Msg : String) is begin if not Flags.Flag_Elaborate_With_Outdated then - Error_Msg_Sem (Msg, Loc); + if Loc = Null_Iir then + Error_Msg_Sem (Msg, Command_Line_Location); + else + Error_Msg_Sem (Msg, Loc); + end if; end if; end Error_Obsolete; diff --git a/src/ortho/mcode/ortho_code-disps.adb b/src/ortho/mcode/ortho_code-disps.adb index 9e8ac1272..e76a20f4a 100644 --- a/src/ortho/mcode/ortho_code-disps.adb +++ b/src/ortho/mcode/ortho_code-disps.adb @@ -444,6 +444,34 @@ package body Ortho_Code.Disps is end case; end Disp_Type; + procedure Debug_Tnode (Atype : O_Tnode) + is + Decl : O_Dnode; + begin + Decl := Decls.Get_Type_Decl (Atype); + if Decl /= O_Dnode_Null then + Decls.Disp_Decl_Name (Decl); + Put (": "); + end if; + Disp_Type (Atype, True); + New_Line; + end Debug_Tnode; + pragma Unreferenced (Debug_Tnode); + + procedure Debug_Enode (Expr : O_Enode) is + begin + Disp_Expr (Expr); + New_Line; + end Debug_Enode; + pragma Unreferenced (Debug_Enode); + + procedure Debug_Lnode (Expr : O_Lnode) is + begin + Disp_Expr (O_Enode (Expr)); + New_Line; + end Debug_Lnode; + pragma Unreferenced (Debug_Lnode); + procedure Disp_Decl_Storage (Decl : O_Dnode) is begin Disp_Storage (Decls.Get_Decl_Storage (Decl)); diff --git a/src/ortho/mcode/ortho_code-flags.ads b/src/ortho/mcode/ortho_code-flags.ads index 805f3779b..214cc743b 100644 --- a/src/ortho/mcode/ortho_code-flags.ads +++ b/src/ortho/mcode/ortho_code-flags.ads @@ -22,6 +22,7 @@ package Ortho_Code.Flags is Flag_Debug : Debug_Type := Debug_None; -- If set, generate a map from type to type declaration. + -- Set with --be-debug=t Flag_Type_Name : Boolean := False; -- If set, enable optimiztions. diff --git a/src/vhdl/configuration.adb b/src/vhdl/configuration.adb index 85339217f..1430eefce 100644 --- a/src/vhdl/configuration.adb +++ b/src/vhdl/configuration.adb @@ -18,7 +18,6 @@ with Libraries; with Errorout; use Errorout; with Std_Package; -with Sem_Names; with Name_Table; use Name_Table; with Flags; with Iirs_Utils; use Iirs_Utils; @@ -434,7 +433,7 @@ package body Configuration is Actual := Null_Iir; else Actual := Get_Actual (Assoc); - Actual := Sem_Names.Name_To_Object (Actual); + Actual := Name_To_Object (Actual); if Actual /= Null_Iir then Actual := Get_Object_Prefix (Actual); end if; diff --git a/src/vhdl/disp_tree.adb b/src/vhdl/disp_tree.adb index 34f31fe6d..3685800cb 100644 --- a/src/vhdl/disp_tree.adb +++ b/src/vhdl/disp_tree.adb @@ -37,9 +37,7 @@ package body Disp_Tree is Max_Depth : Natural := 10; pragma Warnings (On); - procedure Disp_Iir (N : Iir; - Indent : Natural := 1; - Flat : Boolean := False); + procedure Disp_Iir (N : Iir; Indent : Natural; Depth : Natural); procedure Disp_Header (N : Iir); procedure Disp_Tree_List_Flat (Tree_List: Iir_List; Tab: Natural); @@ -70,13 +68,8 @@ package body Disp_Tree is -- For iir. - procedure Disp_Tree_Flat (Tree: Iir; Tab: Natural) is - begin - Disp_Iir (Tree, Tab, True); - end Disp_Tree_Flat; - procedure Disp_Iir_List - (Tree_List : Iir_List; Tab : Natural := 0; Flat : Boolean := False) + (Tree_List : Iir_List; Tab : Natural; Depth : Natural) is El: Iir; begin @@ -92,13 +85,12 @@ package body Disp_Tree is El := Get_Nth_Element (Tree_List, I); exit when El = Null_Iir; Put_Indent (Tab); - Disp_Iir (El, Tab + 1, Flat); + Disp_Iir (El, Tab + 1, Depth); end loop; end if; end Disp_Iir_List; - procedure Disp_Chain - (Tree_Chain: Iir; Indent: Natural; Flat : Boolean := False) + procedure Disp_Chain (Tree_Chain: Iir; Indent: Natural; Depth : Natural) is El: Iir; begin @@ -106,7 +98,7 @@ package body Disp_Tree is El := Tree_Chain; while El /= Null_Iir loop Put_Indent (Indent); - Disp_Iir (El, Indent + 1, Flat); + Disp_Iir (El, Indent + 1, Depth); El := Get_Chain (El); end loop; end Disp_Chain; @@ -117,7 +109,7 @@ package body Disp_Tree is begin El := Tree_Chain; while El /= Null_Iir loop - Disp_Iir (El, Tab, True); + Disp_Iir (El, Tab, 0); El := Get_Chain (El); end loop; end Disp_Tree_Flat_Chain; @@ -140,7 +132,7 @@ package body Disp_Tree is for I in Natural loop El := Get_Nth_Element (Tree_List, I); exit when El = Null_Iir; - Disp_Tree_Flat (El, Tab); + Disp_Iir (El, Tab, 0); end loop; end if; end Disp_Tree_List_Flat; @@ -357,28 +349,20 @@ package body Disp_Tree is New_Line; end Disp_Header; - procedure Disp_Iir (N : Iir; - Indent : Natural := 1; - Flat : Boolean := False) + procedure Disp_Iir (N : Iir; Indent : Natural; Depth : Natural) is Sub_Indent : constant Natural := Indent + 1; + Ndepth : Natural; begin Disp_Header (N); - if Flat or else N = Null_Iir then + if Depth = 0 or else N = Null_Iir then return; end if; Header ("location", Indent); Put_Line (Image_Location_Type (Get_Location (N))); - -- Protect against infinite recursions. - if Indent > Max_Depth then - Put_Indent (Indent); - Put_Line ("..."); - return; - end if; - declare use Nodes_Meta; Fields : constant Fields_Array := Get_Fields (Get_Kind (N)); @@ -391,13 +375,18 @@ package body Disp_Tree is when Type_Iir => case Get_Field_Attribute (F) is when Attr_None => - Disp_Iir (Get_Iir (N, F), Sub_Indent); + Disp_Iir (Get_Iir (N, F), Sub_Indent, Depth - 1); when Attr_Ref => - Disp_Iir (Get_Iir (N, F), Sub_Indent, True); + Disp_Iir (Get_Iir (N, F), Sub_Indent, 0); when Attr_Maybe_Ref => - Disp_Iir (Get_Iir (N, F), Sub_Indent, Get_Is_Ref (N)); + if Get_Is_Ref (N) then + Ndepth := 0; + else + Ndepth := Depth - 1; + end if; + Disp_Iir (Get_Iir (N, F), Sub_Indent, Ndepth); when Attr_Chain => - Disp_Chain (Get_Iir (N, F), Sub_Indent); + Disp_Chain (Get_Iir (N, F), Sub_Indent, Depth - 1); when Attr_Chain_Next => Disp_Iir_Number (Get_Iir (N, F)); New_Line; @@ -405,8 +394,12 @@ package body Disp_Tree is raise Internal_Error; end case; when Type_Iir_List => - Disp_Iir_List (Get_Iir_List (N, F), Sub_Indent, - Get_Field_Attribute (F) = Attr_Of_Ref); + if Get_Field_Attribute (F) = Attr_Of_Ref then + Ndepth := 0; + else + Ndepth := Depth - 1; + end if; + Disp_Iir_List (Get_Iir_List (N, F), Sub_Indent, Ndepth); when Type_PSL_NFA => Disp_PSL_NFA (Get_PSL_NFA (N, F), Sub_Indent); when Type_String8_Id => @@ -484,12 +477,16 @@ package body Disp_Tree is procedure Disp_Tree_For_Psl (N : Int32) is begin - Disp_Tree_Flat (Iir (N), 1); + Disp_Iir (Iir (N), 1, 0); end Disp_Tree_For_Psl; procedure Disp_Tree (Tree : Iir; Flat : Boolean := false) is begin - Disp_Iir (Tree, 1, Flat); + if Flat then + Disp_Iir (Tree, 1, 0); + else + Disp_Iir (Tree, 1, Max_Depth); + end if; end Disp_Tree; end Disp_Tree; diff --git a/src/vhdl/iirs.ads b/src/vhdl/iirs.ads index 37327913c..7b701b379 100644 --- a/src/vhdl/iirs.ads +++ b/src/vhdl/iirs.ads @@ -3117,6 +3117,9 @@ package Iirs is -- Get/Set_Subtype_Indication (Field5) -- -- Get/Set_Expr_Staticness (State1) + -- + -- Only for Iir_Kind_Allocator_By_Subtype: + -- Get/Set_Is_Ref (Flag7) ------------ -- Names -- diff --git a/src/vhdl/iirs_utils.adb b/src/vhdl/iirs_utils.adb index ea8f08ba0..544b0d5da 100644 --- a/src/vhdl/iirs_utils.adb +++ b/src/vhdl/iirs_utils.adb @@ -246,6 +246,110 @@ package body Iirs_Utils is end loop; end Get_Object_Prefix; + function Is_Object_Name (Name : Iir) return Boolean + is + Obj : constant Iir := Name_To_Object (Name); + begin + return Obj /= Null_Iir; + end Is_Object_Name; + + function Name_To_Object (Name : Iir) return Iir is + begin + -- LRM08 6.4 Objects + -- An object is a named entity that contains (has) a value of a type. + -- An object is obe of the following: + case Get_Kind (Name) is + -- An object declared by an object declaration (see 6.4.2) + when Iir_Kind_Signal_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Constant_Declaration => + return Name; + + -- A loop of generate parameter. + when Iir_Kind_Iterator_Declaration => + return Name; + + -- A formal parameter of a subprogram + -- A formal port + -- A formal generic constant + -- A local port + -- A local generic constant + when Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_Interface_File_Declaration => + return Name; + + -- An implicit signak GUARD defined by the guard expression of a + -- block statement + when Iir_Kind_Guard_Signal_Declaration => + return Name; + + -- In addition, the following are objects [ but are not named + -- entities]: + -- An implicit signal defined by any of the predefined attributes + -- 'DELAYED, 'STABLE, 'QUIET, and 'TRANSACTION + when Iir_Kinds_Signal_Attribute => + return Name; + + -- An element or a slice of another object + when Iir_Kind_Slice_Name + | Iir_Kind_Indexed_Name + | Iir_Kind_Selected_Element => + return Name; + + -- An object designated by a value of an access type + when Iir_Kind_Implicit_Dereference + | Iir_Kind_Dereference => + return Name; + + -- LRM08 6.6 Alias declarations + -- An object alias is an alias whose alias designatore denotes an + -- object. + when Iir_Kind_Object_Alias_Declaration => + return Name; + + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + -- LRM08 8 Names + -- Names can denote declared entities [...] + -- GHDL: in particular, names can denote objects. + return Name_To_Object (Get_Named_Entity (Name)); + + when others => + return Null_Iir; + end case; + end Name_To_Object; + + function Name_To_Value (Name : Iir) return Iir is + begin + case Get_Kind (Name) is + when Iir_Kind_Attribute_Value + | Iir_Kind_Function_Call + | Iir_Kinds_Expression_Attribute => + return Name; + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + return Name_To_Value (Get_Named_Entity (Name)); + when others => + return Name_To_Object (Name); + end case; + end Name_To_Value; + + -- Return TRUE if EXPR is a signal name. + function Is_Signal_Name (Expr : Iir) return Boolean + is + Obj : Iir; + begin + Obj := Name_To_Object (Expr); + if Obj /= Null_Iir then + return Is_Signal_Object (Obj); + else + return False; + end if; + end Is_Signal_Name; + function Get_Association_Interface (Assoc : Iir) return Iir is Formal : Iir; @@ -1038,27 +1142,33 @@ package body Iirs_Utils is end case; end Get_Method_Type; - function Create_Error_Expr (Orig : Iir; Atype : Iir) return Iir + function Create_Error (Orig : Iir) return Iir is Res : Iir; begin Res := Create_Iir (Iir_Kind_Error); - Set_Expr_Staticness (Res, None); - Set_Type (Res, Atype); Set_Error_Origin (Res, Orig); Location_Copy (Res, Orig); return Res; + end Create_Error; + + function Create_Error_Expr (Orig : Iir; Atype : Iir) return Iir + is + Res : Iir; + begin + Res := Create_Error (Orig); + Set_Expr_Staticness (Res, None); + Set_Type (Res, Atype); + return Res; end Create_Error_Expr; function Create_Error_Type (Orig : Iir) return Iir is Res : Iir; begin - Res := Create_Iir (Iir_Kind_Error); + Res := Create_Error (Orig); --Set_Expr_Staticness (Res, Locally); Set_Base_Type (Res, Res); - Set_Error_Origin (Res, Orig); - Location_Copy (Res, Orig); Set_Type_Declarator (Res, Null_Iir); Set_Resolved_Flag (Res, True); Set_Signal_Type_Flag (Res, True); diff --git a/src/vhdl/iirs_utils.ads b/src/vhdl/iirs_utils.ads index cb4efe187..eabd68e01 100644 --- a/src/vhdl/iirs_utils.ads +++ b/src/vhdl/iirs_utils.ads @@ -59,6 +59,23 @@ package Iirs_Utils is return Iir; + -- Return TRUE if NAME is a name that designate an object (ie a constant, + -- a variable, a signal or a file). + function Is_Object_Name (Name : Iir) return Boolean; + + -- Return an object node if NAME designates an object (ie either is an + -- object or a name for an object). + -- Otherwise, returns NULL_IIR. + -- For the definition of an object, see LRM08 6.4 Objects. + function Name_To_Object (Name : Iir) return Iir; + + -- Return the value designated by NAME. This is often an object, but can + -- also be an expression like a function call or an attribute. + function Name_To_Value (Name : Iir) return Iir; + + -- Return TRUE if EXPR is a signal name. + function Is_Signal_Name (Expr : Iir) return Boolean; + -- Get the interface associated by the association ASSOC. This is always -- an interface, even if the formal is a name. function Get_Association_Interface (Assoc : Iir) return Iir; @@ -224,6 +241,9 @@ package Iirs_Utils is -- Return the protected type for method SPEC. function Get_Method_Type (Spec : Iir) return Iir; + -- Create an error node for node ORIG. + function Create_Error (Orig : Iir) return Iir; + -- Create an error node for node ORIG, and set its type to ATYPE. -- Set its staticness to locally. function Create_Error_Expr (Orig : Iir; Atype : Iir) return Iir; diff --git a/src/vhdl/nodes_meta.adb b/src/vhdl/nodes_meta.adb index c10ad3382..3dbef4ca5 100644 --- a/src/vhdl/nodes_meta.adb +++ b/src/vhdl/nodes_meta.adb @@ -3276,6 +3276,7 @@ package body Nodes_Meta is Field_Type, Field_Allocator_Designated_Type, -- Iir_Kind_Allocator_By_Subtype + Field_Is_Ref, Field_Expr_Staticness, Field_Subtype_Indication, Field_Type, @@ -4118,96 +4119,96 @@ package body Nodes_Meta is Iir_Kind_Qualified_Expression => 1082, Iir_Kind_Type_Conversion => 1087, Iir_Kind_Allocator_By_Expression => 1091, - Iir_Kind_Allocator_By_Subtype => 1095, - Iir_Kind_Selected_Element => 1101, - Iir_Kind_Dereference => 1106, - Iir_Kind_Implicit_Dereference => 1111, - Iir_Kind_Slice_Name => 1118, - Iir_Kind_Indexed_Name => 1124, - Iir_Kind_Psl_Expression => 1126, - Iir_Kind_Sensitized_Process_Statement => 1146, - Iir_Kind_Process_Statement => 1166, - Iir_Kind_Concurrent_Conditional_Signal_Assignment => 1177, - Iir_Kind_Concurrent_Selected_Signal_Assignment => 1189, - Iir_Kind_Concurrent_Assertion_Statement => 1197, - Iir_Kind_Psl_Default_Clock => 1201, - Iir_Kind_Psl_Assert_Statement => 1210, - Iir_Kind_Psl_Cover_Statement => 1219, - Iir_Kind_Concurrent_Procedure_Call_Statement => 1226, - Iir_Kind_Block_Statement => 1239, - Iir_Kind_If_Generate_Statement => 1249, - Iir_Kind_For_Generate_Statement => 1258, - Iir_Kind_Component_Instantiation_Statement => 1268, - Iir_Kind_Simple_Simultaneous_Statement => 1275, - Iir_Kind_Generate_Statement_Body => 1286, - Iir_Kind_If_Generate_Else_Clause => 1291, - Iir_Kind_Signal_Assignment_Statement => 1300, - Iir_Kind_Null_Statement => 1304, - Iir_Kind_Assertion_Statement => 1311, - Iir_Kind_Report_Statement => 1317, - Iir_Kind_Wait_Statement => 1324, - Iir_Kind_Variable_Assignment_Statement => 1330, - Iir_Kind_Return_Statement => 1336, - Iir_Kind_For_Loop_Statement => 1345, - Iir_Kind_While_Loop_Statement => 1353, - Iir_Kind_Next_Statement => 1359, - Iir_Kind_Exit_Statement => 1365, - Iir_Kind_Case_Statement => 1373, - Iir_Kind_Procedure_Call_Statement => 1379, - Iir_Kind_If_Statement => 1388, - Iir_Kind_Elsif => 1393, - Iir_Kind_Character_Literal => 1400, - Iir_Kind_Simple_Name => 1407, - Iir_Kind_Selected_Name => 1415, - Iir_Kind_Operator_Symbol => 1420, - Iir_Kind_Selected_By_All_Name => 1425, - Iir_Kind_Parenthesis_Name => 1429, - Iir_Kind_External_Constant_Name => 1438, - Iir_Kind_External_Signal_Name => 1447, - Iir_Kind_External_Variable_Name => 1456, - Iir_Kind_Package_Pathname => 1459, - Iir_Kind_Absolute_Pathname => 1460, - Iir_Kind_Relative_Pathname => 1461, - Iir_Kind_Pathname_Element => 1465, - Iir_Kind_Base_Attribute => 1467, - Iir_Kind_Left_Type_Attribute => 1472, - Iir_Kind_Right_Type_Attribute => 1477, - Iir_Kind_High_Type_Attribute => 1482, - Iir_Kind_Low_Type_Attribute => 1487, - Iir_Kind_Ascending_Type_Attribute => 1492, - Iir_Kind_Image_Attribute => 1498, - Iir_Kind_Value_Attribute => 1504, - Iir_Kind_Pos_Attribute => 1510, - Iir_Kind_Val_Attribute => 1516, - Iir_Kind_Succ_Attribute => 1522, - Iir_Kind_Pred_Attribute => 1528, - Iir_Kind_Leftof_Attribute => 1534, - Iir_Kind_Rightof_Attribute => 1540, - Iir_Kind_Delayed_Attribute => 1548, - Iir_Kind_Stable_Attribute => 1556, - Iir_Kind_Quiet_Attribute => 1564, - Iir_Kind_Transaction_Attribute => 1572, - Iir_Kind_Event_Attribute => 1576, - Iir_Kind_Active_Attribute => 1580, - Iir_Kind_Last_Event_Attribute => 1584, - Iir_Kind_Last_Active_Attribute => 1588, - Iir_Kind_Last_Value_Attribute => 1592, - Iir_Kind_Driving_Attribute => 1596, - Iir_Kind_Driving_Value_Attribute => 1600, - Iir_Kind_Behavior_Attribute => 1600, - Iir_Kind_Structure_Attribute => 1600, - Iir_Kind_Simple_Name_Attribute => 1607, - Iir_Kind_Instance_Name_Attribute => 1612, - Iir_Kind_Path_Name_Attribute => 1617, - Iir_Kind_Left_Array_Attribute => 1624, - Iir_Kind_Right_Array_Attribute => 1631, - Iir_Kind_High_Array_Attribute => 1638, - Iir_Kind_Low_Array_Attribute => 1645, - Iir_Kind_Length_Array_Attribute => 1652, - Iir_Kind_Ascending_Array_Attribute => 1659, - Iir_Kind_Range_Array_Attribute => 1666, - Iir_Kind_Reverse_Range_Array_Attribute => 1673, - Iir_Kind_Attribute_Name => 1681 + Iir_Kind_Allocator_By_Subtype => 1096, + Iir_Kind_Selected_Element => 1102, + Iir_Kind_Dereference => 1107, + Iir_Kind_Implicit_Dereference => 1112, + Iir_Kind_Slice_Name => 1119, + Iir_Kind_Indexed_Name => 1125, + Iir_Kind_Psl_Expression => 1127, + Iir_Kind_Sensitized_Process_Statement => 1147, + Iir_Kind_Process_Statement => 1167, + Iir_Kind_Concurrent_Conditional_Signal_Assignment => 1178, + Iir_Kind_Concurrent_Selected_Signal_Assignment => 1190, + Iir_Kind_Concurrent_Assertion_Statement => 1198, + Iir_Kind_Psl_Default_Clock => 1202, + Iir_Kind_Psl_Assert_Statement => 1211, + Iir_Kind_Psl_Cover_Statement => 1220, + Iir_Kind_Concurrent_Procedure_Call_Statement => 1227, + Iir_Kind_Block_Statement => 1240, + Iir_Kind_If_Generate_Statement => 1250, + Iir_Kind_For_Generate_Statement => 1259, + Iir_Kind_Component_Instantiation_Statement => 1269, + Iir_Kind_Simple_Simultaneous_Statement => 1276, + Iir_Kind_Generate_Statement_Body => 1287, + Iir_Kind_If_Generate_Else_Clause => 1292, + Iir_Kind_Signal_Assignment_Statement => 1301, + Iir_Kind_Null_Statement => 1305, + Iir_Kind_Assertion_Statement => 1312, + Iir_Kind_Report_Statement => 1318, + Iir_Kind_Wait_Statement => 1325, + Iir_Kind_Variable_Assignment_Statement => 1331, + Iir_Kind_Return_Statement => 1337, + Iir_Kind_For_Loop_Statement => 1346, + Iir_Kind_While_Loop_Statement => 1354, + Iir_Kind_Next_Statement => 1360, + Iir_Kind_Exit_Statement => 1366, + Iir_Kind_Case_Statement => 1374, + Iir_Kind_Procedure_Call_Statement => 1380, + Iir_Kind_If_Statement => 1389, + Iir_Kind_Elsif => 1394, + Iir_Kind_Character_Literal => 1401, + Iir_Kind_Simple_Name => 1408, + Iir_Kind_Selected_Name => 1416, + Iir_Kind_Operator_Symbol => 1421, + Iir_Kind_Selected_By_All_Name => 1426, + Iir_Kind_Parenthesis_Name => 1430, + Iir_Kind_External_Constant_Name => 1439, + Iir_Kind_External_Signal_Name => 1448, + Iir_Kind_External_Variable_Name => 1457, + Iir_Kind_Package_Pathname => 1460, + Iir_Kind_Absolute_Pathname => 1461, + Iir_Kind_Relative_Pathname => 1462, + Iir_Kind_Pathname_Element => 1466, + Iir_Kind_Base_Attribute => 1468, + Iir_Kind_Left_Type_Attribute => 1473, + Iir_Kind_Right_Type_Attribute => 1478, + Iir_Kind_High_Type_Attribute => 1483, + Iir_Kind_Low_Type_Attribute => 1488, + Iir_Kind_Ascending_Type_Attribute => 1493, + Iir_Kind_Image_Attribute => 1499, + Iir_Kind_Value_Attribute => 1505, + Iir_Kind_Pos_Attribute => 1511, + Iir_Kind_Val_Attribute => 1517, + Iir_Kind_Succ_Attribute => 1523, + Iir_Kind_Pred_Attribute => 1529, + Iir_Kind_Leftof_Attribute => 1535, + Iir_Kind_Rightof_Attribute => 1541, + Iir_Kind_Delayed_Attribute => 1549, + Iir_Kind_Stable_Attribute => 1557, + Iir_Kind_Quiet_Attribute => 1565, + Iir_Kind_Transaction_Attribute => 1573, + Iir_Kind_Event_Attribute => 1577, + Iir_Kind_Active_Attribute => 1581, + Iir_Kind_Last_Event_Attribute => 1585, + Iir_Kind_Last_Active_Attribute => 1589, + Iir_Kind_Last_Value_Attribute => 1593, + Iir_Kind_Driving_Attribute => 1597, + Iir_Kind_Driving_Value_Attribute => 1601, + Iir_Kind_Behavior_Attribute => 1601, + Iir_Kind_Structure_Attribute => 1601, + Iir_Kind_Simple_Name_Attribute => 1608, + Iir_Kind_Instance_Name_Attribute => 1613, + Iir_Kind_Path_Name_Attribute => 1618, + Iir_Kind_Left_Array_Attribute => 1625, + Iir_Kind_Right_Array_Attribute => 1632, + Iir_Kind_High_Array_Attribute => 1639, + Iir_Kind_Low_Array_Attribute => 1646, + Iir_Kind_Length_Array_Attribute => 1653, + Iir_Kind_Ascending_Array_Attribute => 1660, + Iir_Kind_Range_Array_Attribute => 1667, + Iir_Kind_Reverse_Range_Array_Attribute => 1674, + Iir_Kind_Attribute_Name => 1682 ); function Get_Fields (K : Iir_Kind) return Fields_Array @@ -9588,6 +9589,7 @@ package body Nodes_Meta is | Iir_Kind_Interface_Variable_Declaration | Iir_Kind_Interface_Signal_Declaration | Iir_Kind_Interface_File_Declaration + | Iir_Kind_Allocator_By_Subtype | Iir_Kind_External_Constant_Name | Iir_Kind_External_Signal_Name | Iir_Kind_External_Variable_Name => diff --git a/src/vhdl/parse.adb b/src/vhdl/parse.adb index 7cb8f825b..5075c95b2 100644 --- a/src/vhdl/parse.adb +++ b/src/vhdl/parse.adb @@ -214,11 +214,9 @@ package body Parse is -- mode ::= IN | OUT | INOUT | BUFFER | LINKAGE -- -- If there is no mode, DEFAULT is returned. - function Parse_Mode (Default: Iir_Mode) return Iir_Mode is + function Parse_Mode return Iir_Mode is begin case Current_Token is - when Tok_Identifier => - return Default; when Tok_In => Scan; if Current_Token = Tok_Out then @@ -1311,12 +1309,26 @@ package body Parse is -- Skip ':' Scan; + -- Parse mode. + case Current_Token is + when Tok_In + | Tok_Out + | Tok_Inout + | Tok_Linkage + | Tok_Buffer => + Interface_Mode := Parse_Mode; + Has_Mode := True; + when others => + Interface_Mode := Iir_Unknown_Mode; + Has_Mode := False; + end case; + -- LRM93 2.1.1 LRM08 4.2.2.1 -- If the mode is INOUT or OUT, and no object class is explicitly -- specified, variable is assumed. if Is_Default and then Ctxt in Parameter_Interface_List - and then (Current_Token = Tok_Inout or else Current_Token = Tok_Out) + and then Interface_Mode in Iir_Out_Modes then -- Convert into variable. declare @@ -1348,23 +1360,10 @@ package body Parse is end; end if; - -- Update lexical layout if mode is present. - case Current_Token is - when Tok_In - | Tok_Out - | Tok_Inout - | Tok_Linkage - | Tok_Buffer => - Has_Mode := True; - when others => - Has_Mode := False; - null; - end case; - -- Parse mode (and handle default mode). - case Get_Kind (Inter) is + case Iir_Kinds_Interface_Object_Declaration (Get_Kind (Inter)) is when Iir_Kind_Interface_File_Declaration => - if Parse_Mode (Iir_Unknown_Mode) /= Iir_Unknown_Mode then + if Interface_Mode /= Iir_Unknown_Mode then Error_Msg_Parse ("mode can't be specified for a file interface"); end if; @@ -1375,14 +1374,16 @@ package body Parse is -- If no mode is explicitly given in an interface declaration -- other than an interface file declaration, mode IN is -- assumed. - Interface_Mode := Parse_Mode (Iir_In_Mode); + if Interface_Mode = Iir_Unknown_Mode then + Interface_Mode := Iir_In_Mode; + end if; when Iir_Kind_Interface_Constant_Declaration => - Interface_Mode := Parse_Mode (Iir_In_Mode); - if Interface_Mode /= Iir_In_Mode then + if Interface_Mode = Iir_Unknown_Mode then + Interface_Mode := Iir_In_Mode; + elsif Interface_Mode /= Iir_In_Mode then Error_Msg_Parse ("mode must be 'in' for a constant"); + Interface_Mode := Iir_In_Mode; end if; - when others => - raise Internal_Error; end case; Interface_Type := Parse_Subtype_Indication; @@ -3214,7 +3215,7 @@ package body Parse is if Flags.Vhdl_Std >= Vhdl_93 then Error_Msg_Parse ("mode allowed only in vhdl 87"); end if; - Mode := Parse_Mode (Iir_In_Mode); + Mode := Parse_Mode; if Mode = Iir_Inout_Mode then Error_Msg_Parse ("inout mode not allowed for file"); end if; diff --git a/src/vhdl/sem_decls.adb b/src/vhdl/sem_decls.adb index 5081fa3d2..a2475c4b9 100644 --- a/src/vhdl/sem_decls.adb +++ b/src/vhdl/sem_decls.adb @@ -2491,7 +2491,8 @@ package body Sem_Decls is end if; Set_Named_Entity (Name, N_Entity); - Set_Name (Alias, Finish_Sem_Name (Name)); + Name := Finish_Sem_Name (Name); + Set_Name (Alias, Name); if Is_Object_Name (N_Entity) then -- Object alias declaration. @@ -2507,10 +2508,6 @@ package body Sem_Decls is else -- Non object alias declaration. - if Get_Type (Alias) /= Null_Iir then - Error_Msg_Sem - ("subtype indication not allowed for non-object alias", Alias); - end if; if Get_Subtype_Indication (Alias) /= Null_Iir then Error_Msg_Sem ("subtype indication shall not appear in a nonobject alias", @@ -2522,7 +2519,7 @@ package body Sem_Decls is Set_Parent (Res, Get_Parent (Alias)); Set_Chain (Res, Get_Chain (Alias)); Set_Identifier (Res, Get_Identifier (Alias)); - Set_Name (Res, Name); + Set_Name (Res, Get_Name (Alias)); Set_Alias_Signature (Res, Sig); Sem_Scopes.Add_Name (Res); @@ -2530,7 +2527,22 @@ package body Sem_Decls is Free_Iir (Alias); - Sem_Non_Object_Alias_Declaration (Res); + if Get_Kind (Name) in Iir_Kinds_Denoting_Name then + Sem_Non_Object_Alias_Declaration (Res); + else + Error_Msg_Sem + ("name of nonobject alias is not a declaration", Name); + + -- Create a simple name to an error node. + N_Entity := Create_Error (Name); + Name := Create_Iir (Iir_Kind_Simple_Name); + Location_Copy (Name, N_Entity); + Set_Identifier (Name, Get_Identifier (Res)); -- Better idea ? + Set_Named_Entity (Name, N_Entity); + Set_Base_Name (Name, Name); + Set_Name (Res, Name); + end if; + return Res; end if; end Sem_Alias_Declaration; diff --git a/src/vhdl/sem_names.adb b/src/vhdl/sem_names.adb index d6e34222a..fca9f4f19 100644 --- a/src/vhdl/sem_names.adb +++ b/src/vhdl/sem_names.adb @@ -2205,7 +2205,7 @@ package body Sem_Names is -- Only values can be indexed or sliced. -- Catch errors such as slice of a type conversion. - if not Is_Object_Name (Sub_Name) + if Name_To_Value (Sub_Name) = Null_Iir and then Get_Kind (Sub_Name) /= Iir_Kind_Function_Declaration then if Finish then @@ -2492,6 +2492,10 @@ package body Sem_Names is when Iir_Kinds_Library_Unit_Declaration => Error_Msg_Sem ("function name is a design unit", Name); + when Iir_Kind_Error => + -- Continue with the error. + Res := Prefix; + when others => Error_Kind ("sem_parenthesis_name", Prefix); end case; @@ -3774,70 +3778,6 @@ package body Sem_Names is end case; end Name_To_Range; - function Is_Object_Name (Name : Iir) return Boolean is - begin - case Get_Kind (Name) is - when Iir_Kind_Object_Alias_Declaration - | Iir_Kind_Signal_Declaration - | Iir_Kind_Guard_Signal_Declaration - | Iir_Kind_Variable_Declaration - | Iir_Kind_File_Declaration - | Iir_Kind_Constant_Declaration - | Iir_Kind_Iterator_Declaration - | Iir_Kind_Interface_Constant_Declaration - | Iir_Kind_Interface_Variable_Declaration - | Iir_Kind_Interface_Signal_Declaration - | Iir_Kind_Interface_File_Declaration - | Iir_Kind_Slice_Name - | Iir_Kind_Indexed_Name - | Iir_Kind_Selected_Element - | Iir_Kind_Implicit_Dereference - | Iir_Kind_Dereference - | Iir_Kind_Attribute_Value - | Iir_Kind_Function_Call => - return True; - when Iir_Kinds_Expression_Attribute => - -- All expression attributes are a name. - return True; - when Iir_Kind_Simple_Name - | Iir_Kind_Selected_Name => - return False; - when others => - return False; - end case; - end Is_Object_Name; - - function Name_To_Object (Name : Iir) return Iir is - begin - case Get_Kind (Name) is - when Iir_Kind_Object_Alias_Declaration - | Iir_Kind_Signal_Declaration - | Iir_Kind_Guard_Signal_Declaration - | Iir_Kind_Variable_Declaration - | Iir_Kind_File_Declaration - | Iir_Kind_Constant_Declaration - | Iir_Kind_Iterator_Declaration - | Iir_Kind_Interface_Constant_Declaration - | Iir_Kind_Interface_Variable_Declaration - | Iir_Kind_Interface_Signal_Declaration - | Iir_Kind_Interface_File_Declaration - | Iir_Kind_Slice_Name - | Iir_Kind_Indexed_Name - | Iir_Kind_Selected_Element - | Iir_Kind_Implicit_Dereference - | Iir_Kind_Dereference - | Iir_Kind_Attribute_Value - | Iir_Kind_Function_Call - | Iir_Kinds_Signal_Attribute => - return Name; - when Iir_Kind_Simple_Name - | Iir_Kind_Selected_Name => - return Name_To_Object (Get_Named_Entity (Name)); - when others => - return Null_Iir; - end case; - end Name_To_Object; - function Create_Error_Name (Orig : Iir) return Iir is Res : Iir; diff --git a/src/vhdl/sem_names.ads b/src/vhdl/sem_names.ads index 3ce4acf74..d20c4cf48 100644 --- a/src/vhdl/sem_names.ads +++ b/src/vhdl/sem_names.ads @@ -75,15 +75,6 @@ package Sem_Names is -- To be used only for names (weakly) semantized by sem_name_soft. procedure Sem_Name_Clean (Name : Iir); - -- Return TRUE if NAME is a name that designate an object (ie a constant, - -- a variable, a signal or a file). - function Is_Object_Name (Name : Iir) return Boolean; - - -- Return an object node if NAME designates an object (ie either is an - -- object or a name for an object). - -- Otherwise, returns NULL_IIR. - function Name_To_Object (Name : Iir) return Iir; - -- If NAME is a selected name whose prefix is a protected variable, set -- method_object of CALL. procedure Name_To_Method_Object (Call : Iir; Name : Iir); diff --git a/src/vhdl/translate/trans-chap2.adb b/src/vhdl/translate/trans-chap2.adb index a43179e78..b3055f493 100644 --- a/src/vhdl/translate/trans-chap2.adb +++ b/src/vhdl/translate/trans-chap2.adb @@ -111,30 +111,38 @@ package body Trans.Chap2 is -- Return the type of a subprogram interface. -- Return O_Tnode_Null if the parameter is passed through the -- interface record. - function Translate_Interface_Type (Inter : Iir) return O_Tnode + function Translate_Interface_Type (Inter : Iir; Is_Foreign : Boolean) + return O_Tnode is - Mode : Object_Kind_Type; Tinfo : constant Type_Info_Acc := Get_Info (Get_Type (Inter)); + Mode : Object_Kind_Type; + By_Addr : Boolean; begin - case Get_Kind (Inter) is + -- Mechanism. + case Type_Mode_Valid (Tinfo.Type_Mode) is + when Type_Mode_Pass_By_Copy => + By_Addr := False; + when Type_Mode_Pass_By_Address => + By_Addr := True; + end case; + + case Iir_Kinds_Interface_Object_Declaration (Get_Kind (Inter)) is when Iir_Kind_Interface_Constant_Declaration - | Iir_Kind_Interface_Variable_Declaration | Iir_Kind_Interface_File_Declaration => Mode := Mode_Value; + when Iir_Kind_Interface_Variable_Declaration => + Mode := Mode_Value; + if Is_Foreign and then Get_Mode (Inter) in Iir_Out_Modes then + By_Addr := True; + end if; when Iir_Kind_Interface_Signal_Declaration => Mode := Mode_Signal; - when others => - Error_Kind ("translate_interface_type", Inter); - end case; - case Tinfo.Type_Mode is - when Type_Mode_Unknown => - raise Internal_Error; - when Type_Mode_By_Value => - return Tinfo.Ortho_Type (Mode); - when Type_Mode_By_Copy - | Type_Mode_By_Ref => - return Tinfo.Ortho_Ptr_Type (Mode); end case; + if By_Addr then + return Tinfo.Ortho_Ptr_Type (Mode); + else + return Tinfo.Ortho_Type (Mode); + end if; end Translate_Interface_Type; procedure Translate_Subprogram_Declaration (Spec : Iir) @@ -142,6 +150,7 @@ package body Trans.Chap2 is Info : constant Subprg_Info_Acc := Get_Info (Spec); Is_Func : constant Boolean := Get_Kind (Spec) = Iir_Kind_Function_Declaration; + Is_Foreign : constant Boolean := Get_Foreign_Flag (Spec); Inter : Iir; Arg_Info : Ortho_Info_Acc; Tinfo : Type_Info_Acc; @@ -151,13 +160,14 @@ package body Trans.Chap2 is Rtype : Iir; Id : O_Ident; Storage : O_Storage; - Foreign : Foreign_Info_Type := Foreign_Bad; + Foreign : Foreign_Info_Type; begin -- Set the identifier prefix with the subprogram identifier and -- overload number if any. Push_Subprg_Identifier (Spec, Mark); - if Get_Foreign_Flag (Spec) then + -- Create the subprogram identifier. + if Is_Foreign then -- Special handling for foreign subprograms. Foreign := Translate_Foreign_Id (Spec); case Foreign.Kind is @@ -172,6 +182,7 @@ package body Trans.Chap2 is end case; Storage := O_Storage_External; else + Foreign := Foreign_Bad; Id := Create_Identifier; Storage := Global_Storage; end if; @@ -207,13 +218,13 @@ package body Trans.Chap2 is -- gather them in a record. An access to the record is then -- passed to the procedure. Inter := Get_Interface_Declaration_Chain (Spec); - if Inter /= Null_Iir then + if Inter /= Null_Iir and then not Is_Foreign then Start_Record_Type (El_List); while Inter /= Null_Iir loop Arg_Info := Add_Info (Inter, Kind_Interface); New_Record_Field (El_List, Arg_Info.Interface_Field, Create_Identifier_Without_Prefix (Inter), - Translate_Interface_Type (Inter)); + Translate_Interface_Type (Inter, False)); Inter := Get_Chain (Inter); end loop; -- Declare the record type and an access to the record. @@ -241,19 +252,20 @@ package body Trans.Chap2 is end if; -- Instance parameter if any. - if not Get_Foreign_Flag (Spec) then + if not Is_Foreign then Subprgs.Create_Subprg_Instance (Interface_List, Spec); end if; -- Translate interfaces. - if Is_Func then + if Is_Func or else Is_Foreign then Inter := Get_Interface_Declaration_Chain (Spec); while Inter /= Null_Iir loop -- Create the info. Arg_Info := Add_Info (Inter, Kind_Interface); Arg_Info.Interface_Field := O_Fnode_Null; - Arg_Info.Interface_Type := Translate_Interface_Type (Inter); + Arg_Info.Interface_Type := + Translate_Interface_Type (Inter, Is_Foreign); New_Interface_Decl (Interface_List, Arg_Info.Interface_Node, Create_Identifier_Without_Prefix (Inter), @@ -264,7 +276,7 @@ package body Trans.Chap2 is Finish_Subprogram_Decl (Interface_List, Info.Ortho_Func); -- Call the hook for foreign subprograms. - if Get_Foreign_Flag (Spec) and then Foreign_Hook /= null then + if Is_Foreign and then Foreign_Hook /= null then Foreign_Hook.all (Spec, Foreign, Info.Ortho_Func); end if; @@ -853,15 +865,21 @@ package body Trans.Chap2 is pragma Assert (Src.C = null); pragma Assert (Src.Type_Transient_Chain = Null_Iir); when Kind_Object => - pragma Assert (Src.Object_Driver = Null_Var); - pragma Assert (Src.Object_Function = O_Dnode_Null); Dest.all := (Kind => Kind_Object, Object_Static => Src.Object_Static, Object_Var => Instantiate_Var (Src.Object_Var), - Object_Driver => Null_Var, - Object_Rti => Src.Object_Rti, - Object_Function => O_Dnode_Null); + Object_Rti => Src.Object_Rti); + when Kind_Signal => + pragma Assert (Src.Signal_Driver = Null_Var); + pragma Assert (Src.Signal_Function = O_Dnode_Null); + Dest.all := + (Kind => Kind_Signal, + Signal_Value => Instantiate_Var (Src.Signal_Value), + Signal_Sig => Instantiate_Var (Src.Signal_Sig), + Signal_Driver => Null_Var, + Signal_Rti => Src.Signal_Rti, + Signal_Function => O_Dnode_Null); when Kind_Subprg => Dest.Subprg_Frame_Scope := Instantiate_Var_Scope (Src.Subprg_Frame_Scope); diff --git a/src/vhdl/translate/trans-chap3.adb b/src/vhdl/translate/trans-chap3.adb index bc82209f8..3ecec89f4 100644 --- a/src/vhdl/translate/trans-chap3.adb +++ b/src/vhdl/translate/trans-chap3.adb @@ -255,18 +255,15 @@ package body Trans.Chap3 is procedure Translate_Bool_Type (Def : Iir_Enumeration_Type_Definition) is - Info : Type_Info_Acc; - El_List : Iir_List; - True_Lit, False_Lit : Iir_Enumeration_Literal; + Info : constant Type_Info_Acc := Get_Info (Def); + El_List : constant Iir_List := Get_Enumeration_Literal_List (Def); + pragma Assert (Get_Nbr_Elements (El_List) = 2); + + False_Lit : constant Iir := Get_Nth_Element (El_List, 0); + True_Lit : constant Iir := Get_Nth_Element (El_List, 1); + False_Node, True_Node : O_Cnode; begin - Info := Get_Info (Def); - El_List := Get_Enumeration_Literal_List (Def); - if Get_Nbr_Elements (El_List) /= 2 then - raise Internal_Error; - end if; - False_Lit := Get_Nth_Element (El_List, 0); - True_Lit := Get_Nth_Element (El_List, 1); New_Boolean_Type (Info.Ortho_Type (Mode_Value), Translate_Enumeration_Literal (False_Lit), False_Node, @@ -513,54 +510,18 @@ package body Trans.Chap3 is begin Start_Record_Type (Constr); New_Record_Field - (Constr, Info.T.Base_Field (Kind), Get_Identifier ("BASE"), + (Constr, Info.T.Base_Field (Kind), Wki_Base, Info.T.Base_Ptr_Type (Kind)); New_Record_Field - (Constr, Info.T.Bounds_Field (Kind), Get_Identifier ("BOUNDS"), + (Constr, Info.T.Bounds_Field (Kind), Wki_Bounds, Info.T.Bounds_Ptr_Type); Finish_Record_Type (Constr, Info.Ortho_Type (Kind)); end Create_Array_Fat_Pointer; - procedure Translate_Incomplete_Array_Type - (Def : Iir_Array_Type_Definition) - is - Arr_Info : Incomplete_Type_Info_Acc; - Info : Type_Info_Acc; - begin - Arr_Info := Get_Info (Def); - if Arr_Info.Incomplete_Array /= null then - -- This (incomplete) array type was already translated. - -- This is the case for a second access type definition to this - -- still incomplete array type. - return; - end if; - Info := new Ortho_Info_Type (Kind_Type); - Info.Type_Mode := Type_Mode_Fat_Array; - Info.Type_Incomplete := True; - Arr_Info.Incomplete_Array := Info; - - Info.T := Ortho_Info_Type_Array_Init; - Info.T.Bounds_Type := O_Tnode_Null; - - Info.T.Bounds_Ptr_Type := New_Access_Type (Info.T.Bounds_Type); - New_Type_Decl (Create_Identifier ("BOUNDP"), - Info.T.Bounds_Ptr_Type); - - Info.T.Base_Ptr_Type (Mode_Value) := New_Access_Type (O_Tnode_Null); - New_Type_Decl (Create_Identifier ("BASEP"), - Info.T.Base_Ptr_Type (Mode_Value)); - - Create_Array_Fat_Pointer (Info, Mode_Value); - - New_Type_Decl - (Create_Identifier, Info.Ortho_Type (Mode_Value)); - end Translate_Incomplete_Array_Type; - -- Declare the bounds types for DEF. procedure Translate_Array_Type_Bounds (Def : Iir_Array_Type_Definition; - Info : Type_Info_Acc; - Complete : Boolean) + Info : Type_Info_Acc) is Indexes_List : constant Iir_List := Get_Index_Subtype_Definition_List (Def); @@ -602,25 +563,20 @@ package body Trans.Chap3 is Finish_Record_Type (Constr, Info.T.Bounds_Type); New_Type_Decl (Create_Identifier ("BOUND"), Info.T.Bounds_Type); - if Complete then - Finish_Access_Type (Info.T.Bounds_Ptr_Type, Info.T.Bounds_Type); - else - Info.T.Bounds_Ptr_Type := New_Access_Type (Info.T.Bounds_Type); - New_Type_Decl (Create_Identifier ("BOUNDP"), - Info.T.Bounds_Ptr_Type); - end if; + Info.T.Bounds_Ptr_Type := New_Access_Type (Info.T.Bounds_Type); + New_Type_Decl (Create_Identifier ("BOUNDP"), + Info.T.Bounds_Ptr_Type); end Translate_Array_Type_Bounds; procedure Translate_Array_Type_Base (Def : Iir_Array_Type_Definition; - Info : Type_Info_Acc; - Complete : Boolean) + Info : Type_Info_Acc) is - El_Type : Iir; + El_Type : constant Iir := Get_Element_Subtype (Def); El_Tinfo : Type_Info_Acc; Id, Idptr : O_Ident; begin - El_Type := Get_Element_Subtype (Def); + -- Be sure the element type is translated. Translate_Type_Definition (El_Type, True); El_Tinfo := Get_Info (El_Type); @@ -637,12 +593,8 @@ package body Trans.Chap3 is case Kind is when Mode_Value => -- For the values. - Id := Create_Identifier ("BASE"); - if not Complete then - Idptr := Create_Identifier ("BASEP"); - else - Idptr := O_Ident_Nul; - end if; + Id := Wki_Base; + Idptr := Create_Identifier ("BASEP"); when Mode_Signal => -- For the signals Id := Create_Identifier ("SIGBASE"); @@ -652,14 +604,9 @@ package body Trans.Chap3 is New_Array_Type (El_Tinfo.Ortho_Type (Kind), Ghdl_Index_Type); New_Type_Decl (Id, Info.T.Base_Type (Kind)); - if Is_Equal (Idptr, O_Ident_Nul) then - Finish_Access_Type (Info.T.Base_Ptr_Type (Kind), - Info.T.Base_Type (Kind)); - else - Info.T.Base_Ptr_Type (Kind) := - New_Access_Type (Info.T.Base_Type (Kind)); - New_Type_Decl (Idptr, Info.T.Base_Ptr_Type (Kind)); - end if; + Info.T.Base_Ptr_Type (Kind) := + New_Access_Type (Info.T.Base_Type (Kind)); + New_Type_Decl (Idptr, Info.T.Base_Ptr_Type (Kind)); end loop; end if; end Translate_Array_Type_Base; @@ -668,25 +615,18 @@ package body Trans.Chap3 is (Def : Iir_Array_Type_Definition) is Info : constant Type_Info_Acc := Get_Info (Def); - -- If true, INFO was already partially filled, by a previous access - -- type definition to this incomplete array type. - Completion : constant Boolean := Info.Type_Mode = Type_Mode_Fat_Array; El_Tinfo : Type_Info_Acc; begin - if not Completion then - Info.Type_Mode := Type_Mode_Fat_Array; - Info.T := Ortho_Info_Type_Array_Init; - end if; - Translate_Array_Type_Base (Def, Info, Completion); - Translate_Array_Type_Bounds (Def, Info, Completion); + Info.Type_Mode := Type_Mode_Fat_Array; + Info.T := Ortho_Info_Type_Array_Init; + Translate_Array_Type_Base (Def, Info); + Translate_Array_Type_Bounds (Def, Info); Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; - if not Completion then - Create_Array_Fat_Pointer (Info, Mode_Value); - end if; + Create_Array_Fat_Pointer (Info, Mode_Value); if Get_Has_Signal_Flag (Def) then Create_Array_Fat_Pointer (Info, Mode_Signal); end if; - Finish_Type_Definition (Info, Completion); + Finish_Type_Definition (Info, False); El_Tinfo := Get_Info (Get_Element_Subtype (Def)); if Is_Complex_Type (El_Tinfo) then @@ -1017,9 +957,7 @@ package body Trans.Chap3 is function Get_Type_Alignmask (Info : Type_Info_Acc) return O_Enode is begin if Is_Complex_Type (Info) then - if Info.Type_Mode /= Type_Mode_Record then - raise Internal_Error; - end if; + pragma Assert (Info.Type_Mode = Type_Mode_Record); return New_Value (Get_Var (Info.C (Mode_Value).Align_Var)); else return Get_Type_Alignmask (Info.Ortho_Type (Mode_Value)); @@ -1222,56 +1160,56 @@ package body Trans.Chap3 is -- Access -- -------------- + -- Get the ortho designated type for access type DEF. + function Get_Ortho_Designated_Type (Def : Iir_Access_Type_Definition) + return O_Tnode + is + D_Type : constant Iir := Get_Designated_Type (Def); + D_Info : constant Type_Info_Acc := Get_Info (D_Type); + begin + if not Is_Fully_Constrained_Type (D_Type) then + return D_Info.T.Bounds_Type; + else + if D_Info.Type_Mode in Type_Mode_Arrays then + -- The designated type cannot be a sub array inside ortho. + -- FIXME: lift this restriction. + return D_Info.T.Base_Type (Mode_Value); + else + return D_Info.Ortho_Type (Mode_Value); + end if; + end if; + end Get_Ortho_Designated_Type; + procedure Translate_Access_Type (Def : Iir_Access_Type_Definition) is D_Type : constant Iir := Get_Designated_Type (Def); + -- Info for designated type may not be a type info: it may be an + -- incomplete type. D_Info : constant Ortho_Info_Acc := Get_Info (D_Type); Def_Info : constant Type_Info_Acc := Get_Info (Def); Dtype : O_Tnode; - Arr_Info : Type_Info_Acc; begin + -- No access types for signals. + Def_Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; + if not Is_Fully_Constrained_Type (D_Type) then - -- An access type to an unconstrained type definition is a fat - -- pointer. - Def_Info.Type_Mode := Type_Mode_Fat_Acc; - if D_Info.Kind = Kind_Incomplete_Type then - Translate_Incomplete_Array_Type (D_Type); - Arr_Info := D_Info.Incomplete_Array; - Def_Info.Ortho_Type := Arr_Info.Ortho_Type; - Def_Info.T := Arr_Info.T; - else - Def_Info.Ortho_Type := D_Info.Ortho_Type; - Def_Info.T := D_Info.T; - end if; - Def_Info.Ortho_Ptr_Type (Mode_Value) := - New_Access_Type (Def_Info.Ortho_Type (Mode_Value)); - New_Type_Decl (Create_Identifier ("PTR"), - Def_Info.Ortho_Ptr_Type (Mode_Value)); + -- An access type to an unconstrained type definition is a pointer + -- to bounds and base. + Def_Info.Type_Mode := Type_Mode_Bounds_Acc; else -- Otherwise, it is a thin pointer. Def_Info.Type_Mode := Type_Mode_Acc; - -- No access types for signals. - Def_Info.Ortho_Type (Mode_Signal) := O_Tnode_Null; - - if D_Info.Kind = Kind_Incomplete_Type then - Dtype := O_Tnode_Null; - elsif Is_Complex_Type (D_Info) then - -- FIXME: clean here when the ortho_type of a array - -- complex_type is correctly set (not a pointer). - Def_Info.Ortho_Type (Mode_Value) := - D_Info.Ortho_Ptr_Type (Mode_Value); - Finish_Type_Definition (Def_Info, True); - return; - elsif D_Info.Type_Mode in Type_Mode_Arrays then - -- The designated type cannot be a sub array inside ortho. - -- FIXME: lift this restriction. - Dtype := D_Info.T.Base_Type (Mode_Value); - else - Dtype := D_Info.Ortho_Type (Mode_Value); - end if; - Def_Info.Ortho_Type (Mode_Value) := New_Access_Type (Dtype); - Finish_Type_Definition (Def_Info); end if; + + if D_Info.Kind = Kind_Incomplete_Type then + -- Incomplete access. + Dtype := O_Tnode_Null; + else + Dtype := Get_Ortho_Designated_Type (Def); + end if; + + Def_Info.Ortho_Type (Mode_Value) := New_Access_Type (Dtype); + Finish_Type_Definition (Def_Info); end Translate_Access_Type; ------------------------ @@ -1294,20 +1232,16 @@ package body Trans.Chap3 is Ctype := Get_Type (Get_Type_Declarator (Def)); Info := Add_Info (Ctype, Kind_Incomplete_Type); Info.Incomplete_Type := Def; - Info.Incomplete_Array := null; end Translate_Incomplete_Type; - -- CTYPE is the type which has been completed. procedure Translate_Complete_Type - (Incomplete_Info : in out Incomplete_Type_Info_Acc; Ctype : Iir) + (Incomplete_Info : in out Incomplete_Type_Info_Acc) is - C_Info : constant Type_Info_Acc := Get_Info (Ctype); - List : Iir_List; + List : constant Iir_List := + Get_Incomplete_Type_List (Incomplete_Info.Incomplete_Type); Atype : Iir; Def_Info : Type_Info_Acc; - Dtype : O_Tnode; begin - List := Get_Incomplete_Type_List (Incomplete_Info.Incomplete_Type); for I in Natural loop Atype := Get_Nth_Element (List, I); exit when Atype = Null_Iir; @@ -1316,13 +1250,9 @@ package body Trans.Chap3 is pragma Assert (Get_Kind (Atype) = Iir_Kind_Access_Type_Definition); Def_Info := Get_Info (Atype); - case C_Info.Type_Mode is - when Type_Mode_Arrays => - Dtype := C_Info.T.Base_Type (Mode_Value); - when others => - Dtype := C_Info.Ortho_Type (Mode_Value); - end case; - Finish_Access_Type (Def_Info.Ortho_Type (Mode_Value), Dtype); + Finish_Access_Type + (Def_Info.Ortho_Type (Mode_Value), + Get_Ortho_Designated_Type (Atype)); end loop; Unchecked_Deallocation (Incomplete_Info); end Translate_Complete_Type; @@ -1995,24 +1925,18 @@ package body Trans.Chap3 is -- If the definition is already translated, return now. Info := Get_Info (Def); if Info /= null then - if Info.Kind = Kind_Type then - -- The subtype was already translated. - return; - end if; - if Info.Kind = Kind_Incomplete_Type then - -- Type is being completed. - Complete_Info := Info; - Clear_Info (Def); - if Complete_Info.Incomplete_Array /= null then - Info := Complete_Info.Incomplete_Array; - Set_Info (Def, Info); - Unchecked_Deallocation (Complete_Info); - else + case Info.Kind is + when Kind_Type => + -- The subtype was already translated. + return; + when Kind_Incomplete_Type => + -- Type is being completed. + Complete_Info := Info; + Clear_Info (Def); Info := Add_Info (Def, Kind_Type); - end if; - else - raise Internal_Error; - end if; + when others => + raise Internal_Error; + end case; else Complete_Info := null; Info := Add_Info (Def, Kind_Type); @@ -2129,25 +2053,23 @@ package body Trans.Chap3 is end case; if Complete_Info /= null then - Translate_Complete_Type (Complete_Info, Def); + Translate_Complete_Type (Complete_Info); end if; end Translate_Type_Definition; procedure Translate_Bool_Type_Definition (Def : Iir) is Info : Type_Info_Acc; + pragma Unreferenced (Info); begin - -- If the definition is already translated, return now. - Info := Get_Info (Def); - if Info /= null then - raise Internal_Error; - end if; + -- Not already translated. + pragma Assert (Get_Info (Def) = null); + + -- A boolean type is an enumerated type. + pragma Assert (Get_Kind (Def) = Iir_Kind_Enumeration_Type_Definition); Info := Add_Info (Def, Kind_Type); - if Get_Kind (Def) /= Iir_Kind_Enumeration_Type_Definition then - raise Internal_Error; - end if; Translate_Bool_Type (Def); -- This is usually done in translate_type_definition, but boolean @@ -2168,10 +2090,9 @@ package body Trans.Chap3 is -- been declared by the same type declarator. This avoids several -- elaboration of the same type. Def := Get_Base_Type (Def); - if Get_Type_Declarator (Def) /= Decl then - -- Can this happen ?? - raise Internal_Error; - end if; + + -- Consistency check. + pragma Assert (Get_Type_Declarator (Def) = Decl); elsif Get_Kind (Def) = Iir_Kind_Incomplete_Type_Definition then return; end if; @@ -2232,9 +2153,9 @@ package body Trans.Chap3 is Final : Boolean; begin Chap4.Elab_Declaration_Chain (Def, Final); - if Final then - raise Internal_Error; - end if; + + -- No finalizer in protected types (only subprograms). + pragma Assert (Final = False); end; return; when others => @@ -2425,15 +2346,13 @@ package body Trans.Chap3 is Info : constant Type_Info_Acc := Get_Type_Info (Arr); begin case Info.Type_Mode is - when Type_Mode_Fat_Array - | Type_Mode_Fat_Acc => + when Type_Mode_Fat_Array => declare - Kind : Object_Kind_Type; + Kind : constant Object_Kind_Type := Get_Object_Kind (Arr); begin - Kind := Get_Object_Kind (Arr); return Lp2M (New_Selected_Element (M2Lv (Arr), - Info.T.Bounds_Field (Kind)), + Info.T.Bounds_Field (Kind)), Info, Mode_Value, Info.T.Bounds_Type, @@ -2441,6 +2360,8 @@ package body Trans.Chap3 is end; when Type_Mode_Array => return Get_Array_Type_Bounds (Info); + when Type_Mode_Bounds_Acc => + return Lp2M (M2Lv (Arr), Info, Mode_Value); when others => raise Internal_Error; end case; @@ -2508,21 +2429,18 @@ package body Trans.Chap3 is function Get_Array_Base (Arr : Mnode) return Mnode is - Info : Type_Info_Acc; + Info : constant Type_Info_Acc := Get_Type_Info (Arr); begin - Info := Get_Type_Info (Arr); case Info.Type_Mode is - when Type_Mode_Fat_Array - | Type_Mode_Fat_Acc => + when Type_Mode_Fat_Array => declare - Kind : Object_Kind_Type; + Kind : constant Object_Kind_Type := Get_Object_Kind (Arr); begin - Kind := Get_Object_Kind (Arr); return Lp2M (New_Selected_Element (M2Lv (Arr), - Info.T.Base_Field (Kind)), + Info.T.Base_Field (Kind)), Info, - Get_Object_Kind (Arr), + Kind, Info.T.Base_Type (Kind), Info.T.Base_Ptr_Type (Kind)); end; @@ -2533,6 +2451,17 @@ package body Trans.Chap3 is end case; end Get_Array_Base; + function Get_Bounds_Acc_Base + (Acc : O_Enode; D_Type : Iir) return O_Enode + is + D_Info : constant Type_Info_Acc := Get_Info (D_Type); + begin + return Add_Pointer + (Acc, + New_Lit (New_Sizeof (D_Info.T.Bounds_Type, Ghdl_Index_Type)), + D_Info.T.Base_Ptr_Type (Mode_Value)); + end Get_Bounds_Acc_Base; + function Reindex_Complex_Array (Base : Mnode; Atype : Iir; Index : O_Enode; Res_Info : Type_Info_Acc) return Mnode @@ -2542,19 +2471,14 @@ package body Trans.Chap3 is Kind : constant Object_Kind_Type := Get_Object_Kind (Base); begin pragma Assert (Is_Complex_Type (El_Tinfo)); - return - E2M - (New_Unchecked_Address - (New_Slice - (New_Access_Element - (New_Convert_Ov (M2E (Base), Char_Ptr_Type)), - Chararray_Type, - New_Dyadic_Op (ON_Mul_Ov, - New_Value - (Get_Var (El_Tinfo.C (Kind).Size_Var)), - Index)), - El_Tinfo.Ortho_Ptr_Type (Kind)), - Res_Info, Kind); + return E2M + (Add_Pointer + (M2E (Base), + New_Dyadic_Op (ON_Mul_Ov, + New_Value (Get_Var (El_Tinfo.C (Kind).Size_Var)), + Index), + El_Tinfo.Ortho_Ptr_Type (Kind)), + Res_Info, Kind); end Reindex_Complex_Array; function Index_Base (Base : Mnode; Atype : Iir; Index : O_Enode) @@ -2592,6 +2516,22 @@ package body Trans.Chap3 is end if; end Slice_Base; + procedure Maybe_Call_Type_Builder (Obj : Mnode; Obj_Type : Iir) + is + Dinfo : constant Type_Info_Acc := + Get_Info (Get_Base_Type (Obj_Type)); + Kind : constant Object_Kind_Type := Get_Object_Kind (Obj); + begin + if Is_Complex_Type (Dinfo) + and then Dinfo.C (Kind).Builder_Need_Func + then + Open_Temp; + -- Build the type. + Chap3.Gen_Call_Type_Builder (Obj, Obj_Type); + Close_Temp; + end if; + end Maybe_Call_Type_Builder; + procedure Allocate_Fat_Array_Base (Alloc_Kind : Allocation_Kind; Res : Mnode; Arr_Type : Iir) @@ -2608,14 +2548,7 @@ package body Trans.Chap3 is (M2Lp (Chap3.Get_Array_Base (Res)), Gen_Alloc (Alloc_Kind, Length, Dinfo.T.Base_Ptr_Type (Kind))); - if Is_Complex_Type (Dinfo) - and then Dinfo.C (Kind).Builder_Need_Func - then - Open_Temp; - -- Build the type. - Chap3.Gen_Call_Type_Builder (Res, Arr_Type); - Close_Temp; - end if; + Maybe_Call_Type_Builder (Res, Arr_Type); end Allocate_Fat_Array_Base; procedure Create_Array_Subtype (Sub_Type : Iir; Transient : Boolean) @@ -2648,14 +2581,11 @@ package body Trans.Chap3 is begin case Info.Type_Mode is when Type_Mode_Scalar - | Type_Mode_Acc + | Type_Mode_Acc + | Type_Mode_Bounds_Acc | Type_Mode_File => -- Scalar or thin pointer. New_Assign_Stmt (M2Lv (Dest), Src); - when Type_Mode_Fat_Acc => - -- a fat pointer. - D := Stabilize (Dest); - Copy_Fat_Pointer (D, Stabilize (E2M (Src, Info, Kind))); when Type_Mode_Fat_Array => -- a fat array. D := Stabilize (Dest); @@ -2672,17 +2602,19 @@ package body Trans.Chap3 is end case; end Translate_Object_Copy; - function Get_Object_Size (Obj : Mnode; Obj_Type : Iir) - return O_Enode + function Get_Subtype_Size + (Atype : Iir; Bounds : Mnode; Kind : Object_Kind_Type) return O_Enode is - Type_Info : constant Type_Info_Acc := Get_Type_Info (Obj); - Kind : constant Object_Kind_Type := Get_Object_Kind (Obj); + Type_Info : constant Type_Info_Acc := Get_Info (Atype); begin + -- The length is pre-computed for a complex type (except for unbounded + -- types). if Is_Complex_Type (Type_Info) and then Type_Info.C (Kind).Size_Var /= Null_Var then return New_Value (Get_Var (Type_Info.C (Kind).Size_Var)); end if; + case Type_Info.Type_Mode is when Type_Mode_Non_Composite | Type_Mode_Array @@ -2691,29 +2623,30 @@ package body Trans.Chap3 is Ghdl_Index_Type)); when Type_Mode_Fat_Array => declare - El_Type : Iir; - El_Tinfo : Type_Info_Acc; - Obj_Bt : Iir; - Sz : O_Enode; + El_Type : constant Iir := Get_Element_Subtype (Atype); + El_Sz : O_Enode; begin - Obj_Bt := Get_Base_Type (Obj_Type); - El_Type := Get_Element_Subtype (Obj_Bt); - El_Tinfo := Get_Info (El_Type); - -- See create_type_definition_size_var. - Sz := Get_Object_Size (T2M (El_Type, Kind), El_Type); - if Is_Complex_Type (El_Tinfo) then - Sz := New_Dyadic_Op - (ON_Add_Ov, - Sz, - New_Lit (New_Sizeof (El_Tinfo.Ortho_Ptr_Type (Kind), - Ghdl_Index_Type))); - end if; + -- See create_array_size_var. + El_Sz := Get_Subtype_Size (El_Type, Mnode_Null, Kind); return New_Dyadic_Op - (ON_Mul_Ov, Chap3.Get_Array_Length (Obj, Obj_Bt), Sz); + (ON_Mul_Ov, Chap3.Get_Bounds_Length (Bounds, Atype), El_Sz); end; when others => raise Internal_Error; end case; + end Get_Subtype_Size; + + function Get_Object_Size (Obj : Mnode; Obj_Type : Iir) + return O_Enode + is + Type_Info : constant Type_Info_Acc := Get_Type_Info (Obj); + Kind : constant Object_Kind_Type := Get_Object_Kind (Obj); + begin + if Type_Info.Type_Mode = Type_Mode_Fat_Array then + return Get_Subtype_Size (Obj_Type, Get_Array_Bounds (Obj), Kind); + else + return Get_Subtype_Size (Obj_Type, Mnode_Null, Kind); + end if; end Get_Object_Size; procedure Translate_Object_Allocation @@ -2730,9 +2663,9 @@ package body Trans.Chap3 is New_Assign_Stmt (M2Lp (Chap3.Get_Array_Bounds (Res)), Gen_Alloc (Alloc_Kind, - New_Lit (New_Sizeof (Dinfo.T.Bounds_Type, - Ghdl_Index_Type)), - Dinfo.T.Bounds_Ptr_Type)); + New_Lit (New_Sizeof (Dinfo.T.Bounds_Type, + Ghdl_Index_Type)), + Dinfo.T.Bounds_Ptr_Type)); -- Copy bounds to the allocated area. Gen_Memcpy @@ -2746,19 +2679,10 @@ package body Trans.Chap3 is New_Assign_Stmt (M2Lp (Res), Gen_Alloc (Alloc_Kind, - Chap3.Get_Object_Size (T2M (Obj_Type, Kind), - Obj_Type), + Chap3.Get_Object_Size (T2M (Obj_Type, Kind), Obj_Type), Dinfo.Ortho_Ptr_Type (Kind))); - if Is_Complex_Type (Dinfo) - and then Dinfo.C (Kind).Builder_Need_Func - then - Open_Temp; - -- Build the type. - Chap3.Gen_Call_Type_Builder (Res, Obj_Type); - Close_Temp; - end if; - + Maybe_Call_Type_Builder (Res, Obj_Type); end if; end Translate_Object_Allocation; @@ -2774,59 +2698,21 @@ package body Trans.Chap3 is -- Performs deallocation of PARAM (the parameter of a deallocate call). procedure Translate_Object_Deallocation (Param : Iir) is - -- Performs deallocation of field FIELD of type FTYPE of PTR. - -- If FIELD is O_FNODE_NULL, deallocate PTR (of type FTYPE). - -- Here, deallocate means freeing memory and clearing to null. - procedure Deallocate_1 - (Ptr : Mnode; Field : O_Fnode; Ftype : O_Tnode) - is - L : O_Lnode; - begin - for I in 0 .. 1 loop - L := M2Lv (Ptr); - if Field /= O_Fnode_Null then - L := New_Selected_Element (L, Field); - end if; - case I is - when 0 => - -- Call deallocator. - Gen_Deallocate (New_Value (L)); - when 1 => - -- set the value to 0. - New_Assign_Stmt (L, New_Lit (New_Null_Access (Ftype))); - end case; - end loop; - end Deallocate_1; - - Param_Type : Iir; + Param_Type : constant Iir := Get_Type (Param); + Info : constant Type_Info_Acc := Get_Info (Param_Type); Val : Mnode; - Info : Type_Info_Acc; - Binfo : Type_Info_Acc; begin -- Compute parameter Val := Chap6.Translate_Name (Param); - if Get_Object_Kind (Val) = Mode_Signal then - raise Internal_Error; - end if; + pragma Assert (Get_Object_Kind (Val) = Mode_Value); Stabilize (Val); - Param_Type := Get_Type (Param); - Info := Get_Info (Param_Type); - case Info.Type_Mode is - when Type_Mode_Fat_Acc => - -- This is a fat pointer. - -- Deallocate base and bounds. - Binfo := Get_Info (Get_Designated_Type (Param_Type)); - Deallocate_1 (Val, Binfo.T.Base_Field (Mode_Value), - Binfo.T.Base_Ptr_Type (Mode_Value)); - Deallocate_1 (Val, Binfo.T.Bounds_Field (Mode_Value), - Binfo.T.Bounds_Ptr_Type); - when Type_Mode_Acc => - -- This is a thin pointer. - Deallocate_1 (Val, O_Fnode_Null, - Info.Ortho_Type (Mode_Value)); - when others => - raise Internal_Error; - end case; + + -- Call deallocator. + Gen_Deallocate (New_Value (M2Lv (Val))); + + -- Set the value to null. + New_Assign_Stmt + (M2Lv (Val), New_Lit (New_Null_Access (Info.Ortho_Type (Mode_Value)))); end Translate_Object_Deallocation; function Not_In_Range (Value : O_Dnode; Atype : Iir) return O_Enode diff --git a/src/vhdl/translate/trans-chap3.ads b/src/vhdl/translate/trans-chap3.ads index b5f42e887..69d1137b3 100644 --- a/src/vhdl/translate/trans-chap3.ads +++ b/src/vhdl/translate/trans-chap3.ads @@ -172,6 +172,10 @@ package Trans.Chap3 is -- Get array bounds for type ATYPE. function Get_Array_Type_Bounds (Atype : Iir) return Mnode; + -- Return a pointer to the base from bounds_acc ACC. + function Get_Bounds_Acc_Base + (Acc : O_Enode; D_Type : Iir) return O_Enode; + -- Deallocate OBJ. procedure Gen_Deallocate (Obj : O_Enode); @@ -188,17 +192,25 @@ package Trans.Chap3 is Obj_Type : Iir; Bounds : Mnode); - -- Copy SRC to DEST. - -- Both have the same type, OTYPE. - -- Furthermore, arrays are of the same length. + -- Low level copy of SRC to DEST. Both have the same type, OBJ_TYPE. + -- There is no length check, so arrays must be of the same length. procedure Translate_Object_Copy (Dest : Mnode; Src : O_Enode; Obj_Type : Iir); + -- Get size (in bytes with type ghdl_index_type) of subtype ATYPE. + -- For an unconstrained array, BOUNDS must be set, otherwise it may be a + -- null_mnode. + function Get_Subtype_Size + (Atype : Iir; Bounds : Mnode; Kind : Object_Kind_Type) return O_Enode; + -- Get size (in bytes with type ghdl_index_type) of object OBJ. -- For an unconstrained array, OBJ must be really an object, otherwise, - -- it may be a null_mnode, created by T2M. + -- it may be the result of T2M. function Get_Object_Size (Obj : Mnode; Obj_Type : Iir) return O_Enode; + -- If needed call the procedure to build OBJ. + procedure Maybe_Call_Type_Builder (Obj : Mnode; Obj_Type : Iir); + -- Allocate the base of a fat array, whose length is determined from -- the bounds. -- RES_PTR is a pointer to the fat pointer (must be a variable that diff --git a/src/vhdl/translate/trans-chap4.adb b/src/vhdl/translate/trans-chap4.adb index d9de806eb..852be4fd7 100644 --- a/src/vhdl/translate/trans-chap4.adb +++ b/src/vhdl/translate/trans-chap4.adb @@ -153,10 +153,9 @@ package body Trans.Chap4 is Sig_Type := Get_Object_Type (Type_Info, Mode_Signal); pragma Assert (Sig_Type /= O_Tnode_Null); - Info := Add_Info (Decl, Kind_Object); + Info := Add_Info (Decl, Kind_Signal); - Info.Object_Var := - Create_Var (Create_Var_Identifier (Decl), Sig_Type); + Info.Signal_Sig := Create_Var (Create_Var_Identifier (Decl), Sig_Type); case Get_Kind (Decl) is when Iir_Kind_Signal_Declaration @@ -184,9 +183,9 @@ package body Trans.Chap4 is --Chap3.Translate_Object_Subtype (Decl); pragma Assert (Sig_Type /= O_Tnode_Null); - Info := Add_Info (Decl, Kind_Object); + Info := Add_Info (Decl, Kind_Signal); - Info.Object_Var := Create_Var (Create_Uniq_Identifier, Sig_Type); + Info.Signal_Sig := Create_Var (Create_Uniq_Identifier, Sig_Type); end Create_Implicit_Signal; procedure Create_File_Object (El : Iir_File_Declaration) @@ -238,10 +237,8 @@ package body Trans.Chap4 is Kind : constant Object_Kind_Type := Get_Object_Kind (Var); Targ : Mnode; begin - if Type_Info.Type_Mode = Type_Mode_Fat_Array then - -- Cannot allocate unconstrained object (since size is unknown). - raise Internal_Error; - end if; + -- Cannot allocate unconstrained object (since size is unknown). + pragma Assert (Type_Info.Type_Mode /= Type_Mode_Fat_Array); if not Is_Complex_Type (Type_Info) then -- Object is not complex. @@ -257,11 +254,10 @@ package body Trans.Chap4 is end if; -- Allocate variable. - New_Assign_Stmt - (M2Lp (Targ), - Gen_Alloc (Alloc_Kind, - Chap3.Get_Object_Size (Var, Obj_Type), - Type_Info.Ortho_Ptr_Type (Kind))); + New_Assign_Stmt (M2Lp (Targ), + Gen_Alloc (Alloc_Kind, + Chap3.Get_Object_Size (Var, Obj_Type), + Type_Info.Ortho_Ptr_Type (Kind))); if Type_Info.C (Kind).Builder_Need_Func then -- Build the type. @@ -277,10 +273,10 @@ package body Trans.Chap4 is -- FIXME: should use translate_aggregate_others. procedure Init_Array_Object (Obj : Mnode; Obj_Type : Iir) is - Sobj : Mnode; - -- Type of the object. - Type_Info : Type_Info_Acc; + Type_Info : constant Type_Info_Acc := Get_Info (Obj_Type); + + Sobj : Mnode; -- Iterator for the elements. Index : O_Dnode; @@ -290,8 +286,6 @@ package body Trans.Chap4 is Label : O_Snode; begin - Type_Info := Get_Info (Obj_Type); - -- Iterate on all elements of the object. Open_Temp; @@ -330,11 +324,9 @@ package body Trans.Chap4 is procedure Init_Protected_Object (Obj : Mnode; Obj_Type : Iir) is + Info : constant Type_Info_Acc := Get_Info (Obj_Type); Assoc : O_Assoc_List; - Info : Type_Info_Acc; begin - Info := Get_Info (Obj_Type); - -- Call the initializer. Start_Association (Assoc, Info.T.Prot_Init_Subprg); Subprgs.Add_Subprg_Instance_Assoc (Assoc, Info.T.Prot_Init_Instance); @@ -345,12 +337,10 @@ package body Trans.Chap4 is procedure Fini_Protected_Object (Decl : Iir) is + Info : constant Type_Info_Acc := Get_Info (Get_Type (Decl)); Obj : Mnode; Assoc : O_Assoc_List; - Info : Type_Info_Acc; begin - Info := Get_Info (Get_Type (Decl)); - Obj := Chap6.Translate_Name (Decl); -- Call the Finalizator. Start_Association (Assoc, Info.T.Prot_Final_Subprg); @@ -365,7 +355,8 @@ package body Trans.Chap4 is case Tinfo.Type_Mode is when Type_Mode_Scalar => return Chap14.Translate_Left_Type_Attribute (Atype); - when Type_Mode_Acc => + when Type_Mode_Acc + | Type_Mode_Bounds_Acc => return New_Lit (New_Null_Access (Tinfo.Ortho_Type (Mode_Value))); when others => Error_Kind ("get_scalar_initial_value", Atype); @@ -378,27 +369,9 @@ package body Trans.Chap4 is begin case Tinfo.Type_Mode is when Type_Mode_Scalar - | Type_Mode_Acc => + | Type_Mode_Acc + | Type_Mode_Bounds_Acc => New_Assign_Stmt (M2Lv (Obj), Get_Scalar_Initial_Value (Obj_Type)); - when Type_Mode_Fat_Acc => - declare - Dinfo : Type_Info_Acc; - Sobj : Mnode; - begin - Open_Temp; - Sobj := Stabilize (Obj); - Dinfo := Get_Info (Get_Designated_Type (Obj_Type)); - New_Assign_Stmt - (New_Selected_Element (M2Lv (Sobj), - Dinfo.T.Bounds_Field (Mode_Value)), - New_Lit (New_Null_Access (Dinfo.T.Bounds_Ptr_Type))); - New_Assign_Stmt - (New_Selected_Element (M2Lv (Sobj), - Dinfo.T.Base_Field (Mode_Value)), - New_Lit (New_Null_Access - (Dinfo.T.Base_Ptr_Type (Mode_Value)))); - Close_Temp; - end; when Type_Mode_Arrays => Init_Array_Object (Obj, Obj_Type); when Type_Mode_Record => @@ -587,11 +560,9 @@ package body Trans.Chap4 is procedure Fini_Object (Obj : Iir) is - Obj_Type : Iir; - Type_Info : Type_Info_Acc; + Obj_Type : constant Iir := Get_Type (Obj); + Type_Info : constant Type_Info_Acc := Get_Info (Obj_Type); begin - Obj_Type := Get_Type (Obj); - Type_Info := Get_Info (Obj_Type); if Type_Info.Type_Mode = Type_Mode_Fat_Array then declare V : Mnode; @@ -629,11 +600,13 @@ package body Trans.Chap4 is Len := Create_Temp_Init (Ghdl_Index_Type, Chap3.Get_Array_Length (Ssig, Sig_Type)); + -- Can dereference the first index only if the array is not a + -- null array. Start_If_Stmt (If_Blk, New_Compare_Op (ON_Neq, - New_Obj_Value (Len), - New_Lit (Ghdl_Index_0), - Ghdl_Bool_Type)); + New_Obj_Value (Len), + New_Lit (Ghdl_Index_0), + Ghdl_Bool_Type)); New_Assign_Stmt (New_Obj (Len), New_Dyadic_Op @@ -650,15 +623,14 @@ package body Trans.Chap4 is end; when Type_Mode_Record => declare - List : Iir_List; + List : constant Iir_List := + Get_Elements_Declaration_List (Get_Base_Type (Sig_Type)); El : Iir; Res : O_Enode; E : O_Enode; Sig_El : Mnode; Ssig : Mnode; begin - List := - Get_Elements_Declaration_List (Get_Base_Type (Sig_Type)); Ssig := Stabilize (Sig); Res := O_Enode_Null; for I in Natural loop @@ -681,7 +653,7 @@ package body Trans.Chap4 is when Type_Mode_Unknown | Type_Mode_File | Type_Mode_Acc - | Type_Mode_Fat_Acc + | Type_Mode_Bounds_Acc | Type_Mode_Protected => raise Internal_Error; end case; @@ -724,7 +696,7 @@ package body Trans.Chap4 is when Type_Mode_Unknown | Type_Mode_File | Type_Mode_Acc - | Type_Mode_Fat_Acc + | Type_Mode_Bounds_Acc | Type_Mode_Protected => raise Internal_Error; end case; @@ -790,9 +762,9 @@ package body Trans.Chap4 is Start_If_Stmt (If_Stmt, New_Compare_Op (ON_Eq, - New_Value (New_Acc_Value (New_Obj (Targ_Ptr))), - New_Lit (New_Null_Access (Ghdl_Signal_Ptr)), - Ghdl_Bool_Type)); + New_Value (New_Acc_Value (New_Obj (Targ_Ptr))), + New_Lit (New_Null_Access (Ghdl_Signal_Ptr)), + Ghdl_Bool_Type)); end if; case Type_Info.Type_Mode is @@ -872,8 +844,8 @@ package body Trans.Chap4 is New_Compare_Op (ON_Eq, New_Convert_Ov (M2E (Get_Leftest_Signal (Targ, - Targ_Type)), - Ghdl_Signal_Ptr), + Targ_Type)), + Ghdl_Signal_Ptr), New_Lit (New_Null_Access (Ghdl_Signal_Ptr)), Ghdl_Bool_Type)); --Res.Check_Null := False; @@ -961,7 +933,7 @@ package body Trans.Chap4 is -- Elaborate signal subtypes and allocate the storage for the object. procedure Elab_Signal_Declaration_Storage (Decl : Iir) is - Sig_Type : Iir; + Sig_Type : constant Iir := Get_Type (Decl); Type_Info : Type_Info_Acc; Name_Node : Mnode; begin @@ -969,7 +941,6 @@ package body Trans.Chap4 is Open_Temp; - Sig_Type := Get_Type (Decl); Chap3.Elab_Object_Subtype (Sig_Type); Type_Info := Get_Info (Sig_Type); @@ -987,11 +958,11 @@ package body Trans.Chap4 is function Has_Direct_Driver (Sig : Iir) return Boolean is - Info : Ortho_Info_Acc; + Info : constant Ortho_Info_Acc := Get_Info (Get_Object_Prefix (Sig)); begin - Info := Get_Info (Get_Object_Prefix (Sig)); - return Info.Kind = Kind_Object - and then Info.Object_Driver /= Null_Var; + -- Can be an alias ? + return Info.Kind = Kind_Signal + and then Info.Signal_Driver /= Null_Var; end Has_Direct_Driver; procedure Elab_Direct_Driver_Declaration_Storage (Decl : Iir) @@ -1004,8 +975,7 @@ package body Trans.Chap4 is Open_Temp; if Type_Info.Type_Mode = Type_Mode_Fat_Array then - Name_Node := Get_Var (Sig_Info.Object_Driver, - Type_Info, Mode_Value); + Name_Node := Get_Var (Sig_Info.Signal_Driver, Type_Info, Mode_Value); Name_Node := Stabilize (Name_Node); -- Copy bounds from signal. New_Assign_Stmt @@ -1014,8 +984,7 @@ package body Trans.Chap4 is -- Allocate base. Chap3.Allocate_Fat_Array_Base (Alloc_System, Name_Node, Sig_Type); elsif Is_Complex_Type (Type_Info) then - Name_Node := Get_Var (Sig_Info.Object_Driver, - Type_Info, Mode_Value); + Name_Node := Get_Var (Sig_Info.Signal_Driver, Type_Info, Mode_Value); Allocate_Complex_Object (Sig_Type, Alloc_System, Name_Node); end if; @@ -1049,16 +1018,15 @@ package body Trans.Chap4 is New_Association (Assoc, New_Lit (New_Global_Unchecked_Address - (Get_Info (Base_Decl).Object_Rti, - Rtis.Ghdl_Rti_Access))); + (Get_Info (Base_Decl).Signal_Rti, + Rtis.Ghdl_Rti_Access))); Rtis.Associate_Rti_Context (Assoc, Parent); New_Procedure_Call (Assoc); end; Name_Node := Chap6.Translate_Name (Decl); - if Get_Object_Kind (Name_Node) /= Mode_Signal then - raise Internal_Error; - end if; + -- Consistency check: a signal name is a signal. + pragma Assert (Get_Object_Kind (Name_Node) = Mode_Signal); if Decl = Base_Decl then Data.Already_Resolved := False; @@ -1095,10 +1063,10 @@ package body Trans.Chap4 is procedure Elab_Signal_Attribute (Decl : Iir) is + Info : constant Signal_Info_Acc := Get_Info (Decl); + Dtype : constant Iir := Get_Type (Decl); + Type_Info : constant Type_Info_Acc := Get_Info (Dtype); Assoc : O_Assoc_List; - Dtype : Iir; - Type_Info : Type_Info_Acc; - Info : Object_Info_Acc; Prefix : Iir; Prefix_Node : Mnode; Res : O_Enode; @@ -1108,9 +1076,6 @@ package body Trans.Chap4 is begin New_Debug_Line_Stmt (Get_Line_Number (Decl)); - Info := Get_Info (Decl); - Dtype := Get_Type (Decl); - Type_Info := Get_Info (Dtype); -- Create the signal (with the time) case Get_Kind (Decl) is when Iir_Kind_Stable_Attribute => @@ -1138,7 +1103,7 @@ package body Trans.Chap4 is end case; Res := New_Convert_Ov (New_Function_Call (Assoc), Type_Info.Ortho_Type (Mode_Signal)); - New_Assign_Stmt (Get_Var (Info.Object_Var), Res); + New_Assign_Stmt (Get_Var (Info.Signal_Sig), Res); -- Register all signals this depends on. Prefix := Get_Prefix (Decl); @@ -1238,15 +1203,13 @@ package body Trans.Chap4 is procedure Elab_Signal_Delayed_Attribute (Decl : Iir) is + Sig_Type : constant Iir := Get_Type (Decl); + Type_Info : constant Type_Info_Acc := Get_Info (Sig_Type); Name_Node : Mnode; - Sig_Type : Iir; - Type_Info : Type_Info_Acc; Pfx_Node : Mnode; Data : Delayed_Signal_Data; begin Name_Node := Chap6.Translate_Name (Decl); - Sig_Type := Get_Type (Decl); - Type_Info := Get_Info (Sig_Type); if Is_Complex_Type (Type_Info) then Allocate_Complex_Object (Sig_Type, Alloc_System, Name_Node); @@ -1264,21 +1227,19 @@ package body Trans.Chap4 is procedure Elab_File_Declaration (Decl : Iir_File_Declaration) is + Is_Text : constant Boolean := Get_Text_File_Flag (Get_Type (Decl)); + File_Name : constant Iir := Get_File_Logical_Name (Decl); Constr : O_Assoc_List; Name : Mnode; - File_Name : Iir; Open_Kind : Iir; Mode_Val : O_Enode; Str : O_Enode; - Is_Text : Boolean; Info : Type_Info_Acc; begin -- Elaborate the file. Name := Chap6.Translate_Name (Decl); - if Get_Object_Kind (Name) /= Mode_Value then - raise Internal_Error; - end if; - Is_Text := Get_Text_File_Flag (Get_Type (Decl)); + pragma Assert (Get_Object_Kind (Name) = Mode_Value); + if Is_Text then Start_Association (Constr, Ghdl_Text_File_Elaborate); else @@ -1296,7 +1257,6 @@ package body Trans.Chap4 is New_Assign_Stmt (M2Lv (Name), New_Function_Call (Constr)); -- If file_open_information is present, open the file. - File_Name := Get_File_Logical_Name (Decl); if File_Name = Null_Iir then return; end if; @@ -1304,9 +1264,11 @@ package body Trans.Chap4 is Name := Chap6.Translate_Name (Decl); Open_Kind := Get_File_Open_Kind (Decl); if Open_Kind /= Null_Iir then + -- VHDL 93 and later. Mode_Val := New_Convert_Ov (Chap7.Translate_Expression (Open_Kind), Ghdl_I32_Type); else + -- VHDL 87. case Get_Mode (Decl) is when Iir_In_Mode => Mode_Val := New_Lit (New_Signed_Literal (Ghdl_I32_Type, 0)); @@ -1332,12 +1294,10 @@ package body Trans.Chap4 is procedure Final_File_Declaration (Decl : Iir_File_Declaration) is + Is_Text : constant Boolean := Get_Text_File_Flag (Get_Type (Decl)); Constr : O_Assoc_List; Name : Mnode; - Is_Text : Boolean; begin - Is_Text := Get_Text_File_Flag (Get_Type (Decl)); - Open_Temp; Name := Chap6.Translate_Name (Decl); Stabilize (Name); @@ -1367,8 +1327,7 @@ package body Trans.Chap4 is Close_Temp; end Final_File_Declaration; - procedure Translate_Type_Declaration (Decl : Iir) - is + procedure Translate_Type_Declaration (Decl : Iir) is begin Chap3.Translate_Named_Type_Definition (Get_Type_Definition (Decl), Get_Identifier (Decl)); @@ -1432,7 +1391,7 @@ package body Trans.Chap4 is Atype := Get_Ortho_Type (Decl_Type, Info.Alias_Kind); when Type_Mode_Array | Type_Mode_Acc - | Type_Mode_Fat_Acc => + | Type_Mode_Bounds_Acc => -- Create an object pointer. -- At elaboration: copy base from name. Atype := Tinfo.Ortho_Ptr_Type (Info.Alias_Kind); @@ -1491,7 +1450,7 @@ package body Trans.Chap4 is Decl); Close_Temp; when Type_Mode_Acc - | Type_Mode_Fat_Acc => + | Type_Mode_Bounds_Acc => New_Assign_Stmt (Get_Var (Alias_Info.Alias_Var), M2Addr (Name_Node)); when Type_Mode_Scalar => @@ -1645,12 +1604,12 @@ package body Trans.Chap4 is procedure Translate_Resolution_Function (Func : Iir) is + Finfo : constant Subprg_Info_Acc := Get_Info (Func); + Rinfo : constant Subprg_Resolv_Info_Acc := Finfo.Subprg_Resolv; -- Type of the resolution function parameter. El_Type : Iir; El_Info : Type_Info_Acc; - Finfo : constant Subprg_Info_Acc := Get_Info (Func); Interface_List : O_Inter_List; - Rinfo : constant Subprg_Resolv_Info_Acc := Finfo.Subprg_Resolv; Id : O_Ident; Itype : O_Tnode; Unused_Instance : O_Dnode; @@ -1717,11 +1676,10 @@ package body Trans.Chap4 is procedure Read_Source_Non_Composite (Targ : Mnode; Targ_Type : Iir; Data : Read_Source_Data) is + Targ_Info : constant Type_Info_Acc := Get_Info (Targ_Type); Assoc : O_Assoc_List; - Targ_Info : Type_Info_Acc; E : O_Enode; begin - Targ_Info := Get_Info (Targ_Type); case Data.Kind is when Read_Port => Start_Association (Assoc, Ghdl_Signal_Read_Port); @@ -1760,8 +1718,7 @@ package body Trans.Chap4 is function Read_Source_Update_Data_Array (Data : Read_Source_Data; Targ_Type : Iir; Index : O_Dnode) - return Read_Source_Data - is + return Read_Source_Data is begin return Read_Source_Data' (Sig => Chap3.Index_Base (Data.Sig, Targ_Type, @@ -1774,7 +1731,7 @@ package body Trans.Chap4 is (Data : Read_Source_Data; Targ_Type : Iir; El : Iir_Element_Declaration) - return Read_Source_Data + return Read_Source_Data is pragma Unreferenced (Targ_Type); begin diff --git a/src/vhdl/translate/trans-chap5.adb b/src/vhdl/translate/trans-chap5.adb index a58bd956c..f8cfadbba 100644 --- a/src/vhdl/translate/trans-chap5.adb +++ b/src/vhdl/translate/trans-chap5.adb @@ -17,7 +17,6 @@ -- 02111-1307, USA. with Errorout; use Errorout; -with Sem_Names; with Iirs_Utils; use Iirs_Utils; with Trans.Chap3; with Trans.Chap4; @@ -336,13 +335,12 @@ package body Trans.Chap5 is procedure Elab_Unconstrained_Port (Port : Iir; Actual : Iir) is + Actual_Type : constant Iir := Get_Type (Actual); Act_Node : Mnode; Bounds : Mnode; Tinfo : Type_Info_Acc; Bound_Var : O_Dnode; - Actual_Type : Iir; begin - Actual_Type := Get_Type (Actual); Open_Temp; if Is_Fully_Constrained_Type (Actual_Type) then Chap3.Create_Array_Subtype (Actual_Type, False); @@ -354,13 +352,13 @@ package body Trans.Chap5 is New_Assign_Stmt (New_Obj (Bound_Var), Gen_Alloc (Alloc_System, - New_Lit (New_Sizeof (Tinfo.T.Bounds_Type, - Ghdl_Index_Type)), - Tinfo.T.Bounds_Ptr_Type)); + New_Lit (New_Sizeof (Tinfo.T.Bounds_Type, + Ghdl_Index_Type)), + Tinfo.T.Bounds_Ptr_Type)); Gen_Memcpy (New_Obj_Value (Bound_Var), M2Addr (Bounds), New_Lit (New_Sizeof (Tinfo.T.Bounds_Type, - Ghdl_Index_Type))); + Ghdl_Index_Type))); Bounds := Dp2M (Bound_Var, Tinfo, Mode_Value, Tinfo.T.Bounds_Type, Tinfo.T.Bounds_Ptr_Type); @@ -378,19 +376,6 @@ package body Trans.Chap5 is Close_Temp; end Elab_Unconstrained_Port; - -- Return TRUE if EXPR is a signal name. - function Is_Signal (Expr : Iir) return Boolean - is - Obj : Iir; - begin - Obj := Sem_Names.Name_To_Object (Expr); - if Obj /= Null_Iir then - return Is_Signal_Object (Obj); - else - return False; - end if; - end Is_Signal; - procedure Elab_Port_Map_Aspect_Assoc (Assoc : Iir; By_Copy : Boolean) is Formal : constant Iir := Get_Formal (Assoc); @@ -412,10 +397,8 @@ package body Trans.Chap5 is and then Get_Out_Conversion (Assoc) = Null_Iir then Formal_Node := Chap6.Translate_Name (Formal); - if Get_Object_Kind (Formal_Node) /= Mode_Signal then - raise Internal_Error; - end if; - if Is_Signal (Actual) then + pragma Assert (Get_Object_Kind (Formal_Node) = Mode_Signal); + if Is_Signal_Name (Actual) then -- LRM93 4.3.1.2 -- For a signal of a scalar type, each source is either -- a driver or an OUT, INOUT, BUFFER or LINKAGE port of diff --git a/src/vhdl/translate/trans-chap6.adb b/src/vhdl/translate/trans-chap6.adb index 96e7b394f..368b3d63f 100644 --- a/src/vhdl/translate/trans-chap6.adb +++ b/src/vhdl/translate/trans-chap6.adb @@ -745,20 +745,21 @@ package body Trans.Chap6 is begin case Info.Kind is when Kind_Object => - -- For a generic or a port. + -- For a generic. + pragma Assert (Kind = Mode_Value); return Get_Var (Info.Object_Var, Type_Info, Kind); + when Kind_Signal => + -- For a port. + return Get_Var (Info.Signal_Sig, Type_Info, Kind); when Kind_Interface => -- For a parameter. 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 => + case Type_Mode_Valid (Type_Info.Type_Mode) is + when Type_Mode_Pass_By_Copy => return Dv2M (Info.Interface_Node, Type_Info, Kind); - when Type_Mode_By_Copy - | Type_Mode_By_Ref => + when Type_Mode_Pass_By_Address => -- Parameter is passed by reference. return Dp2M (Info.Interface_Node, Type_Info, Kind); end case; @@ -790,14 +791,10 @@ package body Trans.Chap6 is (Get_Instance_Ref (Subprg_Info.Subprg_Frame_Scope), Info.Interface_Field); end if; - case Type_Info.Type_Mode is - when Type_Mode_Unknown => - raise Internal_Error; - when Type_Mode_By_Value => + case Type_Mode_Valid (Type_Info.Type_Mode) is + when Type_Mode_Pass_By_Copy => return Lv2M (Linter, Type_Info, Kind); - when Type_Mode_By_Copy - | Type_Mode_By_Ref => - -- Parameter is passed by reference. + when Type_Mode_Pass_By_Address => return Lp2M (Linter, Type_Info, Kind); end case; end; @@ -931,7 +928,7 @@ package body Trans.Chap6 is when Type_Mode_Array | Type_Mode_Record | Type_Mode_Acc - | Type_Mode_Fat_Acc => + | Type_Mode_Bounds_Acc => R := Get_Var (Name_Info.Alias_Var); return Lp2M (R, Type_Info, Name_Info.Alias_Kind); when Type_Mode_Scalar => @@ -952,7 +949,7 @@ package body Trans.Chap6 is | Iir_Kind_Delayed_Attribute | Iir_Kind_Transaction_Attribute | Iir_Kind_Guard_Signal_Declaration => - return Get_Var (Name_Info.Object_Var, Type_Info, Mode_Signal); + return Get_Var (Name_Info.Signal_Sig, Type_Info, Mode_Signal); when Iir_Kind_Interface_Constant_Declaration => return Translate_Interface_Name (Name, Name_Info, Mode_Value); @@ -977,12 +974,25 @@ package body Trans.Chap6 is when Iir_Kind_Dereference | Iir_Kind_Implicit_Dereference => declare + Prefix : constant Iir := Get_Prefix (Name); + Prefix_Type : constant Iir := Get_Type (Prefix); + Pt_Info : constant Type_Info_Acc := Get_Info (Prefix_Type); Pfx : O_Enode; + Pfx_Var : O_Dnode; begin - Pfx := Chap7.Translate_Expression (Get_Prefix (Name)); - -- FIXME: what about fat pointer ?? - return Lv2M (New_Access_Element (Pfx), - Type_Info, Mode_Value); + Pfx := Chap7.Translate_Expression (Prefix); + if Pt_Info.Type_Mode = Type_Mode_Bounds_Acc then + Pfx_Var := Create_Temp_Init + (Pt_Info.Ortho_Type (Mode_Value), Pfx); + return Chap7.Bounds_Acc_To_Fat_Pointer + (Pfx_Var, Prefix_Type); + else + return Lv2M + (New_Access_Element + (New_Convert_Ov + (Pfx, Type_Info.Ortho_Ptr_Type (Mode_Value))), + Type_Info, Mode_Value); + end if; end; when Iir_Kind_Selected_Element => @@ -1040,8 +1050,8 @@ package body Trans.Chap6 is Translate_Direct_Driver (Get_Name (Name), Sig, Drv); when Iir_Kind_Signal_Declaration | Iir_Kind_Interface_Signal_Declaration => - Sig := Get_Var (Name_Info.Object_Var, Type_Info, Mode_Signal); - Drv := Get_Var (Name_Info.Object_Driver, Type_Info, Mode_Value); + Sig := Get_Var (Name_Info.Signal_Sig, Type_Info, Mode_Signal); + Drv := Get_Var (Name_Info.Signal_Driver, Type_Info, Mode_Value); when Iir_Kind_Slice_Name => declare Data : Slice_Name_Data; diff --git a/src/vhdl/translate/trans-chap7.adb b/src/vhdl/translate/trans-chap7.adb index a3ae2896e..0b2479de1 100644 --- a/src/vhdl/translate/trans-chap7.adb +++ b/src/vhdl/translate/trans-chap7.adb @@ -2598,10 +2598,9 @@ package body Trans.Chap7 is (M2Lv (Target), Chap3.Maybe_Insert_Scalar_Check (Val, Expr, Target_Type)); when Type_Mode_Acc - | Type_Mode_File => + | Type_Mode_Bounds_Acc + | Type_Mode_File => New_Assign_Stmt (M2Lv (Target), Val); - when Type_Mode_Fat_Acc => - Chap3.Translate_Object_Copy (Target, Val, Target_Type); when Type_Mode_Fat_Array => declare T : Mnode; @@ -3263,74 +3262,161 @@ package body Trans.Chap7 is function Translate_Allocator_By_Expression (Expr : Iir) return O_Enode is - Val : O_Enode; - Val_M : Mnode; A_Type : constant Iir := Get_Type (Expr); A_Info : constant Type_Info_Acc := Get_Info (A_Type); D_Type : constant Iir := Get_Designated_Type (A_Type); D_Info : constant Type_Info_Acc := Get_Info (D_Type); + Val : O_Enode; R : Mnode; - Rtype : O_Tnode; begin -- Compute the expression. Val := Translate_Expression (Get_Expression (Expr), D_Type); + -- Allocate memory for the object. case A_Info.Type_Mode is - when Type_Mode_Fat_Acc => - R := Dv2M (Create_Temp (D_Info.Ortho_Type (Mode_Value)), - D_Info, Mode_Value); - Val_M := Stabilize (E2M (Val, D_Info, Mode_Value)); - Chap3.Translate_Object_Allocation - (R, Alloc_Heap, D_Type, - Chap3.Get_Array_Bounds (Val_M)); - Val := M2E (Val_M); - Rtype := A_Info.Ortho_Ptr_Type (Mode_Value); + when Type_Mode_Bounds_Acc => + declare + Res : O_Dnode; + Val_Size : O_Dnode; + Bounds_Size : O_Cnode; + Val_M : Mnode; + begin + Res := Create_Temp (A_Info.Ortho_Type (Mode_Value)); + Val_M := Stabilize (E2M (Val, D_Info, Mode_Value)); + + -- Size of the value (object without the bounds). + Val_Size := Create_Temp_Init + (Ghdl_Index_Type, + Chap3.Get_Subtype_Size + (D_Type, Chap3.Get_Array_Bounds (Val_M), Mode_Value)); + + -- Size of the bounds. + Bounds_Size := + New_Sizeof (D_Info.T.Bounds_Type, Ghdl_Index_Type); + + -- Allocate the object. + New_Assign_Stmt + (New_Obj (Res), + Gen_Alloc (Alloc_Heap, + New_Dyadic_Op + (ON_Add_Ov, + New_Lit (Bounds_Size), + New_Obj_Value (Val_Size)), + A_Info.Ortho_Type (Mode_Value))); + + -- Copy bounds. + Gen_Memcpy + (New_Obj_Value (Res), M2Addr (Chap3.Get_Array_Bounds (Val_M)), + New_Lit (Bounds_Size)); + + -- Copy values. + Gen_Memcpy + (Chap3.Get_Bounds_Acc_Base (New_Obj_Value (Res), D_Type), + M2Addr (Chap3.Get_Array_Base (Val_M)), + New_Obj_Value (Val_Size)); + + return New_Obj_Value (Res); + end; when Type_Mode_Acc => R := Dp2M (Create_Temp (D_Info.Ortho_Ptr_Type (Mode_Value)), D_Info, Mode_Value); Chap3.Translate_Object_Allocation (R, Alloc_Heap, D_Type, Mnode_Null); - Rtype := A_Info.Ortho_Type (Mode_Value); + Chap3.Translate_Object_Copy (R, Val, D_Type); + return New_Convert_Ov (M2Addr (R), A_Info.Ortho_Type (Mode_Value)); when others => raise Internal_Error; end case; - Chap3.Translate_Object_Copy (R, Val, D_Type); - return New_Convert_Ov (M2Addr (R), Rtype); end Translate_Allocator_By_Expression; + function Bounds_Acc_To_Fat_Pointer (Ptr : O_Dnode; Acc_Type : Iir) + return Mnode + is + D_Type : constant Iir := Get_Designated_Type (Acc_Type); + D_Info : constant Type_Info_Acc := Get_Info (D_Type); + Res : Mnode; + begin + Res := Dv2M (Create_Temp (D_Info.Ortho_Type (Mode_Value)), + D_Info, Mode_Value); + + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Bounds (Res)), + New_Convert_Ov (New_Obj_Value (Ptr), D_Info.T.Bounds_Ptr_Type)); + New_Assign_Stmt + (M2Lp (Chap3.Get_Array_Base (Res)), + Chap3.Get_Bounds_Acc_Base (New_Obj_Value (Ptr), D_Type)); + return Res; + end Bounds_Acc_To_Fat_Pointer; + function Translate_Allocator_By_Subtype (Expr : Iir) return O_Enode is - P_Type : constant Iir := Get_Type (Expr); - P_Info : constant Type_Info_Acc := Get_Info (P_Type); - D_Type : constant Iir := Get_Designated_Type (P_Type); + A_Type : constant Iir := Get_Type (Expr); + A_Info : constant Type_Info_Acc := Get_Info (A_Type); + D_Type : constant Iir := Get_Designated_Type (A_Type); D_Info : constant Type_Info_Acc := Get_Info (D_Type); - Sub_Type : Iir; Bounds : Mnode; Res : Mnode; - Rtype : O_Tnode; begin - case P_Info.Type_Mode is - when Type_Mode_Fat_Acc => - Res := Dv2M (Create_Temp (D_Info.Ortho_Type (Mode_Value)), - D_Info, Mode_Value); - -- FIXME: should allocate bounds, and directly set bounds - -- from the range. - Sub_Type := Get_Subtype_Indication (Expr); - Sub_Type := Get_Type_Of_Subtype_Indication (Sub_Type); - Chap3.Create_Array_Subtype (Sub_Type, True); - Bounds := Chap3.Get_Array_Type_Bounds (Sub_Type); - Rtype := P_Info.Ortho_Ptr_Type (Mode_Value); + case A_Info.Type_Mode is + when Type_Mode_Bounds_Acc => + declare + Sub_Type : Iir; + Ptr : O_Dnode; + Val_Size : O_Dnode; + Bounds_Size : O_Cnode; + begin + Sub_Type := Get_Subtype_Indication (Expr); + Sub_Type := Get_Type_Of_Subtype_Indication (Sub_Type); + Chap3.Create_Array_Subtype (Sub_Type, True); + + Ptr := Create_Temp (A_Info.Ortho_Type (Mode_Value)); + + -- Size of the value (object without the bounds). + Val_Size := Create_Temp_Init + (Ghdl_Index_Type, + Chap3.Get_Subtype_Size + (D_Type, Chap3.Get_Array_Type_Bounds (Sub_Type), + Mode_Value)); + + -- Size of the bounds. + Bounds_Size := + New_Sizeof (D_Info.T.Bounds_Type, Ghdl_Index_Type); + + -- Allocate the object. + New_Assign_Stmt + (New_Obj (Ptr), + Gen_Alloc (Alloc_Heap, + New_Dyadic_Op + (ON_Add_Ov, + New_Lit (Bounds_Size), + New_Obj_Value (Val_Size)), + A_Info.Ortho_Type (Mode_Value))); + + -- Copy bounds. + Gen_Memcpy + (New_Obj_Value (Ptr), + M2Addr (Chap3.Get_Array_Type_Bounds (Sub_Type)), + New_Lit (Bounds_Size)); + + -- Create a fat pointer to initialize the object. + Res := Bounds_Acc_To_Fat_Pointer (Ptr, A_Type); + Chap3.Maybe_Call_Type_Builder (Res, D_Type); + Chap4.Init_Object (Res, D_Type); + + return New_Obj_Value (Ptr); + end; when Type_Mode_Acc => Res := Dp2M (Create_Temp (D_Info.Ortho_Ptr_Type (Mode_Value)), D_Info, Mode_Value); Bounds := Mnode_Null; - Rtype := P_Info.Ortho_Type (Mode_Value); + Chap3.Translate_Object_Allocation + (Res, Alloc_Heap, D_Type, Bounds); + Chap4.Init_Object (Res, D_Type); + return New_Convert_Ov + (M2Addr (Res), A_Info.Ortho_Type (Mode_Value)); when others => raise Internal_Error; end case; - Chap3.Translate_Object_Allocation (Res, Alloc_Heap, D_Type, Bounds); - Chap4.Init_Object (Res, D_Type); - return New_Convert_Ov (M2Addr (Res), Rtype); end Translate_Allocator_By_Subtype; function Translate_Fat_Array_Type_Conversion @@ -3770,28 +3856,8 @@ package body Trans.Chap7 is declare Tinfo : constant Type_Info_Acc := Get_Info (Expr_Type); Otype : constant O_Tnode := Tinfo.Ortho_Type (Mode_Value); - L : O_Dnode; - B : Type_Info_Acc; begin - if Tinfo.Type_Mode = Type_Mode_Fat_Acc then - -- Create a fat null pointer. - -- FIXME: should be optimized!! - L := Create_Temp (Otype); - B := Get_Info (Get_Designated_Type (Expr_Type)); - New_Assign_Stmt - (New_Selected_Element (New_Obj (L), - B.T.Base_Field (Mode_Value)), - New_Lit - (New_Null_Access (B.T.Base_Ptr_Type (Mode_Value)))); - New_Assign_Stmt - (New_Selected_Element - (New_Obj (L), B.T.Bounds_Field (Mode_Value)), - New_Lit (New_Null_Access (B.T.Bounds_Ptr_Type))); - return New_Address (New_Obj (L), - Tinfo.Ortho_Ptr_Type (Mode_Value)); - else - return New_Lit (New_Null_Access (Otype)); - end if; + return New_Lit (New_Null_Access (Otype)); end; when Iir_Kind_Overflow_Literal => @@ -4446,35 +4512,10 @@ package body Trans.Chap7 is Tinfo := Get_Type_Info (L); case Tinfo.Type_Mode is when Type_Mode_Scalar - | Type_Mode_Acc => + | Type_Mode_Bounds_Acc + | Type_Mode_Acc => return New_Compare_Op (ON_Eq, M2E (L), M2E (R), Ghdl_Bool_Type); - when Type_Mode_Fat_Acc => - -- a fat pointer. - declare - B : Type_Info_Acc; - Ln, Rn : Mnode; - V1, V2 : O_Enode; - begin - B := Get_Info (Get_Designated_Type (Etype)); - Ln := Stabilize (L); - Rn := Stabilize (R); - V1 := New_Compare_Op - (ON_Eq, - New_Value (New_Selected_Element - (M2Lv (Ln), B.T.Base_Field (Mode_Value))), - New_Value (New_Selected_Element - (M2Lv (Rn), B.T.Base_Field (Mode_Value))), - Std_Boolean_Type_Node); - V2 := New_Compare_Op - (ON_Eq, - New_Value (New_Selected_Element - (M2Lv (Ln), B.T.Bounds_Field (Mode_Value))), - New_Value (New_Selected_Element - (M2Lv (Rn), B.T.Bounds_Field (Mode_Value))), - Std_Boolean_Type_Node); - return New_Dyadic_Op (ON_And, V1, V2); - end; when Type_Mode_Array => declare @@ -5280,7 +5321,7 @@ package body Trans.Chap7 is when Type_Mode_Unknown | Type_Mode_File | Type_Mode_Acc - | Type_Mode_Fat_Acc + | Type_Mode_Bounds_Acc | Type_Mode_Fat_Array | Type_Mode_Protected => raise Internal_Error; diff --git a/src/vhdl/translate/trans-chap7.ads b/src/vhdl/translate/trans-chap7.ads index 8aa904259..2434c3b54 100644 --- a/src/vhdl/translate/trans-chap7.ads +++ b/src/vhdl/translate/trans-chap7.ads @@ -114,6 +114,10 @@ package Trans.Chap7 is procedure Translate_Aggregate (Target : Mnode; Target_Type : Iir; Aggr : Iir); + -- Convert bounds access PTR to a fat pointer. + function Bounds_Acc_To_Fat_Pointer (Ptr : O_Dnode; Acc_Type : Iir) + return Mnode; + -- Translate implicit functions defined by a type. type Implicit_Subprogram_Infos is private; procedure Init_Implicit_Subprogram_Infos diff --git a/src/vhdl/translate/trans-chap8.adb b/src/vhdl/translate/trans-chap8.adb index 8a3711ee2..ca05eb67a 100644 --- a/src/vhdl/translate/trans-chap8.adb +++ b/src/vhdl/translate/trans-chap8.adb @@ -97,8 +97,9 @@ package body Trans.Chap8 is Gen_Return_Value (R); end if; end; - when Type_Mode_Acc => - -- * access: thin and no range. + when Type_Mode_Acc + | Type_Mode_Bounds_Acc => + -- * access: no range. declare Res : O_Enode; begin @@ -126,8 +127,7 @@ package body Trans.Chap8 is Gen_Return; end; when Type_Mode_Record - | Type_Mode_Array - | Type_Mode_Fat_Acc => + | Type_Mode_Array => -- * if the return type is a constrained composite type, copy -- it to the result area. -- Create a temporary area so that if the expression use @@ -1351,7 +1351,7 @@ package body Trans.Chap8 is when Type_Mode_Unknown | Type_Mode_File | Type_Mode_Acc - | Type_Mode_Fat_Acc + | Type_Mode_Bounds_Acc | Type_Mode_Protected => raise Internal_Error; end case; @@ -1424,7 +1424,7 @@ package body Trans.Chap8 is when Type_Mode_Unknown | Type_Mode_File | Type_Mode_Acc - | Type_Mode_Fat_Acc + | Type_Mode_Bounds_Acc | Type_Mode_Protected => raise Internal_Error; end case; @@ -1704,6 +1704,7 @@ package body Trans.Chap8 is Is_Procedure : constant Boolean := Get_Kind (Imp) = Iir_Kind_Procedure_Declaration; Is_Function : constant Boolean := not Is_Procedure; + Is_Foreign : constant Boolean := Get_Foreign_Flag (Imp); Info : constant Subprg_Info_Acc := Get_Info (Imp); type Mnode_Array is array (Natural range <>) of Mnode; @@ -1718,6 +1719,10 @@ package body Trans.Chap8 is -- The values of actuals. E_Params : O_Enode_Array (0 .. Nbr_Assoc - 1); + -- Only for inout/out variables passed by copy of foreign procedures: + -- the copy of the scalar. + Inout_Params : Mnode_Array (0 .. Nbr_Assoc - 1); + Params_Var : O_Dnode; Res : Mnode; El : Iir; @@ -1777,6 +1782,7 @@ package body Trans.Chap8 is while El /= Null_Iir loop Params (Pos) := Mnode_Null; E_Params (Pos) := O_Enode_Null; + Inout_Params (Pos) := Mnode_Null; Formal := Strip_Denoting_Name (Get_Formal (El)); Base_Formal := Get_Association_Interface (El); @@ -1853,7 +1859,7 @@ package body Trans.Chap8 is else Param := Chap6.Translate_Name (Act); if Base_Formal /= Formal - or else Ftype_Info.Type_Mode in Type_Mode_By_Value + or else Ftype_Info.Type_Mode in Type_Mode_Pass_By_Copy then -- For out/inout, we need to keep the reference for the -- copy-out. @@ -1872,6 +1878,16 @@ package body Trans.Chap8 is else Val := M2E (Param); end if; + + if Is_Foreign + and then Ftype_Info.Type_Mode in Type_Mode_Pass_By_Copy + then + -- Scalar parameters of foreign procedures (of mode out + -- or inout) are passed by address, create a copy of the + -- value. + Inout_Params (Pos) := + Create_Temp (Ftype_Info, Mode_Value); + end if; end if; if In_Conv /= Null_Iir then Val := Do_Conversion (In_Conv, Act, Val); @@ -1906,6 +1922,8 @@ package body Trans.Chap8 is Ptr := New_Selected_Element (New_Obj (Params_Var), Formal_Info.Interface_Field); New_Assign_Stmt (Ptr, Val); + elsif Inout_Params (Pos) /= Mnode_Null then + Chap3.Translate_Object_Copy (Inout_Params (Pos), Val, Formal_Type); else E_Params (Pos) := Val; end if; @@ -1952,7 +1970,12 @@ package body Trans.Chap8 is New_Association (Constr, M2E (Params (Pos))); elsif Base_Formal = Formal then -- Whole association. - New_Association (Constr, E_Params (Pos)); + if Inout_Params (Pos) /= Mnode_Null then + Val := M2Addr (Inout_Params (Pos)); + else + Val := E_Params (Pos); + end if; + New_Association (Constr, Val); end if; end if; El := Get_Chain (El); @@ -1995,6 +2018,8 @@ package body Trans.Chap8 is -- By individual, copy back. Param := Translate_Individual_Association_Formal (Formal, Formal_Info, Params (Last_Individual)); + elsif Inout_Params (Pos) /= Mnode_Null then + Param := Inout_Params (Pos); else pragma Assert (Formal_Info.Interface_Field /= O_Fnode_Null); Ptr := New_Selected_Element diff --git a/src/vhdl/translate/trans-chap9.adb b/src/vhdl/translate/trans-chap9.adb index 86faf6a3d..9a7bf98f9 100644 --- a/src/vhdl/translate/trans-chap9.adb +++ b/src/vhdl/translate/trans-chap9.adb @@ -58,8 +58,8 @@ package body Trans.Chap9 is Sig := Get_Object_Prefix (Drivers (I).Sig); Info := Get_Info (Sig); case Info.Kind is - when Kind_Object => - Info.Object_Driver := Var; + when Kind_Signal => + Info.Signal_Driver := Var; when Kind_Alias => null; when others => @@ -83,8 +83,8 @@ package body Trans.Chap9 is Sig := Get_Object_Prefix (Drivers (I).Sig); Info := Get_Info (Sig); case Info.Kind is - when Kind_Object => - Info.Object_Driver := Null_Var; + when Kind_Signal => + Info.Signal_Driver := Null_Var; when Kind_Alias => null; when others => @@ -122,21 +122,19 @@ package body Trans.Chap9 is procedure Translate_Implicit_Guard_Signal (Guard : Iir; Base : Block_Info_Acc) is - Info : Object_Info_Acc; + Guard_Expr : constant Iir := Get_Guard_Expression (Guard); + Info : constant Signal_Info_Acc := Get_Info (Guard); Inter_List : O_Inter_List; Instance : O_Dnode; - Guard_Expr : Iir; begin - Guard_Expr := Get_Guard_Expression (Guard); -- Create the subprogram to compute the value of GUARD. - Info := Get_Info (Guard); Start_Function_Decl (Inter_List, Create_Identifier ("_GUARD_PROC"), O_Storage_Private, Std_Boolean_Type_Node); New_Interface_Decl (Inter_List, Instance, Wki_Instance, Base.Block_Decls_Ptr_Type); - Finish_Subprogram_Decl (Inter_List, Info.Object_Function); + Finish_Subprogram_Decl (Inter_List, Info.Signal_Function); - Start_Subprogram_Body (Info.Object_Function); + Start_Subprogram_Body (Info.Signal_Function); Push_Local_Factory; Set_Scope_Via_Param_Ptr (Base.Block_Scope, Instance); Open_Temp; @@ -1325,27 +1323,24 @@ package body Trans.Chap9 is procedure Elab_Implicit_Guard_Signal (Block : Iir_Block_Statement; Block_Info : Block_Info_Acc) is - Guard : Iir; - Type_Info : Type_Info_Acc; - Info : Object_Info_Acc; + Guard : constant Iir := Get_Guard_Decl (Block); + Info : constant Signal_Info_Acc := Get_Info (Guard); + Type_Info : constant Type_Info_Acc := Get_Info (Get_Type (Guard)); Constr : O_Assoc_List; begin -- Create the guard signal. - Guard := Get_Guard_Decl (Block); - Info := Get_Info (Guard); - Type_Info := Get_Info (Get_Type (Guard)); Start_Association (Constr, Ghdl_Signal_Create_Guard); New_Association (Constr, New_Unchecked_Address (Get_Instance_Ref (Block_Info.Block_Scope), Ghdl_Ptr_Type)); New_Association (Constr, - New_Lit (New_Subprogram_Address (Info.Object_Function, - Ghdl_Ptr_Type))); + New_Lit (New_Subprogram_Address (Info.Signal_Function, + Ghdl_Ptr_Type))); -- New_Association (Constr, Chap6.Get_Instance_Name_Ref (Block)); - New_Assign_Stmt (Get_Var (Info.Object_Var), + New_Assign_Stmt (Get_Var (Info.Signal_Sig), New_Convert_Ov (New_Function_Call (Constr), - Type_Info.Ortho_Type (Mode_Signal))); + Type_Info.Ortho_Type (Mode_Signal))); -- Register sensitivity list of the guard signal. Register_Signal_List (Get_Guard_Sensitivity_List (Guard), @@ -1840,16 +1835,15 @@ package body Trans.Chap9 is New_Association (Assoc, New_Lit (New_Global_Unchecked_Address - (Get_Info (Data.Sig).Object_Rti, - Rtis.Ghdl_Rti_Access))); + (Get_Info (Data.Sig).Signal_Rti, + Rtis.Ghdl_Rti_Access))); New_Procedure_Call (Assoc); Close_Temp; end Merge_Signals_Rti_Non_Composite; - function Merge_Signals_Rti_Prepare (Targ : Mnode; - Targ_Type : Iir; - Data : Merge_Signals_Data) - return Merge_Signals_Data + function Merge_Signals_Rti_Prepare + (Targ : Mnode; Targ_Type : Iir; Data : Merge_Signals_Data) + return Merge_Signals_Data is pragma Unreferenced (Targ); pragma Unreferenced (Targ_Type); @@ -1934,26 +1928,27 @@ package body Trans.Chap9 is while Port /= Null_Iir loop Port_Type := Get_Type (Port); Data.Sig := Port; + Open_Temp; + case Get_Mode (Port) is when Iir_Buffer_Mode | Iir_Out_Mode | Iir_Inout_Mode => Data.Set_Init := True; + Val := Get_Default_Value (Port); + if Val = Null_Iir then + Data.Has_Val := False; + else + Data.Has_Val := True; + Data.Val := E2M (Chap7.Translate_Expression (Val, Port_Type), + Get_Info (Port_Type), + Mode_Value); + end if; when others => Data.Set_Init := False; + Data.Has_Val := False; end case; - Open_Temp; - Val := Get_Default_Value (Port); - if Val = Null_Iir then - Data.Has_Val := False; - else - Data.Has_Val := True; - Data.Val := E2M (Chap7.Translate_Expression (Val, Port_Type), - Get_Info (Port_Type), - Mode_Value); - end if; - Merge_Signals_Rti (Chap6.Translate_Name (Port), Port_Type, Data); Close_Temp; diff --git a/src/vhdl/translate/trans-rtis.adb b/src/vhdl/translate/trans-rtis.adb index a55447a47..cae059bb8 100644 --- a/src/vhdl/translate/trans-rtis.adb +++ b/src/vhdl/translate/trans-rtis.adb @@ -1813,10 +1813,9 @@ package body Trans.Rtis is procedure Generate_Signal_Rti (Sig : Iir) is - Info : Object_Info_Acc; + Info : constant Signal_Info_Acc := Get_Info (Sig); begin - Info := Get_Info (Sig); - New_Const_Decl (Info.Object_Rti, Create_Identifier (Sig, "__RTI"), + New_Const_Decl (Info.Signal_Rti, Create_Identifier (Sig, "__RTI"), Global_Storage, Ghdl_Rtin_Object); end Generate_Signal_Rti; @@ -1895,10 +1894,10 @@ package body Trans.Rtis is case Get_Kind (Decl) is when Iir_Kind_Signal_Declaration => Comm := Ghdl_Rtik_Signal; - Var := Info.Object_Var; + Var := Info.Signal_Sig; when Iir_Kind_Interface_Signal_Declaration => Comm := Ghdl_Rtik_Port; - Var := Info.Object_Var; + Var := Info.Signal_Sig; Mode := Iir_Mode'Pos (Get_Mode (Decl)); when Iir_Kind_Constant_Declaration => Comm := Ghdl_Rtik_Constant; @@ -1911,7 +1910,7 @@ package body Trans.Rtis is Var := Info.Object_Var; when Iir_Kind_Guard_Signal_Declaration => Comm := Ghdl_Rtik_Guard; - Var := Info.Object_Var; + Var := Info.Signal_Sig; when Iir_Kind_Iterator_Declaration => Comm := Ghdl_Rtik_Iterator; Var := Info.Iterator_Var; @@ -1923,13 +1922,13 @@ package body Trans.Rtis is Var := Null_Var; when Iir_Kind_Transaction_Attribute => Comm := Ghdl_Rtik_Attribute_Transaction; - Var := Info.Object_Var; + Var := Info.Signal_Sig; when Iir_Kind_Quiet_Attribute => Comm := Ghdl_Rtik_Attribute_Quiet; - Var := Info.Object_Var; + Var := Info.Signal_Sig; when Iir_Kind_Stable_Attribute => Comm := Ghdl_Rtik_Attribute_Stable; - Var := Info.Object_Var; + Var := Info.Signal_Sig; when Iir_Kind_Object_Alias_Declaration => Comm := Ghdl_Rtik_Alias; Var := Info.Alias_Var; @@ -2207,20 +2206,25 @@ package body Trans.Rtis is Add_Rti_Node (Info.Object_Rti); end; end if; + when Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_File_Declaration => + declare + Info : constant Object_Info_Acc := Get_Info (Decl); + begin + Generate_Object (Decl, Info.Object_Rti); + Add_Rti_Node (Info.Object_Rti); + end; when Iir_Kind_Signal_Declaration | Iir_Kind_Interface_Signal_Declaration - | Iir_Kind_Interface_Constant_Declaration - | Iir_Kind_Variable_Declaration - | Iir_Kind_File_Declaration | Iir_Kind_Transaction_Attribute | Iir_Kind_Quiet_Attribute | Iir_Kind_Stable_Attribute => declare - Info : Object_Info_Acc; + Info : constant Signal_Info_Acc := Get_Info (Decl); begin - Info := Get_Info (Decl); - Generate_Object (Decl, Info.Object_Rti); - Add_Rti_Node (Info.Object_Rti); + Generate_Object (Decl, Info.Signal_Rti); + Add_Rti_Node (Info.Signal_Rti); end; when Iir_Kind_Delayed_Attribute => -- FIXME: to be added. @@ -2530,12 +2534,12 @@ package body Trans.Rtis is declare Guard : constant Iir := Get_Guard_Decl (Blk); Header : constant Iir := Get_Block_Header (Blk); - Guard_Info : Object_Info_Acc; + Guard_Info : Signal_Info_Acc; begin if Guard /= Null_Iir then Guard_Info := Get_Info (Guard); - Generate_Object (Guard, Guard_Info.Object_Rti); - Add_Rti_Node (Guard_Info.Object_Rti); + Generate_Object (Guard, Guard_Info.Signal_Rti); + Add_Rti_Node (Guard_Info.Signal_Rti); end if; if Header /= Null_Iir then Generate_Declaration_Chain (Get_Generic_Chain (Header)); diff --git a/src/vhdl/translate/trans.adb b/src/vhdl/translate/trans.adb index 91ebb9e3b..de5abc351 100644 --- a/src/vhdl/translate/trans.adb +++ b/src/vhdl/translate/trans.adb @@ -1054,7 +1054,7 @@ package body Trans is | Type_Mode_Acc | Type_Mode_File | Type_Mode_Fat_Array - | Type_Mode_Fat_Acc => + | Type_Mode_Bounds_Acc => if Stable then return Dv2M (D, Vtype, Mode); else @@ -1204,6 +1204,17 @@ package body Trans is return New_Access_Element (New_Value (L)); end New_Acc_Value; + function Add_Pointer + (Ptr : O_Enode; Offset : O_Enode; Res_Ptr : O_Tnode) return O_Enode is + begin + return New_Unchecked_Address + (New_Slice + (New_Access_Element (New_Convert_Ov (Ptr, Char_Ptr_Type)), + Chararray_Type, + Offset), + Res_Ptr); + end Add_Pointer; + package Node_Infos is new GNAT.Table (Table_Component_Type => Ortho_Info_Acc, Table_Index_Type => Iir, @@ -1668,7 +1679,7 @@ package body Trans is | Type_Mode_Acc | Type_Mode_File | Type_Mode_Fat_Array - | Type_Mode_Fat_Acc => + | Type_Mode_Bounds_Acc => return Lv2M (L, Vtype, Mode); when Type_Mode_Array | Type_Mode_Record @@ -1691,7 +1702,7 @@ package body Trans is | Type_Mode_Acc | Type_Mode_File | Type_Mode_Fat_Array - | Type_Mode_Fat_Acc => + | Type_Mode_Bounds_Acc => return Dv2M (D, Vtype, Mode); when Type_Mode_Array | Type_Mode_Record @@ -1741,11 +1752,24 @@ package body Trans is type Temp_Level_Type; type Temp_Level_Acc is access Temp_Level_Type; type Temp_Level_Type is record + -- Link to the outer record. Prev : Temp_Level_Acc; + + -- Nested level. 'Top' level is 0. Level : Natural; + + -- Generated variable id, starts from 0. Id : Natural; + + -- True if a scope was created, as it is created dynamically at the + -- first use. Emitted : Boolean; + + -- Declaration of the variable for the stack2 mark. The stack2 will + -- be released at the end of the scope (if used). Stack2_Mark : O_Dnode; + + -- List of transient types to be removed at the end of the scope. Transient_Types : Iir; end record; -- Current level. diff --git a/src/vhdl/translate/trans.ads b/src/vhdl/translate/trans.ads index 8cf76b7de..b135929d8 100644 --- a/src/vhdl/translate/trans.ads +++ b/src/vhdl/translate/trans.ads @@ -157,6 +157,8 @@ package Trans is Wki_Val : O_Ident; Wki_L_Len : O_Ident; Wki_R_Len : O_Ident; + Wki_Base : O_Ident; + Wki_Bounds : O_Ident; -- ALLOCATION_KIND defines the type of memory storage. -- ALLOC_STACK means the object is allocated on the local stack and @@ -183,6 +185,12 @@ package Trans is -- Equivalent to new_access_element (new_value (l)) function New_Acc_Value (L : O_Lnode) return O_Lnode; + -- Return PTR + OFFSET as a RES_PTR value. The offset is the number of + -- bytes. RES_PTR must be an access type and the type of PTR must be an + -- access. + function Add_Pointer + (Ptr : O_Enode; Offset : O_Enode; Res_Ptr : O_Tnode) return O_Enode; + package Chap10 is -- There are three data storage kind: global, local or instance. -- For example, a constant can have: @@ -635,6 +643,7 @@ package Trans is Kind_Expr, Kind_Subprg, Kind_Object, + Kind_Signal, Kind_Alias, Kind_Iterator, Kind_Interface, @@ -790,6 +799,7 @@ package Trans is ( -- Unknown mode. Type_Mode_Unknown, + -- Boolean type, with 2 elements. Type_Mode_B1, -- Enumeration with at most 256 elements. @@ -809,8 +819,8 @@ package Trans is -- Thin access. Type_Mode_Acc, - -- Fat access. - Type_Mode_Fat_Acc, + -- Access to an unbounded type. + Type_Mode_Bounds_Acc, -- Record. Type_Mode_Record, @@ -821,43 +831,72 @@ package Trans is -- Fat array type (used for unconstrained array). Type_Mode_Fat_Array); - subtype Type_Mode_Scalar is Type_Mode_Type - range Type_Mode_B1 .. Type_Mode_F64; + subtype Type_Mode_Valid is Type_Mode_Type range + Type_Mode_B1 .. Type_Mode_Type'Last; - subtype Type_Mode_Non_Composite is Type_Mode_Type - range Type_Mode_B1 .. Type_Mode_Fat_Acc; + subtype Type_Mode_Scalar is Type_Mode_Type range + Type_Mode_B1 .. Type_Mode_F64; -- Composite types, with the vhdl meaning: record and arrays. - subtype Type_Mode_Composite is Type_Mode_Type - range Type_Mode_Record .. Type_Mode_Fat_Array; + subtype Type_Mode_Composite is Type_Mode_Type range + Type_Mode_Record .. Type_Mode_Fat_Array; + + subtype Type_Mode_Non_Composite is Type_Mode_Type range + Type_Mode_B1 .. Type_Mode_Bounds_Acc; -- Array types. subtype Type_Mode_Arrays is Type_Mode_Type range Type_Mode_Array .. Type_Mode_Fat_Array; -- Thin types, ie types whose length is a scalar. - subtype Type_Mode_Thin is Type_Mode_Type - range Type_Mode_B1 .. Type_Mode_Acc; + subtype Type_Mode_Thin is Type_Mode_Type range + Type_Mode_B1 .. Type_Mode_Bounds_Acc; -- Fat types, ie types whose length is longer than a scalar. - subtype Type_Mode_Fat is Type_Mode_Type - range Type_Mode_Fat_Acc .. Type_Mode_Fat_Array; + subtype Type_Mode_Fat is Type_Mode_Type range + Type_Mode_Record .. Type_Mode_Fat_Array; - -- These parameters are passed by value, ie the argument of the subprogram - -- is the value of the object. - subtype Type_Mode_By_Value is Type_Mode_Type - range Type_Mode_B1 .. Type_Mode_Acc; + -- Subprogram call argument mechanism. + -- In VHDL, the evaluation is strict: actual parameters are evaluated + -- before the call. This is the usual strategy of most compiled languages + -- (the main exception being Algol-68 call by name). + -- + -- Call semantic is described in + -- LRM08 4.2.2.2 Constant and variable parameters. + -- + -- At the semantic (and LRM level), there are two call convention: either + -- call by value or call by reference. That vocabulary should be used in + -- trans for the semantic level: call convention and call-by. According to + -- the LRM, all scalars use the call by value convention. It is possible + -- to change the actual after the call for inout parameters, using + -- pass-by value mechanism and copy-in/copy-out. + -- + -- At the low-level (generated code), there are two mechanisms: either + -- pass by copy or pass by address. Again, that vocabulary should be used + -- in trans for the low-level: mechanism and pass-by. + -- + -- A call by reference is always passed by address; while a call by value + -- can use a pass-by address to a copy of the value. The later being + -- used for fat accesses. With Ortho, only scalars and pointers can be + -- passed by copy. - -- These parameters are passed by copy, ie a copy of the object is created - -- and the reference of the copy is passed. If the object is not - -- modified by the subprogram, the object could be passed by reference. - subtype Type_Mode_By_Copy is Type_Mode_Type - range Type_Mode_Fat_Acc .. Type_Mode_Fat_Acc; + -- In GHDL, all non-composite types use the call-by value convention, and + -- composite types use the call-by reference convention. For fat accesses, + -- a copy of the value is passed by address. - -- The parameters are passed by reference, ie the argument of the + -- These parameters are passed by copy, ie the argument of the subprogram + -- is the value of the object. + subtype Type_Mode_Pass_By_Copy is Type_Mode_Type range + Type_Mode_B1 .. Type_Mode_Bounds_Acc; + + -- The parameters are passed by address, ie the argument of the -- subprogram is an address to the object. - subtype Type_Mode_By_Ref is Type_Mode_Type - range Type_Mode_Record .. Type_Mode_Fat_Array; + subtype Type_Mode_Pass_By_Address is Type_Mode_Type range + Type_Mode_Record .. Type_Mode_Fat_Array; + + -- Call conventions. + subtype Type_Mode_Call_By_Value is Type_Mode_Non_Composite; + subtype Type_Mode_Call_By_Reference is Type_Mode_Composite; -- Additional informations for a resolving function. type Subprg_Resolv_Info is record @@ -1076,7 +1115,6 @@ package Trans is when Kind_Incomplete_Type => -- The declaration of the incomplete type. Incomplete_Type : Iir; - Incomplete_Array : Ortho_Info_Acc; when Kind_Index => -- Field declaration for array dimension. @@ -1139,13 +1177,21 @@ package Trans is Object_Static : Boolean; -- The object itself. Object_Var : Var_Type; - -- Direct driver for signal (if any). - Object_Driver : Var_Type := Null_Var; -- RTI constant for the object. Object_Rti : O_Dnode := O_Dnode_Null; + + when Kind_Signal => + -- The current value of the signal. + Signal_Value : Var_Type := Null_Var; + -- A pointer to the signal (contains meta data). + Signal_Sig : Var_Type; + -- Direct driver for signal (if any). + Signal_Driver : Var_Type := Null_Var; + -- RTI constant for the object. + Signal_Rti : O_Dnode := O_Dnode_Null; -- Function to compute the value of object (used for implicit -- guard signal declaration). - Object_Function : O_Dnode := O_Dnode_Null; + Signal_Function : O_Dnode := O_Dnode_Null; when Kind_Alias => Alias_Var : Var_Type; @@ -1383,6 +1429,7 @@ package Trans is subtype Index_Info_Acc is Ortho_Info_Acc (Kind_Index); subtype Subprg_Info_Acc is Ortho_Info_Acc (Kind_Subprg); subtype Object_Info_Acc is Ortho_Info_Acc (Kind_Object); + subtype Signal_Info_Acc is Ortho_Info_Acc (Kind_Signal); subtype Alias_Info_Acc is Ortho_Info_Acc (Kind_Alias); subtype Proc_Info_Acc is Ortho_Info_Acc (Kind_Process); subtype Psl_Info_Acc is Ortho_Info_Acc (Kind_Psl_Directive); diff --git a/src/vhdl/translate/translation.adb b/src/vhdl/translate/translation.adb index 516c3e9e3..a3d2375a7 100644 --- a/src/vhdl/translate/translation.adb +++ b/src/vhdl/translate/translation.adb @@ -390,6 +390,8 @@ package body Translation is Wki_Val := Get_Identifier ("val"); Wki_L_Len := Get_Identifier ("l_len"); Wki_R_Len := Get_Identifier ("r_len"); + Wki_Base := Get_Identifier ("BASE"); + Wki_Bounds := Get_Identifier ("BOUNDS"); Sizetype := New_Unsigned_Type (32); New_Type_Decl (Get_Identifier ("__ghdl_size_type"), Sizetype); |