diff options
| -rw-r--r-- | iirs.ads | 2 | ||||
| -rw-r--r-- | libraries/Makefile.inc | 4 | ||||
| -rw-r--r-- | translate/ghdldrv/ghdlrun.adb | 94 | ||||
| -rw-r--r-- | translate/grt/grt-cbinding.c | 2 | ||||
| -rw-r--r-- | translate/grt/grt-errors.adb | 6 | ||||
| -rw-r--r-- | translate/grt/grt-errors.ads | 3 | ||||
| -rw-r--r-- | translate/grt/grt-images.adb | 198 | ||||
| -rw-r--r-- | translate/grt/grt-images.ads | 38 | ||||
| -rw-r--r-- | translate/grt/grt-lib.adb | 109 | ||||
| -rw-r--r-- | translate/grt/grt-lib.ads | 35 | ||||
| -rw-r--r-- | translate/grt/grt-processes.adb | 4 | ||||
| -rw-r--r-- | translate/grt/grt-rtis.ads | 2 | ||||
| -rw-r--r-- | translate/grt/grt-rtis_utils.adb | 22 | ||||
| -rw-r--r-- | translate/grt/grt-rtis_utils.ads | 6 | ||||
| -rw-r--r-- | translate/grt/grt-std_logic_1164.adb | 70 | ||||
| -rw-r--r-- | translate/grt/grt-std_logic_1164.ads | 17 | ||||
| -rw-r--r-- | translate/grt/grt-types.ads | 16 | ||||
| -rw-r--r-- | translate/grt/grt-values.adb | 17 | ||||
| -rw-r--r-- | translate/trans_decls.ads | 13 | ||||
| -rw-r--r-- | translate/translation.adb | 1728 |
20 files changed, 1377 insertions, 1009 deletions
@@ -1802,6 +1802,7 @@ package Iirs is -- -- index_subtype_definition ::= type_mark RANGE <> -- + -- Note: Use Get_Element_Subtype to get the element subtype definition. -- Get/Set_Element_Subtype_Indication (Field1) -- -- Get/Set_Type_Declarator (Field3) @@ -2112,6 +2113,7 @@ package Iirs is -- Iir_Kind_Array_Subtype_Definition (Medium) -- + -- Note: Use Get_Element_Subtype to get the element subtype definition. -- Get/Set_Element_Subtype_Indication (Field1) -- -- Get/Set_Subtype_Type_Mark (Field2) diff --git a/libraries/Makefile.inc b/libraries/Makefile.inc index 9228351..5695068 100644 --- a/libraries/Makefile.inc +++ b/libraries/Makefile.inc @@ -208,8 +208,8 @@ std.v08: $(LIB08_DIR) $(STD08_SRCS) force mkdir $(STD08_DIR) prev=`pwd`; cd $(STD08_DIR); \ for i in $(STD08_SRCS); do \ - echo $$i; \ - $(ANALYZE08) --bootstrap --work=std $(REL_DIR)/$$i || exit 1; \ + cmd="$(ANALYZE08) --bootstrap --work=std $(REL_DIR)/$$i"; \ + echo $$cmd; eval $$cmd || exit 1; \ done; \ cd $$prev diff --git a/translate/ghdldrv/ghdlrun.adb b/translate/ghdldrv/ghdlrun.adb index 5bcb2b7..e5ea931 100644 --- a/translate/ghdldrv/ghdlrun.adb +++ b/translate/ghdldrv/ghdlrun.adb @@ -30,7 +30,6 @@ with Ortho_Nodes; use Ortho_Nodes; with Interfaces; with System; use System; with Trans_Decls; -with Types; with Iirs; use Iirs; with Flags; with Errorout; use Errorout; @@ -38,7 +37,6 @@ with Libraries; with Canon; with Trans_Be; with Translation; -with Std_Names; with Ieee.Std_Logic_1164; with Lists; @@ -151,48 +149,6 @@ package body Ghdlrun is Elaborate_Proc.all; end Ghdl_Elaborate; - function Find_Untruncated_Text_Read return O_Dnode - is - use Types; - use Std_Names; - File, Unit, Lib, Decl : Iir; - begin - if Libraries.Std_Library = Null_Iir then - return O_Dnode_Null; - end if; - File := Get_Design_File_Chain (Libraries.Std_Library); - L1 : loop - if File = Null_Iir then - return O_Dnode_Null; - end if; - Unit := Get_First_Design_Unit (File); - while Unit /= Null_Iir loop - Lib := Get_Library_Unit (Unit); - if Get_Kind (Lib) = Iir_Kind_Package_Body - and then Get_Identifier (Lib) = Name_Textio - then - exit L1; - end if; - Unit := Get_Chain (Unit); - end loop; - File := Get_Chain (File); - end loop L1; - - Decl := Get_Declaration_Chain (Lib); - while Decl /= Null_Iir loop - if Get_Kind (Decl) = Iir_Kind_Procedure_Declaration - and then Get_Identifier (Decl) = Name_Untruncated_Text_Read - then - if not Get_Foreign_Flag (Decl) then - raise Program_Error; - end if; - return Translation.Get_Ortho_Decl (Decl); - end if; - Decl := Get_Chain (Decl); - end loop; - return O_Dnode_Null; - end Find_Untruncated_Text_Read; - procedure Def (Decl : O_Dnode; Addr : Address) renames Ortho_Jit.Set_Address; @@ -219,7 +175,22 @@ package body Ghdlrun is end if; end; when Foreign_Intrinsic => - null; + Name_Table.Image (Get_Identifier (Decl)); + declare + Name : constant String := + Name_Table.Name_Buffer (1 .. Name_Table.Name_Length); + begin + if Name = "untruncated_text_read" then + Def (Ortho, Grt.Files.Ghdl_Untruncated_Text_Read'Address); + elsif Name = "control_simulation" then + Def (Ortho, Grt.Lib.Ghdl_Control_Simulation'Address); + elsif Name = "get_resolution_limit" then + Def (Ortho, Grt.Lib.Ghdl_Get_Resolution_Limit'Address); + else + Error_Msg_Sem ("unknown foreign intrinsic '" & Name & "'", + Decl); + end if; + end; when Foreign_Unknown => null; end case; @@ -252,6 +223,8 @@ package body Ghdlrun is Grt.Lib.Ghdl_Report'Address); Def (Trans_Decls.Ghdl_Assert_Failed, Grt.Lib.Ghdl_Assert_Failed'Address); + Def (Trans_Decls.Ghdl_Ieee_Assert_Failed, + Grt.Lib.Ghdl_Ieee_Assert_Failed'Address); Def (Trans_Decls.Ghdl_Psl_Assert_Failed, Grt.Lib.Ghdl_Psl_Assert_Failed'Address); Def (Trans_Decls.Ghdl_Psl_Cover, @@ -547,22 +520,41 @@ package body Ghdlrun is Def (Trans_Decls.Ghdl_Std_Ulogic_Match_Le, Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Match_Le'Address); + Def (Trans_Decls.Ghdl_Std_Ulogic_Array_Match_Eq, + Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Array_Match_Eq'Address); + Def (Trans_Decls.Ghdl_Std_Ulogic_Array_Match_Ne, + Grt.Std_Logic_1164.Ghdl_Std_Ulogic_Array_Match_Ne'Address); + Def (Trans_Decls.Ghdl_To_String_I32, Grt.Images.Ghdl_To_String_I32'Address); Def (Trans_Decls.Ghdl_To_String_F64, Grt.Images.Ghdl_To_String_F64'Address); Def (Trans_Decls.Ghdl_To_String_F64_Digits, Grt.Images.Ghdl_To_String_F64_Digits'Address); + Def (Trans_Decls.Ghdl_To_String_F64_Format, + Grt.Images.Ghdl_To_String_F64_Format'Address); + Def (Trans_Decls.Ghdl_To_String_B1, + Grt.Images.Ghdl_To_String_B1'Address); + Def (Trans_Decls.Ghdl_To_String_E8, + Grt.Images.Ghdl_To_String_E8'Address); + Def (Trans_Decls.Ghdl_To_String_E32, + Grt.Images.Ghdl_To_String_E32'Address); + Def (Trans_Decls.Ghdl_To_String_P32, + Grt.Images.Ghdl_To_String_P32'Address); + Def (Trans_Decls.Ghdl_To_String_P64, + Grt.Images.Ghdl_To_String_P64'Address); + Def (Trans_Decls.Ghdl_Time_To_String_Unit, + Grt.Images.Ghdl_Time_To_String_Unit'Address); Def (Trans_Decls.Ghdl_BV_To_Ostring, Grt.Images.Ghdl_BV_To_Ostring'Address); Def (Trans_Decls.Ghdl_BV_To_Hstring, Grt.Images.Ghdl_BV_To_Hstring'Address); - - -- Find untruncated_text_read, if any. - Decl := Find_Untruncated_Text_Read; - if Decl /= O_Dnode_Null then - Def (Decl, Grt.Files.Ghdl_Untruncated_Text_Read'Address); - end if; + Def (Trans_Decls.Ghdl_Array_Char_To_String_B1, + Grt.Images.Ghdl_Array_Char_To_String_B1'Address); + Def (Trans_Decls.Ghdl_Array_Char_To_String_E8, + Grt.Images.Ghdl_Array_Char_To_String_E8'Address); + Def (Trans_Decls.Ghdl_Array_Char_To_String_E32, + Grt.Images.Ghdl_Array_Char_To_String_E32'Address); Ortho_Jit.Link (Err); if Err then diff --git a/translate/grt/grt-cbinding.c b/translate/grt/grt-cbinding.c index 4da06c5..b95c0f0 100644 --- a/translate/grt/grt-cbinding.c +++ b/translate/grt/grt-cbinding.c @@ -52,7 +52,7 @@ __ghdl_snprintf_nf (char *buf, unsigned int len, int ndigits, double val) } void -__ghdl_snprintf_fmtf (const char *buf, unsigned int len, +__ghdl_snprintf_fmtf (char *buf, unsigned int len, const char *format, double v) { snprintf (buf, len, format, v); diff --git a/translate/grt/grt-errors.adb b/translate/grt/grt-errors.adb index 2d4d8f6..eddea38 100644 --- a/translate/grt/grt-errors.adb +++ b/translate/grt/grt-errors.adb @@ -46,6 +46,12 @@ package body Grt.Errors is pragma Import (C, Maybe_Return_Via_Longjump, "__ghdl_maybe_return_via_longjump"); + procedure Exit_Simulation is + begin + Maybe_Return_Via_Longjump (-2); + Internal_Error ("exit_simulation"); + end Exit_Simulation; + procedure Fatal_Error is begin if Error_Hook /= null then diff --git a/translate/grt/grt-errors.ads b/translate/grt/grt-errors.ads index 483ceab..c797a71 100644 --- a/translate/grt/grt-errors.ads +++ b/translate/grt/grt-errors.ads @@ -67,6 +67,9 @@ package Grt.Errors is pragma No_Return (Fatal_Error); pragma Export (C, Fatal_Error, "__ghdl_fatal"); + Exit_Status : Integer := 0; + procedure Exit_Simulation; + -- Hook called in case of error. Error_Hook : Grt.Hooks.Proc_Hook_Type := null; diff --git a/translate/grt/grt-images.adb b/translate/grt/grt-images.adb index 49bce9d..59830c1 100644 --- a/translate/grt/grt-images.adb +++ b/translate/grt/grt-images.adb @@ -29,6 +29,7 @@ with Ada.Unchecked_Conversion; with Grt.Rtis_Utils; use Grt.Rtis_Utils; with Grt.Processes; use Grt.Processes; with Grt.Vstrings; use Grt.Vstrings; +with Grt.Errors; use Grt.Errors; package body Grt.Images is function To_Std_String_Basep is new Ada.Unchecked_Conversion @@ -37,19 +38,25 @@ package body Grt.Images is function To_Std_String_Boundp is new Ada.Unchecked_Conversion (Source => System.Address, Target => Std_String_Boundp); - procedure Return_String (Res : Std_String_Ptr; Str : String) + procedure Set_String_Bounds (Res : Std_String_Ptr; Len : Ghdl_Index_Type) is begin - Res.Base := To_Std_String_Basep (Ghdl_Stack2_Allocate (Str'Length)); Res.Bounds := To_Std_String_Boundp (Ghdl_Stack2_Allocate (Std_String_Bound'Size / System.Storage_Unit)); + Res.Bounds.Dim_1 := (Left => 1, + Right => Std_Integer (Len), + Dir => Dir_To, + Length => Len); + end Set_String_Bounds; + + procedure Return_String (Res : Std_String_Ptr; Str : String) + is + begin + Res.Base := To_Std_String_Basep (Ghdl_Stack2_Allocate (Str'Length)); for I in 0 .. Str'Length - 1 loop Res.Base (Ghdl_Index_Type (I)) := Str (Str'First + I); end loop; - Res.Bounds.Dim_1 := (Left => 1, - Right => Str'Length, - Dir => Dir_To, - Length => Str'Length); + Set_String_Bounds (Res, Str'Length); end Return_String; procedure Return_Enum @@ -165,20 +172,195 @@ package body Grt.Images is Return_String (Res, Str (1 .. P)); end Ghdl_To_String_F64_Digits; + procedure Ghdl_To_String_F64_Format + (Res : Std_String_Ptr; Val : Ghdl_F64; Format : Std_String_Ptr) + is + C_Format : String (1 .. Positive (Format.Bounds.Dim_1.Length + 1)); + Str : Grt.Vstrings.String_Real_Format; + P : Natural; + begin + for I in 1 .. C_Format'Last - 1 loop + C_Format (I) := Format.Base (Ghdl_Index_Type (I - 1)); + end loop; + C_Format (C_Format'Last) := NUL; + + To_String (Str, P, Val, To_Ghdl_C_String (C_Format'Address)); + Return_String (Res, Str (1 .. P)); + end Ghdl_To_String_F64_Format; + + subtype Log_Base_Type is Ghdl_Index_Type range 3 .. 4; + Hex_Chars : constant array (Natural range 0 .. 15) of Character := + "0123456789ABCDEF"; + + procedure Ghdl_BV_To_String (Res : Std_String_Ptr; + Val : Std_Bit_Vector_Basep; + Len : Ghdl_Index_Type; + Log_Base : Log_Base_Type) + is + Res_Len : constant Ghdl_Index_Type := (Len + Log_Base - 1) / Log_Base; + Pos : Ghdl_Index_Type; + V : Natural; + Sh : Natural range 0 .. 4; + begin + Res.Base := To_Std_String_Basep (Ghdl_Stack2_Allocate (Res_Len)); + V := 0; + Sh := 0; + Pos := Res_Len - 1; + for I in reverse 1 .. Len loop + V := V + Std_Bit'Pos (Val (I - 1)) * (2 ** Sh); + Sh := Sh + 1; + if Sh = Natural (Log_Base) or else I = 1 then + Res.Base (Pos) := Hex_Chars (V); + Pos := Pos - 1; + Sh := 0; + V := 0; + end if; + end loop; + Set_String_Bounds (Res, Res_Len); + end Ghdl_BV_To_String; + procedure Ghdl_BV_To_Ostring (Res : Std_String_Ptr; Base : Std_Bit_Vector_Basep; Len : Ghdl_Index_Type) is begin - raise Program_Error; + Ghdl_BV_To_String (Res, Base, Len, 3); end Ghdl_BV_To_Ostring; procedure Ghdl_BV_To_Hstring (Res : Std_String_Ptr; Base : Std_Bit_Vector_Basep; Len : Ghdl_Index_Type) is begin - raise Program_Error; + Ghdl_BV_To_String (Res, Base, Len, 4); end Ghdl_BV_To_Hstring; + procedure To_String_Enum + (Res : Std_String_Ptr; Rti : Ghdl_Rti_Access; Index : Ghdl_Index_Type) + is + Enum_Rti : Ghdl_Rtin_Type_Enum_Acc; + Str : Ghdl_C_String; + begin + Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Str := Enum_Rti.Names (Index); + if Str (1) = ''' then + Return_String (Res, Str (2 .. 2)); + else + Return_String (Res, Str (1 .. strlen (Str))); + end if; + end To_String_Enum; + + procedure Ghdl_To_String_B1 + (Res : Std_String_Ptr; Val : Ghdl_B1; Rti : Ghdl_Rti_Access) is + begin + To_String_Enum (Res, Rti, Ghdl_B1'Pos (Val)); + end Ghdl_To_String_B1; + + procedure Ghdl_To_String_E8 + (Res : Std_String_Ptr; Val : Ghdl_E8; Rti : Ghdl_Rti_Access) is + begin + To_String_Enum (Res, Rti, Ghdl_E8'Pos (Val)); + end Ghdl_To_String_E8; + + procedure Ghdl_To_String_E32 + (Res : Std_String_Ptr; Val : Ghdl_E32; Rti : Ghdl_Rti_Access) is + begin + To_String_Enum (Res, Rti, Ghdl_E32'Pos (Val)); + end Ghdl_To_String_E32; + + procedure Ghdl_To_String_P32 + (Res : Std_String_Ptr; Val : Ghdl_I32; Rti : Ghdl_Rti_Access) + renames Ghdl_Image_P32; + + procedure Ghdl_To_String_P64 + (Res : Std_String_Ptr; Val : Ghdl_I64; Rti : Ghdl_Rti_Access) + renames Ghdl_Image_P64; + + procedure Ghdl_Time_To_String_Unit + (Res : Std_String_Ptr; + Val : Std_Time; Unit : Std_Time; Rti : Ghdl_Rti_Access) + is + Str : Grt.Vstrings.String_Time_Unit; + First : Natural; + Phys : constant Ghdl_Rtin_Type_Physical_Acc + := To_Ghdl_Rtin_Type_Physical_Acc (Rti); + Unit_Name : Ghdl_C_String; + Unit_Len : Natural; + begin + Unit_Name := null; + for I in 1 .. Phys.Nbr loop + if Get_Physical_Unit_Value (Phys.Units (I - 1), Rti) = Ghdl_I64 (Unit) + then + Unit_Name := Get_Physical_Unit_Name (Phys.Units (I - 1)); + exit; + end if; + end loop; + if Unit_Name = null then + Error ("no unit for to_string"); + end if; + Grt.Vstrings.To_String (Str, First, Ghdl_I64 (Val), Ghdl_I64 (Unit)); + Unit_Len := strlen (Unit_Name); + declare + L : constant Natural := Str'Last + 1 - First; + Str2 : String (1 .. L + 1 + Unit_Len); + begin + Str2 (1 .. L) := Str (First .. Str'Last); + Str2 (L + 1) := ' '; + Str2 (L + 2 .. Str2'Last) := Unit_Name (1 .. Unit_Len); + Return_String (Res, Str2); + end; + end Ghdl_Time_To_String_Unit; + + procedure Ghdl_Array_Char_To_String_B1 + (Res : Std_String_Ptr; + Val : Ghdl_Ptr; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access) + is + Enum_Rti : constant Ghdl_Rtin_Type_Enum_Acc := + To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Str : Ghdl_C_String; + Arr : constant Ghdl_B1_Array_Base_Ptr := To_Ghdl_B1_Array_Base_Ptr (Val); + begin + Res.Base := To_Std_String_Basep (Ghdl_Stack2_Allocate (Len)); + for I in 1 .. Len loop + Str := Enum_Rti.Names (Ghdl_B1'Pos (Arr (I - 1))); + Res.Base (I - 1) := Str (2); + end loop; + Set_String_Bounds (Res, Len); + end Ghdl_Array_Char_To_String_B1; + + procedure Ghdl_Array_Char_To_String_E8 + (Res : Std_String_Ptr; + Val : Ghdl_Ptr; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access) + is + Enum_Rti : constant Ghdl_Rtin_Type_Enum_Acc := + To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Str : Ghdl_C_String; + Arr : constant Ghdl_E8_Array_Base_Ptr := To_Ghdl_E8_Array_Base_Ptr (Val); + begin + Res.Base := To_Std_String_Basep (Ghdl_Stack2_Allocate (Len)); + for I in 1 .. Len loop + Str := Enum_Rti.Names (Ghdl_E8'Pos (Arr (I - 1))); + Res.Base (I - 1) := Str (2); + end loop; + Set_String_Bounds (Res, Len); + end Ghdl_Array_Char_To_String_E8; + + procedure Ghdl_Array_Char_To_String_E32 + (Res : Std_String_Ptr; + Val : Ghdl_Ptr; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access) + is + Enum_Rti : constant Ghdl_Rtin_Type_Enum_Acc := + To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Str : Ghdl_C_String; + Arr : constant Ghdl_E32_Array_Base_Ptr := + To_Ghdl_E32_Array_Base_Ptr (Val); + begin + Res.Base := To_Std_String_Basep (Ghdl_Stack2_Allocate (Len)); + for I in 1 .. Len loop + Str := Enum_Rti.Names (Ghdl_E32'Pos (Arr (I - 1))); + Res.Base (I - 1) := Str (2); + end loop; + Set_String_Bounds (Res, Len); + end Ghdl_Array_Char_To_String_E32; + -- procedure Ghdl_Image_F64 (Res : Std_String_Ptr; Val : Ghdl_F64) -- is -- -- Sign (1) + digit (1) + dot (1) + digits (15) + exp (1) + sign (1) diff --git a/translate/grt/grt-images.ads b/translate/grt/grt-images.ads index a5d8415..b85f8e6 100644 --- a/translate/grt/grt-images.ads +++ b/translate/grt/grt-images.ads @@ -46,6 +46,31 @@ package Grt.Images is procedure Ghdl_To_String_F64 (Res : Std_String_Ptr; Val : Ghdl_F64); procedure Ghdl_To_String_F64_Digits (Res : Std_String_Ptr; Val : Ghdl_F64; Nbr_Digits : Ghdl_I32); + procedure Ghdl_To_String_F64_Format + (Res : Std_String_Ptr; Val : Ghdl_F64; Format : Std_String_Ptr); + procedure Ghdl_To_String_B1 + (Res : Std_String_Ptr; Val : Ghdl_B1; Rti : Ghdl_Rti_Access); + procedure Ghdl_To_String_E8 + (Res : Std_String_Ptr; Val : Ghdl_E8; Rti : Ghdl_Rti_Access); + procedure Ghdl_To_String_E32 + (Res : Std_String_Ptr; Val : Ghdl_E32; Rti : Ghdl_Rti_Access); + procedure Ghdl_To_String_P32 + (Res : Std_String_Ptr; Val : Ghdl_I32; Rti : Ghdl_Rti_Access); + procedure Ghdl_To_String_P64 + (Res : Std_String_Ptr; Val : Ghdl_I64; Rti : Ghdl_Rti_Access); + procedure Ghdl_Time_To_String_Unit + (Res : Std_String_Ptr; + Val : Std_Time; Unit : Std_Time; Rti : Ghdl_Rti_Access); + procedure Ghdl_Array_Char_To_String_B1 + (Res : Std_String_Ptr; + Val : Ghdl_Ptr; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access); + procedure Ghdl_Array_Char_To_String_E8 + (Res : Std_String_Ptr; + Val : Ghdl_Ptr; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access); + procedure Ghdl_Array_Char_To_String_E32 + (Res : Std_String_Ptr; + Val : Ghdl_Ptr; Len : Ghdl_Index_Type; Rti : Ghdl_Rti_Access); + procedure Ghdl_BV_To_Ostring (Res : Std_String_Ptr; Base : Std_Bit_Vector_Basep; Len : Ghdl_Index_Type); @@ -64,6 +89,19 @@ private pragma Export (C, Ghdl_To_String_I32, "__ghdl_to_string_i32"); pragma Export (C, Ghdl_To_String_F64, "__ghdl_to_string_f64"); pragma Export (C, Ghdl_To_String_F64_Digits, "__ghdl_to_string_f64_digits"); + pragma Export (C, Ghdl_To_String_F64_Format, "__ghdl_to_string_f64_format"); + pragma Export (Ada, Ghdl_To_String_B1, "__ghdl_to_string_b1"); + pragma Export (C, Ghdl_To_String_E8, "__ghdl_to_string_e8"); + pragma Export (C, Ghdl_To_String_E32, "__ghdl_to_string_e32"); + pragma Export (C, Ghdl_To_String_P32, "__ghdl_to_string_p32"); + pragma Export (C, Ghdl_To_String_P64, "__ghdl_to_string_p64"); + pragma Export (C, Ghdl_Time_To_String_Unit, "__ghdl_time_to_string_unit"); + pragma Export (C, Ghdl_Array_Char_To_String_B1, + "__ghdl_array_char_to_string_b1"); + pragma Export (C, Ghdl_Array_Char_To_String_E8, + "__ghdl_array_char_to_string_e8"); + pragma Export (C, Ghdl_Array_Char_To_String_E32, + "__ghdl_array_char_to_string_e32"); pragma Export (C, Ghdl_BV_To_Ostring, "__ghdl_bv_to_ostring"); pragma Export (C, Ghdl_BV_To_Hstring, "__ghdl_bv_to_hstring"); end Grt.Images; diff --git a/translate/grt/grt-lib.adb b/translate/grt/grt-lib.adb index 3c10417..d2b095c 100644 --- a/translate/grt/grt-lib.adb +++ b/translate/grt/grt-lib.adb @@ -39,40 +39,14 @@ package body Grt.Lib is Memmove (Dest, Src, Size); end Ghdl_Memcpy; - Ieee_Name : constant String := "ieee" & NUL; - procedure Do_Report (Msg : String; Str : Std_String_Ptr; Default_Str : String; Severity : Integer; - Loc : Ghdl_Location_Ptr; - Unit : Ghdl_Rti_Access) + Loc : Ghdl_Location_Ptr) is - use Grt.Options; Level : constant Integer := Severity mod 256; begin - -- Assertions from ieee library can be disabled. - if Unit /= null - and then Unit.Kind = Ghdl_Rtik_Package_Body - and then (Ieee_Asserts = Disable_Asserts - or (Ieee_Asserts = Disable_Asserts_At_Time_0 - and Current_Time = 0)) - then - declare - Blk : constant Ghdl_Rtin_Block_Acc := - To_Ghdl_Rtin_Block_Acc (Unit); - Pkg : constant Ghdl_Rtin_Block_Acc := - To_Ghdl_Rtin_Block_Acc (Blk.Parent); - Lib : constant Ghdl_Rtin_Type_Scalar_Acc := - To_Ghdl_Rtin_Type_Scalar_Acc (Pkg.Parent); - begin - -- Return now if this assert comes from the ieee library. - if Strcmp (Lib.Name, To_Ghdl_C_String (Ieee_Name'Address)) = 0 then - return; - end if; - end; - end if; - Report_H; Report_C (Loc.Filename); Report_C (":"); @@ -109,56 +83,52 @@ package body Grt.Lib is end Do_Report; procedure Ghdl_Assert_Failed - (Str : Std_String_Ptr; - Severity : Integer; - Loc : Ghdl_Location_Ptr; - Unit : Ghdl_Rti_Access) + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr) is begin - Do_Report ("assertion", - Str, "Assertion violation", Severity, Loc, Unit); + Do_Report ("assertion", Str, "Assertion violation", Severity, Loc); end Ghdl_Assert_Failed; - procedure Ghdl_Psl_Assert_Failed - (Str : Std_String_Ptr; - Severity : Integer; - Loc : Ghdl_Location_Ptr; - Unit : Ghdl_Rti_Access) + procedure Ghdl_Ieee_Assert_Failed + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr) is + use Grt.Options; + begin + if Ieee_Asserts = Disable_Asserts + or else (Ieee_Asserts = Disable_Asserts_At_Time_0 and Current_Time = 0) + then + return; + else + Do_Report ("assertion", Str, "Assertion violation", Severity, Loc); + end if; + end Ghdl_Ieee_Assert_Failed; + + procedure Ghdl_Psl_Assert_Failed + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr) is begin - Do_Report ("psl assertion", - Str, "Assertion violation", Severity, Loc, Unit); + Do_Report ("psl assertion", Str, "Assertion violation", Severity, Loc); end Ghdl_Psl_Assert_Failed; procedure Ghdl_Psl_Cover - (Str : Std_String_Ptr; - Severity : Integer; - Loc : Ghdl_Location_Ptr; - Unit : Ghdl_Rti_Access) - is + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr) is begin - Do_Report ("psl cover", Str, "sequence covered", Severity, Loc, Unit); + Do_Report ("psl cover", Str, "sequence covered", Severity, Loc); end Ghdl_Psl_Cover; procedure Ghdl_Psl_Cover_Failed - (Str : Std_String_Ptr; - Severity : Integer; - Loc : Ghdl_Location_Ptr; - Unit : Ghdl_Rti_Access) - is + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr) is begin Do_Report ("psl cover failure", - Str, "sequence not covered", Severity, Loc, Unit); + Str, "sequence not covered", Severity, Loc); end Ghdl_Psl_Cover_Failed; procedure Ghdl_Report (Str : Std_String_Ptr; Severity : Integer; - Loc : Ghdl_Location_Ptr; - Unit : Ghdl_Rti_Access) + Loc : Ghdl_Location_Ptr) is begin - Do_Report ("report", Str, "Assertion violation", Severity, Loc, Unit); + Do_Report ("report", Str, "Assertion violation", Severity, Loc); end Ghdl_Report; procedure Ghdl_Program_Error (Filename : Ghdl_C_String; @@ -295,7 +265,34 @@ package body Grt.Lib is return 1.0 / Res; end if; end Ghdl_Real_Exp; -end Grt.Lib; + function Ghdl_Get_Resolution_Limit return Std_Time is + begin + return 1; + end Ghdl_Get_Resolution_Limit; + procedure Ghdl_Control_Simulation + (Stop : Ghdl_B1; Has_Status : Ghdl_B1; Status : Std_Integer) is + begin + Report_H; + -- Report_C (Grt.Options.Progname); + Report_C ("simulation "); + if Stop then + Report_C ("stopped"); + else + Report_C ("finished"); + end if; + Report_C (" @"); + Report_Now_C; + if Has_Status then + Report_C (" with status "); + Report_C (Integer (Status)); + end if; + Report_E (""); + if Has_Status then + Exit_Status := Integer (Status); + end if; + Exit_Simulation; + end Ghdl_Control_Simulation; +end Grt.Lib; diff --git a/translate/grt/grt-lib.ads b/translate/grt/grt-lib.ads index b0dc0a3..4dac2c8 100644 --- a/translate/grt/grt-lib.ads +++ b/translate/grt/grt-lib.ads @@ -32,35 +32,24 @@ package Grt.Lib is (Dest : Ghdl_Ptr; Src : Ghdl_Ptr; Size : Ghdl_Index_Type); procedure Ghdl_Assert_Failed - (Str : Std_String_Ptr; - Severity : Integer; - Loc : Ghdl_Location_Ptr; - Unit : Ghdl_Rti_Access); + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr); + procedure Ghdl_Ieee_Assert_Failed + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr); procedure Ghdl_Psl_Assert_Failed (Str : Std_String_Ptr; Severity : Integer; - Loc : Ghdl_Location_Ptr; - Unit : Ghdl_Rti_Access); + Loc : Ghdl_Location_Ptr); -- Called when a sequence is covered (in a cover directive) procedure Ghdl_Psl_Cover - (Str : Std_String_Ptr; - Severity : Integer; - Loc : Ghdl_Location_Ptr; - Unit : Ghdl_Rti_Access); + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr); procedure Ghdl_Psl_Cover_Failed - (Str : Std_String_Ptr; - Severity : Integer; - Loc : Ghdl_Location_Ptr; - Unit : Ghdl_Rti_Access); + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr); procedure Ghdl_Report - (Str : Std_String_Ptr; - Severity : Integer; - Loc : Ghdl_Location_Ptr; - Unit : Ghdl_Rti_Access); + (Str : Std_String_Ptr; Severity : Integer; Loc : Ghdl_Location_Ptr); Note_Severity : constant Integer := 0; Warning_Severity : constant Integer := 1; @@ -103,10 +92,15 @@ package Grt.Lib is True, -- H False -- - ); + + function Ghdl_Get_Resolution_Limit return Std_Time; + procedure Ghdl_Control_Simulation + (Stop : Ghdl_B1; Has_Status : Ghdl_B1; Status : Std_Integer); private pragma Export (C, Ghdl_Memcpy, "__ghdl_memcpy"); pragma Export (C, Ghdl_Assert_Failed, "__ghdl_assert_failed"); + pragma Export (C, Ghdl_Ieee_Assert_Failed, "__ghdl_ieee_assert_failed"); pragma Export (C, Ghdl_Psl_Assert_Failed, "__ghdl_psl_assert_failed"); pragma Export (C, Ghdl_Psl_Cover, "__ghdl_psl_cover"); pragma Export (C, Ghdl_Psl_Cover_Failed, "__ghdl_psl_cover_failed"); @@ -125,4 +119,9 @@ private pragma Export (C, Ghdl_Std_Ulogic_To_Boolean_Array, "__ghdl_std_ulogic_to_boolean_array"); + + pragma Export (C, Ghdl_Get_Resolution_Limit, + "__ghdl_get_resolution_limit"); + pragma Export (Ada, Ghdl_Control_Simulation, + "__ghdl_control_simulation"); end Grt.Lib; diff --git a/translate/grt/grt-processes.adb b/translate/grt/grt-processes.adb index 3d40f3a..64db682 100644 --- a/translate/grt/grt-processes.adb +++ b/translate/grt/grt-processes.adb @@ -995,7 +995,7 @@ package body Grt.Processes is Grt.Disp.Disp_Now; end if; Status := Run_Through_Longjump (Simulation_Cycle'Access); - exit when Status = Run_Failure; + exit when Status < 0; if Trace_Signals then Grt.Disp_Signals.Disp_All_Signals; end if; @@ -1035,7 +1035,7 @@ package body Grt.Processes is if Status = Run_Failure then return -1; else - return 0; + return Exit_Status ; end if; end Simulation; diff --git a/translate/grt/grt-rtis.ads b/translate/grt/grt-rtis.ads index c441b40..6bb7659 100644 --- a/translate/grt/grt-rtis.ads +++ b/translate/grt/grt-rtis.ads @@ -190,6 +190,8 @@ package Grt.Rtis is Common : Ghdl_Rti_Common; Name : Ghdl_C_String; Nbr : Ghdl_Index_Type; + -- Characters are represented as 'X', identifiers are represented as is, + -- extended identifiers are represented as is too. Names : Ghdl_C_String_Array_Ptr; end record; type Ghdl_Rtin_Type_Enum_Acc is access Ghdl_Rtin_Type_Enum; diff --git a/translate/grt/grt-rtis_utils.adb b/translate/grt/grt-rtis_utils.adb index 4df5d6f..0d4328e 100644 --- a/translate/grt/grt-rtis_utils.adb +++ b/translate/grt/grt-rtis_utils.adb @@ -498,6 +498,28 @@ package body Grt.Rtis_Utils is end case; end Get_Physical_Unit_Name; + function Get_Physical_Unit_Value (Unit : Ghdl_Rti_Access; + Type_Rti : Ghdl_Rti_Access) + return Ghdl_I64 is + begin + case Unit.Kind is + when Ghdl_Rtik_Unit64 => + return To_Ghdl_Rtin_Unit64_Acc (Unit).Value; + when Ghdl_Rtik_Unitptr => + case Type_Rti.Kind is + when Ghdl_Rtik_Type_P64 => + return To_Ghdl_Rtin_Unitptr_Acc (Unit).Addr.I64; + when Ghdl_Rtik_Type_P32 => + return Ghdl_I64 + (To_Ghdl_Rtin_Unitptr_Acc (Unit).Addr.I32); + when others => + Internal_Error ("get_physical_unit_value(1)"); + end case; + when others => + Internal_Error ("get_physical_unit_value(2)"); + end case; + end Get_Physical_Unit_Value; + procedure Get_Enum_Value (Rstr : in out Rstring; Rti : Ghdl_Rti_Access; Val : Ghdl_Index_Type) is diff --git a/translate/grt/grt-rtis_utils.ads b/translate/grt/grt-rtis_utils.ads index 0cb6e3e..10c1a0f 100644 --- a/translate/grt/grt-rtis_utils.ads +++ b/translate/grt/grt-rtis_utils.ads @@ -69,6 +69,12 @@ package Grt.Rtis_Utils is -- Get the name of a physical unit. function Get_Physical_Unit_Name (Unit : Ghdl_Rti_Access) return Ghdl_C_String; + + -- Get the value of a physical unit. + function Get_Physical_Unit_Value (Unit : Ghdl_Rti_Access; + Type_Rti : Ghdl_Rti_Access) + return Ghdl_I64; + -- Disp a value. procedure Disp_Value (Stream : FILEs; Value : Value_Union; diff --git a/translate/grt/grt-std_logic_1164.adb b/translate/grt/grt-std_logic_1164.adb index 49d96e7..5be308b 100644 --- a/translate/grt/grt-std_logic_1164.adb +++ b/translate/grt/grt-std_logic_1164.adb @@ -26,16 +26,16 @@ with Grt.Lib; package body Grt.Std_Logic_1164 is - Assert_Msg : constant String := + Assert_DC_Msg : constant String := "STD_LOGIC_1164: '-' operand for matching ordering operator"; - Assert_Msg_Bound : constant Std_String_Bound := - (Dim_1 => (Left => 1, Right => Assert_Msg'Length, Dir => Dir_To, - Length => Assert_Msg'Length)); + Assert_DC_Msg_Bound : constant Std_String_Bound := + (Dim_1 => (Left => 1, Right => Assert_DC_Msg'Length, Dir => Dir_To, + Length => Assert_DC_Msg'Length)); - Assert_Msg_Str : aliased constant Std_String := - (Base => To_Std_String_Basep (Assert_Msg'Address), - Bounds => To_Std_String_Boundp (Assert_Msg_Bound'Address)); + Assert_DC_Msg_Str : aliased constant Std_String := + (Base => To_Std_String_Basep (Assert_DC_Msg'Address), + Bounds => To_Std_String_Boundp (Assert_DC_Msg_Bound'Address)); Filename : constant String := "std_logic_1164.vhdl" & NUL; Loc : aliased constant Ghdl_Location := @@ -48,10 +48,9 @@ package body Grt.Std_Logic_1164 is use Grt.Lib; begin if V = '-' then - -- FIXME: assert disabled for ieee. - Ghdl_Assert_Failed - (To_Std_String_Ptr (Assert_Msg_Str'Address), Error_Severity, - To_Ghdl_Location_Ptr (Loc'Address), null); + Ghdl_Ieee_Assert_Failed + (To_Std_String_Ptr (Assert_DC_Msg_Str'Address), Error_Severity, + To_Ghdl_Location_Ptr (Loc'Address)); end if; end Assert_Not_Match; @@ -95,4 +94,53 @@ package body Grt.Std_Logic_1164 is return Std_Ulogic'Pos (Or_Table (Match_Lt_Table (Left, Right), Match_Eq_Table (Left, Right))); end Ghdl_Std_Ulogic_Match_Le; + + Assert_Arr_Msg : constant String := + "parameters of '?=' array operator are not of the same length"; + + Assert_Arr_Msg_Bound : constant Std_String_Bound := + (Dim_1 => (Left => 1, Right => Assert_Arr_Msg'Length, Dir => Dir_To, + Length => Assert_Arr_Msg'Length)); + + Assert_Arr_Msg_Str : aliased constant Std_String := + (Base => To_Std_String_Basep (Assert_Arr_Msg'Address), + Bounds => To_Std_String_Boundp (Assert_Arr_Msg_Bound'Address)); + + + function Ghdl_Std_Ulogic_Array_Match_Eq (L : Ghdl_Ptr; + L_Len : Ghdl_Index_Type; + R : Ghdl_Ptr; + R_Len : Ghdl_Index_Type) + return Ghdl_I32 + is + use Grt.Lib; + L_Arr : constant Ghdl_E8_Array_Base_Ptr := + To_Ghdl_E8_Array_Base_Ptr (L); + R_Arr : constant Ghdl_E8_Array_Base_Ptr := + To_Ghdl_E8_Array_Base_Ptr (R); + Res : Std_Ulogic := '1'; + begin + if L_Len /= R_Len then + Ghdl_Ieee_Assert_Failed + (To_Std_String_Ptr (Assert_Arr_Msg_Str'Address), Error_Severity, + To_Ghdl_Location_Ptr (Loc'Address)); + end if; + for I in 1 .. L_Len loop + Res := And_Table + (Res, Std_Ulogic'Val (Ghdl_Std_Ulogic_Match_Eq (L_Arr (I - 1), + R_Arr (I - 1)))); + end loop; + return Std_Ulogic'Pos (Res); + end Ghdl_Std_Ulogic_Array_Match_Eq; + + function Ghdl_Std_Ulogic_Array_Match_Ne (L : Ghdl_Ptr; + L_Len : Ghdl_Index_Type; + R : Ghdl_Ptr; + R_Len : Ghdl_Index_Type) + return Ghdl_I32 is + begin + return Std_Ulogic'Pos + (Not_Table (Std_Ulogic'Val + (Ghdl_Std_Ulogic_Array_Match_Eq (L, L_Len, R, R_Len)))); + end Ghdl_Std_Ulogic_Array_Match_Ne; end Grt.Std_Logic_1164; diff --git a/translate/grt/grt-std_logic_1164.ads b/translate/grt/grt-std_logic_1164.ads index d6b1b7d..4d15695 100644 --- a/translate/grt/grt-std_logic_1164.ads +++ b/translate/grt/grt-std_logic_1164.ads @@ -99,9 +99,26 @@ package Grt.Std_Logic_1164 is function Ghdl_Std_Ulogic_Match_Lt (L, R : Ghdl_E8) return Ghdl_E8; function Ghdl_Std_Ulogic_Match_Le (L, R : Ghdl_E8) return Ghdl_E8; -- For Gt and Ge, use Lt and Le with swapped parameters. + + function Ghdl_Std_Ulogic_Array_Match_Eq (L : Ghdl_Ptr; + L_Len : Ghdl_Index_Type; + R : Ghdl_Ptr; + R_Len : Ghdl_Index_Type) + return Ghdl_I32; + function Ghdl_Std_Ulogic_Array_Match_Ne (L : Ghdl_Ptr; + L_Len : Ghdl_Index_Type; + R : Ghdl_Ptr; + R_Len : Ghdl_Index_Type) + return Ghdl_I32; + private pragma Export (C, Ghdl_Std_Ulogic_Match_Eq, "__ghdl_std_ulogic_match_eq"); pragma Export (C, Ghdl_Std_Ulogic_Match_Ne, "__ghdl_std_ulogic_match_ne"); pragma Export (C, Ghdl_Std_Ulogic_Match_Lt, "__ghdl_std_ulogic_match_lt"); pragma Export (C, Ghdl_Std_Ulogic_Match_Le, "__ghdl_std_ulogic_match_le"); + + pragma Export (C, Ghdl_Std_Ulogic_Array_Match_Eq, + "__ghdl_std_ulogic_array_match_eq"); + pragma Export (C, Ghdl_Std_Ulogic_Array_Match_Ne, + "__ghdl_std_ulogic_array_match_ne"); end Grt.Std_Logic_1164; diff --git a/translate/grt/grt-types.ads b/translate/grt/grt-types.ads index 96bd97b..fed8225 100644 --- a/translate/grt/grt-types.ads +++ b/translate/grt/grt-types.ads @@ -171,7 +171,23 @@ package Grt.Types is (Mode_B1, Mode_E8, Mode_E32, Mode_I32, Mode_I64, Mode_F64); type Ghdl_B1_Array is array (Ghdl_Index_Type range <>) of Ghdl_B1; + subtype Ghdl_B1_Array_Base is Ghdl_B1_Array (Ghdl_Index_Type); + type Ghdl_B1_Array_Base_Ptr is access Ghdl_B1_Array_Base; + function To_Ghdl_B1_Array_Base_Ptr is new Ada.Unchecked_Conversion + (Source => Ghdl_Ptr, Target => Ghdl_B1_Array_Base_Ptr); + type Ghdl_E8_Array is array (Ghdl_Index_Type range <>) of Ghdl_E8; + subtype Ghdl_E8_Array_Base is Ghdl_E8_Array (Ghdl_Index_Type); + type Ghdl_E8_Array_Base_Ptr is access Ghdl_E8_Array_Base; + function To_Ghdl_E8_Array_Base_Ptr is new Ada.Unchecked_Conversion + (Source => Ghdl_Ptr, Target => Ghdl_E8_Array_Base_Ptr); + + type Ghdl_E32_Array is array (Ghdl_Index_Type range <>) of Ghdl_E32; + subtype Ghdl_E32_Array_Base is Ghdl_E32_Array (Ghdl_Index_Type); + type Ghdl_E32_Array_Base_Ptr is access Ghdl_E32_Array_Base; + function To_Ghdl_E32_Array_Base_Ptr is new Ada.Unchecked_Conversion + (Source => Ghdl_Ptr, Target => Ghdl_E32_Array_Base_Ptr); + type Ghdl_I32_Array is array (Ghdl_Index_Type range <>) of Ghdl_I32; type Value_Union (Mode : Mode_Type := Mode_B1) is record diff --git a/translate/grt/grt-values.adb b/translate/grt/grt-values.adb index 209f658..3d703bc 100644 --- a/translate/grt/grt-values.adb +++ b/translate/grt/grt-values.adb @@ -602,22 +602,7 @@ package body Grt.Values is Error_E ("'"); end if; - case Multiple.Kind is - when Ghdl_Rtik_Unit64 => - Mult := To_Ghdl_Rtin_Unit64_Acc (Multiple).Value; - when Ghdl_Rtik_Unitptr => - case Rti.Kind is - when Ghdl_Rtik_Type_P64 => - Mult := To_Ghdl_Rtin_Unitptr_Acc (Multiple).Addr.I64; - when Ghdl_Rtik_Type_P32 => - Mult := Ghdl_I64 - (To_Ghdl_Rtin_Unitptr_Acc (Multiple).Addr.I32); - when others => - Internal_Error ("values.physical_type(P32/P64-1)"); - end case; - when others => - Internal_Error ("values.physical_type(P32/P64-2)"); - end case; + Mult := Grt.Rtis_Utils.Get_Physical_Unit_Value (Multiple, Rti); if Lit_End = 0 then return Mult; diff --git a/translate/trans_decls.ads b/translate/trans_decls.ads index 5ee9989..3ceb907 100644 --- a/translate/trans_decls.ads +++ b/translate/trans_decls.ads @@ -20,6 +20,7 @@ with Ortho_Nodes; use Ortho_Nodes; package Trans_Decls is -- Procedures called in case of assert failed. Ghdl_Assert_Failed : O_Dnode; + Ghdl_Ieee_Assert_Failed : O_Dnode; Ghdl_Psl_Assert_Failed : O_Dnode; Ghdl_Psl_Cover : O_Dnode; @@ -225,11 +226,23 @@ package Trans_Decls is Ghdl_Std_Ulogic_Match_Ne : O_Dnode; Ghdl_Std_Ulogic_Match_Lt : O_Dnode; Ghdl_Std_Ulogic_Match_Le : O_Dnode; + Ghdl_Std_Ulogic_Array_Match_Eq : O_Dnode; + Ghdl_Std_Ulogic_Array_Match_Ne : O_Dnode; -- For To_String (vhdl 2008). Ghdl_To_String_I32 : O_Dnode; Ghdl_To_String_F64 : O_Dnode; Ghdl_To_String_F64_Digits : O_Dnode; + Ghdl_To_String_F64_Format : O_Dnode; + Ghdl_To_String_B1 : O_Dnode; + Ghdl_To_String_E8 : O_Dnode; + Ghdl_To_String_E32 : O_Dnode; + Ghdl_To_String_P32 : O_Dnode; + Ghdl_To_String_P64 : O_Dnode; + Ghdl_Time_To_String_Unit : O_Dnode; + Ghdl_Array_Char_To_String_B1 : O_Dnode; + Ghdl_Array_Char_To_String_E8 : O_Dnode; + Ghdl_Array_Char_To_String_E32 : O_Dnode; Ghdl_BV_To_String : O_Dnode; Ghdl_BV_To_Ostring : O_Dnode; Ghdl_BV_To_Hstring : O_Dnode; diff --git a/translate/translation.adb b/translate/translation.adb index 17d1409..2b9d1cf 100644 --- a/translate/translation.adb +++ b/translate/translation.adb @@ -179,6 +179,9 @@ package body Translation is Wki_Cmp : O_Ident; Wki_Upframe : O_Ident; Wki_Frame : O_Ident; + Wki_Val : O_Ident; + Wki_L_Len : O_Ident; + Wki_R_Len : O_Ident; -- ALLOCATION_KIND defines the type of memory storage. -- ALLOC_STACK means the object is allocated on the local stack and @@ -1611,30 +1614,6 @@ package body Translation is return Tinfo.C /= null; end Is_Complex_Type; - - -- Convert an o_lnode to an o_enode, either by taking value or address. - function L2e_Node (L : O_Lnode; - Type_Info : Type_Info_Acc; - Kind : Object_Kind_Type) - return O_Enode is - begin - case Type_Info.Type_Mode is - when Type_Mode_Unknown => - raise Internal_Error; - when Type_Mode_Scalar - | Type_Mode_Acc - | Type_Mode_File => - return New_Value (L); - when Type_Mode_Fat_Array - | Type_Mode_Fat_Acc => - return New_Address (L, Type_Info.Ortho_Ptr_Type (Kind)); - when Type_Mode_Record - | Type_Mode_Array - | Type_Mode_Protected => - return New_Address (L, Type_Info.Ortho_Ptr_Type (Kind)); - end case; - end L2e_Node; - -- In order to simplify the handling of Enode/Lnode, let's introduce -- Mnode (yes, another node). -- An Mnode is a typed union, containing either an Lnode or a Enode. @@ -1862,12 +1841,14 @@ package body Translation is function Slice_Base (Base : Mnode; Atype : Iir; Index : O_Enode) return Mnode; - -- Get the length of the array. + -- Get the length of the array (the number of elements). function Get_Array_Length (Arr : Mnode; Atype : Iir) return O_Enode; - function Get_Bounds_Ptr_Length (Ptr : O_Dnode; Atype : Iir) - return O_Enode; + -- Get the number of elements for bounds BOUNDS. BOUNDS are + -- automatically stabilized if necessary. + function Get_Bounds_Length (Bounds : Mnode; Atype : Iir) return O_Enode; + -- Get the number of elements in array ATYPE. function Get_Array_Type_Length (Atype : Iir) return O_Enode; -- Get the base of array ARR. @@ -1901,30 +1882,6 @@ package body Translation is -- Get array bounds for type ATYPE. function Get_Array_Type_Bounds (Atype : Iir) return Mnode; - -- Return the a pointer to the array base from variable PTR - -- containing a pointer to array. - function Get_Array_Ptr_Base_Ptr - (Ptr : O_Lnode; Atype : Iir; Is_Sig : Object_Kind_Type) - return O_Lnode; - - -- Return pointer to range DIM of array pointed by PTR. - function Get_Array_Ptr_Range_Ptr (Ptr : O_Lnode; - Array_Type : Iir; - Dim : Natural; - Is_Sig : Object_Kind_Type) - return O_Enode; - - - function Get_Array_Bounds_Ptr - (Arr : O_Lnode; Arr_Type : Iir; Is_Sig : Object_Kind_Type) - return O_Enode; - - -- Return the bounds field of a fat array from variable PTR containing a - -- pointer to a fat array. - function Get_Array_Ptr_Bounds_Ptr - (Ptr : O_Lnode; Atype : Iir; Is_Sig : Object_Kind_Type) - return O_Enode; - -- Deallocate OBJ. procedure Gen_Deallocate (Obj : O_Enode); @@ -1939,7 +1896,7 @@ package body Translation is (Res : in out Mnode; Alloc_Kind : Allocation_Kind; Obj_Type : Iir; - Bounds : O_Enode); + Bounds : Mnode); -- Copy SRC to DEST. -- Both have the same type, OTYPE. @@ -1990,6 +1947,10 @@ package body Translation is (Value : O_Enode; Expr : Iir; Atype : Iir) return O_Enode; + -- Return True iff all indexes of L_TYPE and R_TYPE have the same + -- length. They must be locally static. + function Locally_Array_Match (L_Type, R_Type : Iir) return Boolean; + -- Check bounds length of L match bounds length of R. -- If L_TYPE (resp. R_TYPE) is not a thin array, then L_NODE -- (resp. R_NODE) are not used (and may be Mnode_Null). @@ -2139,45 +2100,10 @@ package body Translation is El : Iir_Element_Declaration) return Mnode; --- -- Get direction/length/left bound/right bound of dimension DIM of --- -- array ARR whose type if ARR_TYPE. --- -- For a thin array, ARR is the array; --- -- For a fat array, ARR is the fat array (ie the record with base and --- -- bounds pointer) and not a pointer. --- function Get_Array_Bound_Dir (Arr : O_Lnode; --- Arr_Type : Iir; --- Dim : Natural; --- Is_Sig : Object_Kind_Type) --- return O_Enode; - function Get_Array_Bound_Length (Arr : O_Lnode; + function Get_Array_Bound_Length (Arr : Mnode; Arr_Type : Iir; - Dim : Natural; - Is_Sig : Object_Kind_Type) - - return O_Enode; - function Get_Array_Ptr_Bound_Length (Ptr : O_Lnode; - Arr_Type : Iir; - Dim : Natural; - Is_Sig : Object_Kind_Type) - return O_Enode; --- function Get_Array_Bound_Left (Arr : O_Lnode; --- Arr_Type : Iir; --- Dim : Natural; --- Is_Sig : Object_Kind_Type) --- return O_Enode; --- function Get_Array_Bound_Right (Arr : O_Lnode; --- Arr_Type : Iir; --- Dim : Natural; --- Is_Sig : Object_Kind_Type) --- return O_Enode; - - -- Extract from fat array FAT_ARRAY the range corresponding to dimension - -- DIM. - function Fat_Array_To_Range (Fat_Array : O_Lnode; - Array_Type : Iir; - Dim : Natural; - Is_Sig : Object_Kind_Type) - return O_Lnode; + Dim : Natural) + return O_Enode; procedure Gen_Bound_Error (Loc : Iir); @@ -2376,7 +2302,7 @@ package body Translation is function Translate_Ascending_Array_Attribute (Expr : Iir) return O_Enode; function Translate_High_Low_Type_Attribute - (Attr : Iir; Is_High : Boolean) return O_Enode; + (Atype : Iir; Is_High : Boolean) return O_Enode; -- Return the value of the left bound/right bound/direction of scalar -- type ATYPE. @@ -2428,11 +2354,6 @@ package body Translation is -- D and S are stabilized fat pointers. procedure Copy_Fat_Pointer (D : Mnode; S: Mnode); - -- Copy a fat access. - -- D and S are variable containing address of the fat pointer. - -- PTR_TYPE is the type of the fat access. - procedure Copy_Fat_Access (D : O_Dnode; S : O_Dnode; Ptr_Type : Iir); - -- Generate code to initialize a ghdl_index_type variable V to 0. procedure Init_Var (V : O_Dnode); @@ -2459,11 +2380,6 @@ package body Translation is -- address of NAME. function Create_Temp_Ptr (Atype : O_Tnode; Name : O_Lnode) return O_Dnode; - -- Create a temporary variable for ATYPE and assign it with address - -- of NAME. - function Create_Temp_Ptr - (Atype : Iir; Name : O_Lnode; Is_Sig : Object_Kind_Type) - return O_Dnode; -- Create a mark in the temporary region for the stack2. -- FIXME: maybe a flag must be added to CLOSE_TEMP where it is known -- stack2 can be released. @@ -3287,27 +3203,6 @@ package body Translation is M2Addr (Chap3.Get_Array_Bounds (S))); end Copy_Fat_Pointer; - procedure Copy_Fat_Pointer - (D : O_Dnode; S : O_Dnode; Ftype : Iir; Is_Sig : Object_Kind_Type) - is - Info : constant Type_Info_Acc := Get_Info (Ftype); - begin - New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (D), Info.T.Base_Field (Is_Sig)), - New_Value_Selected_Acc_Value (New_Obj (S), - Info.T.Base_Field (Is_Sig))); - New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (D), Info.T.Bounds_Field (Is_Sig)), - New_Value_Selected_Acc_Value (New_Obj (S), - Info.T.Bounds_Field (Is_Sig))); - end Copy_Fat_Pointer; - - procedure Copy_Fat_Access (D : O_Dnode; S : O_Dnode; Ptr_Type : Iir) - is - begin - Copy_Fat_Pointer (D, S, Get_Designated_Type (Ptr_Type), Mode_Value); - end Copy_Fat_Access; - procedure Inc_Var (V : O_Dnode) is begin New_Assign_Stmt (New_Obj (V), @@ -3586,16 +3481,6 @@ package body Translation is return Create_Temp_Init (Atype, New_Address (Name, Atype)); end Create_Temp_Ptr; - function Create_Temp_Ptr - (Atype : Iir; Name : O_Lnode; Is_Sig : Object_Kind_Type) - return O_Dnode - is - Temp_Type : O_Tnode; - begin - Temp_Type := Get_Info (Atype).Ortho_Ptr_Type (Is_Sig); - return Create_Temp_Init (Temp_Type, New_Address (Name, Temp_Type)); - end Create_Temp_Ptr; - -- Return a ghdl_index_type literal for NUM. function New_Index_Lit (Num : Unsigned_64) return O_Cnode is begin @@ -5945,16 +5830,15 @@ package body Translation is Kind : Object_Kind_Type) return O_Enode is - Tinfo : Type_Info_Acc; - Binfo : Type_Info_Acc; + Tinfo : constant Type_Info_Acc := Get_Info (Var_Type); + Binfo : constant Type_Info_Acc := Get_Info (Get_Base_Type (Var_Type)); Assoc : O_Assoc_List; begin - Tinfo := Get_Info (Var_Type); -- Build the field - Binfo := Get_Info (Get_Base_Type (Var_Type)); Start_Association (Assoc, Binfo.C (Kind).Builder_Func); Chap2.Add_Subprg_Instance_Assoc (Assoc, Binfo.C (Kind).Builder_Instance); + case Tinfo.Type_Mode is when Type_Mode_Record | Type_Mode_Array => @@ -5968,20 +5852,22 @@ package body Translation is when others => raise Internal_Error; end case; - case Tinfo.Type_Mode is - when Type_Mode_Array => - New_Association - (Assoc, - Get_Array_Bounds_Ptr (O_Lnode_Null, Var_Type, Kind)); - when Type_Mode_Fat_Array => + + if Tinfo.Type_Mode in Type_Mode_Arrays then + declare + Arr : Mnode; + begin + case Type_Mode_Arrays (Tinfo.Type_Mode) is + when Type_Mode_Array => + Arr := T2M (Var_Type, Kind); + when Type_Mode_Fat_Array => + Arr := Dp2M (Var_Ptr, Tinfo, Kind); + end case; New_Association - (Assoc, Get_Array_Ptr_Bounds_Ptr (New_Obj (Var_Ptr), - Var_Type, Kind)); - when Type_Mode_Record => - null; - when others => - raise Internal_Error; - end case; + (Assoc, M2Addr (Chap3.Get_Array_Bounds (Arr))); + end; + end if; + return New_Function_Call (Assoc); end Gen_Call_Type_Builder; @@ -6758,11 +6644,10 @@ package body Translation is procedure Create_Array_Subtype_Bounds_Var (Def : Iir; Elab_Now : Boolean) is - Info : Type_Info_Acc; + Info : constant Type_Info_Acc := Get_Info (Def); Base_Info : Type_Info_Acc; Val : O_Cnode; begin - Info := Get_Info (Def); if Info.T.Array_Bounds /= null then return; end if; @@ -6826,7 +6711,11 @@ package body Translation is (New_Obj (Var_Length), New_Dyadic_Op (ON_Mul_Ov, New_Value (Get_Var (El_Info.C (Kind).Size_Var)), - Get_Bounds_Ptr_Length (Bound, Def))); + Get_Bounds_Length (Dp2M (Bound, Info, + Mode_Value, + Info.T.Bounds_Type, + Info.T.Bounds_Ptr_Type), + Def))); -- Find the innermost non-array element. while El_Info.Type_Mode = Type_Mode_Array loop @@ -8243,9 +8132,8 @@ package body Translation is function Range_To_Length (R : Mnode) return Mnode is - Tinfo : Type_Info_Acc; + Tinfo : constant Type_Info_Acc := Get_Type_Info (R); begin - Tinfo := Get_Type_Info (R); return Lv2M (New_Selected_Element (M2Lv (R), Tinfo.T.Range_Length), Tinfo, @@ -8338,31 +8226,29 @@ package body Translation is return Bounds_To_Range (Get_Array_Bounds (Arr), Atype, Dim); end Get_Array_Range; - function Get_Array_Type_Length (Atype : Iir) return O_Enode + function Get_Bounds_Length (Bounds : Mnode; Atype : Iir) return O_Enode is - Index_List : Iir_List; - Nbr_Dim : Natural; + Type_Info : constant Type_Info_Acc := Get_Info (Atype); + Index_List : constant Iir_List := Get_Index_Subtype_List (Atype); + Nbr_Dim : constant Natural := Get_Nbr_Elements (Index_List); Dim_Length : O_Enode; Res : O_Enode; - Type_Info : Type_Info_Acc; - Bounds : Mnode; + Bounds_Stable : Mnode; begin - -- Handle non-complex array case. - Type_Info := Get_Info (Atype); if Type_Info.Type_Locally_Constrained then return New_Lit (Get_Thin_Array_Length (Atype)); end if; - -- FIXME: share code with get_array_length ??? - Index_List := Get_Index_Subtype_List (Atype); - Nbr_Dim := Get_Nbr_Elements (Index_List); - Bounds := Get_Array_Type_Bounds (Atype); if Nbr_Dim > 1 then - Bounds := Stabilize (Bounds); + Bounds_Stable := Stabilize (Bounds); + else + Bounds_Stable := Bounds; end if; + for Dim in 1 .. Nbr_Dim loop Dim_Length := - M2E (Range_To_Length (Bounds_To_Range (Bounds, Atype, Dim))); + M2E (Range_To_Length + (Bounds_To_Range (Bounds_Stable, Atype, Dim))); if Dim = 1 then Res := Dim_Length; else @@ -8370,65 +8256,28 @@ package body Translation is end if; end loop; return Res; - end Get_Array_Type_Length; + end Get_Bounds_Length; - function Get_Bounds_Ptr_Length (Ptr : O_Dnode; Atype : Iir) - return O_Enode + function Get_Array_Type_Length (Atype : Iir) return O_Enode is - Index_List : constant Iir_List := Get_Index_Subtype_List (Atype); - Nbr_Dim : constant Natural := Get_Nbr_Elements (Index_List); - Index_Type : Iir; - Dim_Length : O_Enode; - Res : O_Enode; - Type_Info : constant Type_Info_Acc := - Get_Info (Get_Base_Type (Atype)); - Index_Info : Type_Info_Acc; + Type_Info : constant Type_Info_Acc := Get_Info (Atype); begin - for Dim in 1 .. Nbr_Dim loop - Index_Type := Get_Index_Type (Index_List, Dim - 1); - Index_Info := Get_Info (Get_Base_Type (Index_Type)); - Dim_Length := New_Value - (New_Selected_Element - (New_Selected_Element (New_Acc_Value (New_Obj (Ptr)), - Type_Info.T.Bounds_Vector (Dim)), - Index_Info.T.Range_Length)); - if Dim = 1 then - Res := Dim_Length; - else - Res := New_Dyadic_Op (ON_Mul_Ov, Res, Dim_Length); - end if; - end loop; - return Res; - end Get_Bounds_Ptr_Length; + if Type_Info.Type_Locally_Constrained then + return New_Lit (Get_Thin_Array_Length (Atype)); + else + return Get_Bounds_Length (Get_Array_Type_Bounds (Atype), Atype); + end if; + end Get_Array_Type_Length; function Get_Array_Length (Arr : Mnode; Atype : Iir) return O_Enode is - Index_List : Iir_List; - Nbr_Dim : Natural; - Dim_Length : O_Enode; - Res : O_Enode; - Type_Info : Type_Info_Acc; - B : Mnode; + Type_Info : constant Type_Info_Acc := Get_Info (Atype); begin - -- Handle thin array case. - Type_Info := Get_Info (Atype); if Type_Info.Type_Locally_Constrained then return New_Lit (Get_Thin_Array_Length (Atype)); + else + return Get_Bounds_Length (Get_Array_Bounds (Arr), Atype); end if; - - Index_List := Get_Index_Subtype_List (Atype); - Nbr_Dim := Get_Nbr_Elements (Index_List); - for Dim in 1 .. Nbr_Dim loop - B := Get_Array_Bounds (Arr); - Dim_Length := - M2E (Range_To_Length (Bounds_To_Range (B, Atype, Dim))); - if Dim = 1 then - Res := Dim_Length; - else - Res := New_Dyadic_Op (ON_Mul_Ov, Res, Dim_Length); - end if; - end loop; - return Res; end Get_Array_Length; function Get_Array_Base (Arr : Mnode) return Mnode @@ -8518,103 +8367,15 @@ package body Translation is end if; end Slice_Base; - function Get_Array_Ptr_Base_Ptr - (Ptr : O_Lnode; Atype : Iir; Is_Sig : Object_Kind_Type) - return O_Lnode - is - Tinfo : Type_Info_Acc; - begin - Tinfo := Get_Info (Atype); - case Tinfo.Type_Mode is - when Type_Mode_Fat_Array => - return New_Selected_Element - (New_Access_Element (New_Value (Ptr)), - Tinfo.T.Base_Field (Is_Sig)); - when Type_Mode_Array => - return Ptr; - when others => - raise Internal_Error; - end case; - end Get_Array_Ptr_Base_Ptr; - - function Get_Array_Ptr_Range_Ptr (Ptr : O_Lnode; - Array_Type : Iir; - Dim : Natural; - Is_Sig : Object_Kind_Type) - return O_Enode - is - Array_Info : constant Type_Info_Acc := Get_Info (Array_Type); - Index_Type : constant Iir := Get_Index_Type (Array_Type, Dim - 1); - Index_Info : constant Type_Info_Acc := - Get_Info (Get_Base_Type (Index_Type)); - Res : O_Lnode; - begin - case Array_Info.Type_Mode is - when Type_Mode_Array => - -- Extract bound variable. - Res := Get_Var (Array_Info.T.Array_Bounds); - when Type_Mode_Fat_Array => - -- From fat record, extract bounds field. - Res := New_Acc_Value - (New_Selected_Acc_Value - (Ptr, Array_Info.T.Bounds_Field (Is_Sig))); - when others => - raise Internal_Error; - end case; - -- Extract the range for the dimension. - Res := New_Selected_Element (Res, Array_Info.T.Bounds_Vector (Dim)); - return New_Address (Res, Index_Info.T.Range_Ptr_Type); - end Get_Array_Ptr_Range_Ptr; - - function Get_Array_Ptr_Bounds_Ptr - (Ptr : O_Lnode; Atype : Iir; Is_Sig : Object_Kind_Type) - return O_Enode - is - Info : Type_Info_Acc; - begin - Info := Get_Info (Atype); - case Info.Type_Mode is - when Type_Mode_Fat_Array => - return New_Value - (New_Selected_Element (New_Acc_Value (Ptr), - Info.T.Bounds_Field (Is_Sig))); - when Type_Mode_Array => - return New_Address (Get_Var (Info.T.Array_Bounds), - Info.T.Bounds_Ptr_Type); - when others => - raise Internal_Error; - end case; - end Get_Array_Ptr_Bounds_Ptr; - - function Get_Array_Bounds_Ptr - (Arr : O_Lnode; Arr_Type : Iir; Is_Sig : Object_Kind_Type) - return O_Enode - is - Type_Info : Type_Info_Acc; - begin - Type_Info := Get_Info (Arr_Type); - case Type_Info.Type_Mode is - when Type_Mode_Fat_Array => - return New_Value (New_Selected_Element - (Arr, Type_Info.T.Bounds_Field (Is_Sig))); - when Type_Mode_Array => - return New_Address (Get_Var (Type_Info.T.Array_Bounds), - Type_Info.T.Bounds_Ptr_Type); - when others => - -- Not an array! - raise Internal_Error; - end case; - end Get_Array_Bounds_Ptr; - procedure Allocate_Fat_Array_Base (Alloc_Kind : Allocation_Kind; Res : Mnode; Arr_Type : Iir) is - Dinfo : Type_Info_Acc; - Length : O_Enode; + Dinfo : constant Type_Info_Acc := + Get_Info (Get_Base_Type (Arr_Type)); Kind : constant Object_Kind_Type := Get_Object_Kind (Res); + Length : O_Enode; begin - Dinfo := Get_Info (Get_Base_Type (Arr_Type)); -- Compute array size. Length := Get_Object_Size (Res, Arr_Type); -- Allocate the storage for the elements. @@ -8668,16 +8429,8 @@ package body Translation is New_Assign_Stmt (M2Lv (Dest), Src); when Type_Mode_Fat_Acc => -- a fat pointer. - declare - Var_S : O_Dnode; - Var_D : O_Dnode; - begin - Var_S := Create_Temp_Init (Info.Ortho_Ptr_Type (Kind), - Src); - Var_D := Create_Temp_Init (Info.Ortho_Ptr_Type (Kind), - M2Addr (Dest)); - Copy_Fat_Access (Var_D, Var_S, Get_Base_Type (Obj_Type)); - end; + D := Stabilize (Dest); + Copy_Fat_Pointer (D, Stabilize (E2M (Src, Info, Kind))); when Type_Mode_Fat_Array => -- a fat array. D := Stabilize (Dest); @@ -8744,13 +8497,11 @@ package body Translation is (Res : in out Mnode; Alloc_Kind : Allocation_Kind; Obj_Type : Iir; - Bounds : O_Enode) + Bounds : Mnode) is - Dinfo : Type_Info_Acc; - Kind : Object_Kind_Type; + Dinfo : constant Type_Info_Acc := Get_Info (Obj_Type); + Kind : constant Object_Kind_Type := Get_Object_Kind (Res); begin - Dinfo := Get_Info (Obj_Type); - Kind := Get_Object_Kind (Res); if Dinfo.Type_Mode = Type_Mode_Fat_Array then -- Allocate memory for bounds. New_Assign_Stmt @@ -8763,7 +8514,7 @@ package body Translation is -- Copy bounds to the allocated area. Gen_Memcpy (M2Addr (Chap3.Get_Array_Bounds (Res)), - Bounds, + M2Addr (Bounds), New_Lit (New_Sizeof (Dinfo.T.Bounds_Type, Ghdl_Index_Type))); -- Allocate base. @@ -9012,6 +8763,26 @@ package body Translation is end if; end Maybe_Insert_Scalar_Check; + function Locally_Array_Match (L_Type, R_Type : Iir) return Boolean + is + L_Indexes : constant Iir_List := Get_Index_Subtype_List (L_Type); + R_Indexes : constant Iir_List := Get_Index_Subtype_List (R_Type); + L_El : Iir; + R_El : Iir; + begin + for I in Natural loop + L_El := Get_Index_Type (L_Indexes, I); + R_El := Get_Index_Type (R_Indexes, I); + exit when L_El = Null_Iir and R_El = Null_Iir; + if Eval_Discrete_Type_Length (L_El) + /= Eval_Discrete_Type_Length (R_El) + then + return False; + end if; + end loop; + return True; + end Locally_Array_Match; + procedure Check_Array_Match (L_Type : Iir; L_Node : Mnode; R_Type : Iir; @@ -9030,30 +8801,9 @@ package body Translation is then -- Both left and right are thin array. -- Check here the length are the same. - declare - L_Indexes : Iir_List; - R_Indexes : Iir_List; - L_El : Iir; - R_El : Iir; - Err : Boolean; - begin - L_Indexes := Get_Index_Subtype_List (L_Type); - R_Indexes := Get_Index_Subtype_List (R_Type); - Err := False; - for I in Natural loop - L_El := Get_Index_Type (L_Indexes, I); - R_El := Get_Index_Type (R_Indexes, I); - exit when L_El = Null_Iir and R_El = Null_Iir; - if Eval_Discrete_Type_Length (L_El) - /= Eval_Discrete_Type_Length (R_El) - then - if not Err then - Chap6.Gen_Bound_Error (Loc); - Err := True; - end if; - end if; - end loop; - end; + if not Locally_Array_Match (L_Type, R_Type) then + Chap6.Gen_Bound_Error (Loc); + end if; else -- Check length match. declare @@ -9702,10 +9452,8 @@ package body Translation is Chap3.Create_Array_Subtype (Aggr_Type, True); Name_Node := Stabilize (Name); New_Assign_Stmt - (New_Selected_Element - (M2Lv (Name_Node), Type_Info.T.Bounds_Field (Mode_Value)), - Chap3.Get_Array_Ptr_Bounds_Ptr (O_Lnode_Null, Aggr_Type, - Mode_Value)); + (M2Lp (Chap3.Get_Array_Bounds (Name_Node)), + M2Addr (Chap3.Get_Array_Type_Bounds (Aggr_Type))); Chap3.Allocate_Fat_Array_Base (Alloc_Kind, Name_Node, Get_Base_Type (Aggr_Type)); end; @@ -9718,26 +9466,22 @@ package body Translation is if Type_Info.Type_Mode = Type_Mode_Fat_Array then declare - S : O_Dnode; + S : Mnode; begin Name_Node := Stabilize (Name); - S := Create_Temp_Init - (Type_Info.Ortho_Ptr_Type (Mode_Value), Value_Node); + S := Stabilize (E2M (Value_Node, Type_Info, Mode_Value)); if Get_Kind (Value) = Iir_Kind_String_Literal and then Get_Kind (Obj) = Iir_Kind_Constant_Declaration then -- No need to allocate space for the object. - Copy_Fat_Pointer (Name_Node, - Dp2M (S, Type_Info, Mode_Value)); + Copy_Fat_Pointer (Name_Node, S); else Chap3.Translate_Object_Allocation (Name_Node, Alloc_Kind, Obj_Type, - Chap3.Get_Array_Ptr_Bounds_Ptr (New_Obj (S), - Get_Type (Value), - Mode_Value)); + Chap3.Get_Array_Bounds (S)); Chap3.Translate_Object_Copy - (Name_Node, New_Obj_Value (S), Obj_Type); + (Name_Node, M2Addr (S), Obj_Type); end if; end; else @@ -12497,7 +12241,7 @@ package body Translation is Obj_Info : Object_Info_Acc; Obj_Type : Iir; Type_Info : Type_Info_Acc; - Bounds : O_Enode; + Bounds : Mnode; begin Formal_Type := Get_Type (Formal); Chap3.Elab_Object_Subtype (Formal_Type); @@ -12512,7 +12256,7 @@ package body Translation is (Formal_Type, Alloc_System, Formal_Node); else Chap3.Create_Array_Subtype (Obj_Type, False); - Bounds := M2E (Chap3.Get_Array_Type_Bounds (Obj_Type)); + Bounds := Chap3.Get_Array_Type_Bounds (Obj_Type); Chap3.Translate_Object_Allocation (Formal_Node, Alloc_System, Formal_Type, Bounds); end if; @@ -12641,78 +12385,25 @@ package body Translation is end Chap5; package body Chap6 is - -- Extract from fat array FAT_ARRAY the range corresponding to dimension - -- DIM. - function Fat_Array_To_Range (Fat_Array : O_Lnode; - Array_Type : Iir; - Dim : Natural; - Is_Sig : Object_Kind_Type) - return O_Lnode - is - Lval : O_Lnode; - Array_Info : Type_Info_Acc; - begin - Array_Info := Get_Info (Array_Type); - case Array_Info.Type_Mode is - when Type_Mode_Fat_Array => - -- From fat record, extract bounds field. - Lval := New_Selected_Element - (Fat_Array, Array_Info.T.Bounds_Field (Is_Sig)); - -- Dereference it. - Lval := New_Access_Element (New_Value (Lval)); - when Type_Mode_Array => - Lval := Get_Var (Array_Info.T.Array_Bounds); - when others => - raise Internal_Error; - end case; - -- Extract the range for the dimension. - return New_Selected_Element (Lval, Array_Info.T.Bounds_Vector (Dim)); - end Fat_Array_To_Range; - - function Get_Array_Bound_Length (Arr : O_Lnode; + function Get_Array_Bound_Length (Arr : Mnode; Arr_Type : Iir; - Dim : Natural; - Is_Sig : Object_Kind_Type) - return O_Enode + Dim : Natural) + return O_Enode is Index_Type : constant Iir := Get_Index_Type (Arr_Type, Dim - 1); Tinfo : constant Type_Info_Acc := Get_Info (Arr_Type); - Rinfo : Type_Info_Acc; Constraint : Iir; begin if Tinfo.Type_Locally_Constrained then Constraint := Get_Range_Constraint (Index_Type); return New_Lit (Chap7.Translate_Static_Range_Length (Constraint)); else - Rinfo := Get_Info (Get_Base_Type (Index_Type)); - return New_Value - (New_Selected_Element - (Fat_Array_To_Range (Arr, Arr_Type, Dim, Is_Sig), - Rinfo.T.Range_Length)); + return M2E + (Chap3.Range_To_Length + (Chap3.Get_Array_Range (Arr, Arr_Type, Dim))); end if; end Get_Array_Bound_Length; - function Get_Array_Ptr_Bound_Length (Ptr : O_Lnode; - Arr_Type : Iir; - Dim : Natural; - Is_Sig : Object_Kind_Type) - return O_Enode - is - Tinfo : Type_Info_Acc; - begin - Tinfo := Get_Info (Arr_Type); - case Tinfo.Type_Mode is - when Type_Mode_Fat_Array => - return Get_Array_Bound_Length - (New_Acc_Value (Ptr), Arr_Type, Dim, Is_Sig); - when Type_Mode_Array => - return Get_Array_Bound_Length - (O_Lnode_Null, Arr_Type, Dim, Is_Sig); - when others => - raise Internal_Error; - end case; - end Get_Array_Ptr_Bound_Length; - procedure Gen_Bound_Error (Loc : Iir) is Constr : O_Assoc_List; @@ -14146,17 +13837,17 @@ package body Translation is function Translate_String_Literal (Str : Iir) return O_Enode is + Str_Type : constant Iir := Get_Type (Str); Var : Var_Acc; Info : Type_Info_Acc; - Str_Type : Iir; Res : O_Cnode; R : O_Enode; begin - Str_Type := Get_Type (Str); if Get_Constraint_State (Str_Type) = Fully_Constrained and then Get_Type_Staticness (Get_Index_Type (Str_Type, 0)) = Locally then + Chap3.Create_Array_Subtype (Str_Type, True); case Get_Kind (Str) is when Iir_Kind_String_Literal => Res := Translate_Static_String_Literal (Str); @@ -14170,7 +13861,6 @@ package body Translation is when others => raise Internal_Error; end case; - Str_Type := Get_Type (Str); Info := Get_Info (Str_Type); Var := Create_Global_Const (Create_Uniq_Identifier, Info.Ortho_Type (Mode_Value), @@ -14605,62 +14295,53 @@ package body Translation is end Translate_Operator_Function_Call; function Convert_Constrained_To_Unconstrained - (Expr : O_Enode; Expr_Type : Iir; Atype : Iir; Kind : Object_Kind_Type) - return O_Enode + (Expr : Mnode; Res_Type : Iir) + return Mnode is - Res : O_Dnode; - Type_Info : Type_Info_Acc; + Type_Info : constant Type_Info_Acc := Get_Info (Res_Type); + Kind : constant Object_Kind_Type := Get_Object_Kind (Expr); + Stable_Expr : Mnode; + Res : Mnode; begin - -- FIXME: to do. - -- Be sure the bounds variable was created. - -- This may be necessary for on-the-fly types, such as strings. - Chap3.Create_Array_Subtype (Expr_Type, True); - - Type_Info := Get_Info (Atype); - Res := Create_Temp (Type_Info.Ortho_Type (Kind)); + Res := Create_Temp (Type_Info, Kind); + Stable_Expr := Stabilize (Expr); New_Assign_Stmt - (New_Selected_Element (New_Obj (Res), - Type_Info.T.Base_Field (Kind)), - New_Convert_Ov (Expr, Type_Info.T.Base_Ptr_Type (Kind))); - + (M2Lp (Chap3.Get_Array_Base (Res)), + New_Convert_Ov (M2Addr (Chap3.Get_Array_Base (Stable_Expr)), + Type_Info.T.Base_Ptr_Type (Kind))); New_Assign_Stmt - (New_Selected_Element (New_Obj (Res), - Type_Info.T.Bounds_Field (Kind)), - Chap3.Get_Array_Ptr_Bounds_Ptr (O_Lnode_Null, Expr_Type, Kind)); - return L2e_Node (New_Obj (Res), Type_Info, Kind); + (M2Lp (Chap3.Get_Array_Bounds (Res)), + M2Addr (Chap3.Get_Array_Bounds (Stable_Expr))); + return Res; end Convert_Constrained_To_Unconstrained; - function Convert_Array_To_Thin_Array - (Expr : O_Enode; - Expr_Type : Iir; - Atype : Iir; - Is_Sig : Object_Kind_Type; - Loc : Iir) - return O_Enode + function Convert_Array_To_Thin_Array (Expr : Mnode; + Expr_Type : Iir; + Atype : Iir; + Loc : Iir) + return Mnode is - Ptr : O_Dnode; - Expr_Type_Info : Type_Info_Acc; - Expr_Indexes: Iir_List; + Expr_Indexes : constant Iir_List := + Get_Index_Subtype_List (Expr_Type); + Expr_Stable : Mnode; Success_Label, Failure_Label : O_Snode; begin - Expr_Type_Info := Get_Info (Expr_Type); - Ptr := Create_Temp_Init - (Expr_Type_Info.Ortho_Ptr_Type (Is_Sig), Expr); + Expr_Stable := Stabilize (Expr); Open_Temp; -- Check each dimension. - Expr_Indexes := Get_Index_Subtype_List (Expr_Type); Start_Loop_Stmt (Success_Label); Start_Loop_Stmt (Failure_Label); for I in 1 .. Get_Nbr_Elements (Expr_Indexes) loop Gen_Exit_When (Failure_Label, New_Compare_Op - (ON_Neq, - Chap6.Get_Array_Ptr_Bound_Length (New_Obj (Ptr), - Expr_Type, I, Is_Sig), - Chap6.Get_Array_Bound_Length (O_Lnode_Null, Atype, I, Is_Sig), - Ghdl_Bool_Type)); + (ON_Neq, + Chap6.Get_Array_Bound_Length + (Expr_Stable, Expr_Type, I), + Chap6.Get_Array_Bound_Length + (T2M (Atype, Get_Object_Kind (Expr_Stable)), Atype, I), + Ghdl_Bool_Type)); end loop; New_Exit_Stmt (Success_Label); Finish_Loop_Stmt (Failure_Label); @@ -14668,84 +14349,84 @@ package body Translation is Finish_Loop_Stmt (Success_Label); Close_Temp; - return New_Value - (Chap3.Get_Array_Ptr_Base_Ptr (New_Obj (Ptr), Expr_Type, Is_Sig)); + return Chap3.Get_Array_Base (Expr_Stable); end Convert_Array_To_Thin_Array; + function Translate_Implicit_Array_Conversion + (Expr : Mnode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir) + return Mnode + is + Ainfo : Type_Info_Acc; + Einfo : Type_Info_Acc; + begin + pragma Assert + (Get_Kind (Expr_Type) in Iir_Kinds_Array_Type_Definition); + + if Res_Type = Expr_Type then + return Expr; + end if; + + Ainfo := Get_Info (Res_Type); + Einfo := Get_Info (Expr_Type); + case Ainfo.Type_Mode is + when Type_Mode_Fat_Array => + -- X to unconstrained. + case Einfo.Type_Mode is + when Type_Mode_Fat_Array => + -- unconstrained to unconstrained. + return Expr; + when Type_Mode_Array => + -- constrained to unconstrained. + return Convert_Constrained_To_Unconstrained + (Expr, Res_Type); + when others => + raise Internal_Error; + end case; + when Type_Mode_Array => + -- X to constrained. + if Einfo.Type_Locally_Constrained + and then Ainfo.Type_Locally_Constrained + then + -- FIXME: optimize static vs non-static + -- constrained to constrained. + if not Chap3.Locally_Array_Match (Expr_Type, Res_Type) then + -- FIXME: generate a bound error ? + -- Even if this is caught at compile-time, + -- the code is not required to run. + Chap6.Gen_Bound_Error (Loc); + end if; + return Expr; + else + -- Unbounded/bounded array to bounded array. + return Convert_Array_To_Thin_Array + (Expr, Expr_Type, Res_Type, Loc); + end if; + when others => + raise Internal_Error; + end case; + end Translate_Implicit_Array_Conversion; + -- Convert (if necessary) EXPR translated from EXPR_ORIG to type ATYPE. function Translate_Implicit_Conv (Expr : O_Enode; Expr_Type : Iir; Atype : Iir; Is_Sig : Object_Kind_Type; Loc : Iir) - return O_Enode - is - Ainfo : Type_Info_Acc; - Einfo : Type_Info_Acc; + return O_Enode is begin + -- Same type: nothing to do. if Atype = Expr_Type then return Expr; end if; + if Expr_Type = Universal_Integer_Type_Definition then return New_Convert_Ov (Expr, Get_Ortho_Type (Atype, Mode_Value)); elsif Expr_Type = Universal_Real_Type_Definition then return New_Convert_Ov (Expr, Get_Ortho_Type (Atype, Mode_Value)); elsif Get_Kind (Expr_Type) in Iir_Kinds_Array_Type_Definition then - Ainfo := Get_Info (Atype); - Einfo := Get_Info (Expr_Type); - case Ainfo.Type_Mode is - when Type_Mode_Fat_Array => - -- X to unconstrained. - case Einfo.Type_Mode is - when Type_Mode_Fat_Array => - -- unconstrained to unconstrained. - return Expr; - when Type_Mode_Array => - -- constrained to unconstrained. - return Convert_Constrained_To_Unconstrained - (Expr, Expr_Type, Atype, Is_Sig); - when others => - raise Internal_Error; - end case; - when Type_Mode_Array => - -- X to constrained. - if Einfo.Type_Locally_Constrained - and then Ainfo.Type_Locally_Constrained - then - -- FIXME: optimize static vs non-static - -- constrained to constrained. - -- FIXME: share with check_array_match ? - declare - E_List : constant Iir_List := - Get_Index_Subtype_List (Expr_Type); - A_List : constant Iir_List := - Get_Index_Subtype_List (Atype); - E_El, A_El : Iir; - begin - for I in Natural loop - E_El := Get_Index_Type (E_List, I); - A_El := Get_Index_Type (A_List, I); - exit when E_El = Null_Iir - and then A_El = Null_Iir; - if Eval_Discrete_Type_Length (E_El) - /= Eval_Discrete_Type_Length (A_El) - then - -- FIXME: generate a bound error ? - -- Even if this is caught at compile-time, - -- the code is not required to run. - Chap6.Gen_Bound_Error (Loc); - end if; - end loop; - end; - return Expr; - else - -- unconstrained to constrained. - return Convert_Array_To_Thin_Array - (Expr, Expr_Type, Atype, Is_Sig, Loc); - end if; - when others => - raise Internal_Error; - end case; + return M2E (Translate_Implicit_Array_Conversion + (E2M (Expr, Get_Info (Expr_Type), Is_Sig), + Expr_Type, Atype, Loc)); else return Expr; end if; @@ -14893,10 +14574,9 @@ package body Translation is (Left, Right : O_Enode; Func : Iir_Implicit_Function_Declaration) return O_Enode is - Info : Subprg_Info_Acc; + Info : constant Subprg_Info_Acc := Get_Info (Func); Constr : O_Assoc_List; begin - Info := Get_Info (Func); Start_Association (Constr, Info.Ortho_Func); Chap2.Add_Subprg_Instance_Assoc (Constr, Info.Subprg_Instance); New_Association (Constr, Left); @@ -15045,6 +14725,71 @@ package body Translation is return New_Obj_Value (Res); end Translate_Scalar_Min_Max; + function Translate_Predefined_Vector_Min_Max (Is_Min : Boolean; + Left : Iir; + Res_Type : Iir) + return O_Enode + is + Res_Otype : constant O_Tnode := + Get_Ortho_Type (Res_Type, Mode_Value); + Left_Type : constant Iir := Get_Type (Left); + Res, El, Len : O_Dnode; + Arr : Mnode; + If_Blk : O_If_Block; + Label : O_Snode; + Op : ON_Op_Kind; + begin + -- Create a variable for the result. + Res := Create_Temp (Res_Otype); + + Open_Temp; + if Is_Min then + Op := ON_Lt; + else + Op := ON_Gt; + end if; + New_Assign_Stmt + (New_Obj (Res), + Chap14.Translate_High_Low_Type_Attribute (Res_Type, Is_Min)); + + El := Create_Temp (Res_Otype); + Arr := Stabilize (E2M (Translate_Expression (Left), + Get_Info (Left_Type), Mode_Value)); + Len := Create_Temp_Init + (Ghdl_Index_Type, + M2E (Chap3.Range_To_Length + (Chap3.Get_Array_Range (Arr, Left_Type, 1)))); + + -- Create: + -- loop + -- exit when LEN = 0; + -- LEN := LEN - 1; + -- if ARR[LEN] </> RES then + -- RES := ARR[LEN]; + -- end if; + -- end loop; + Start_Loop_Stmt (Label); + Gen_Exit_When (Label, New_Compare_Op (ON_Eq, New_Obj_Value (Len), + New_Lit (Ghdl_Index_0), + Ghdl_Bool_Type)); + Dec_Var (Len); + New_Assign_Stmt + (New_Obj (El), + M2E (Chap3.Index_Base (Chap3.Get_Array_Base (Arr), + Left_Type, New_Obj_Value (Len)))); + Start_If_Stmt (If_Blk, New_Compare_Op (Op, + New_Obj_Value (El), + New_Obj_Value (Res), + Ghdl_Bool_Type)); + New_Assign_Stmt (New_Obj (Res), New_Obj_Value (El)); + Finish_If_Stmt (If_Blk); + Finish_Loop_Stmt (Label); + + Close_Temp; + + return New_Obj_Value (Res); + end Translate_Predefined_Vector_Min_Max; + function Translate_Std_Ulogic_Match (Func : O_Dnode; L, R : O_Enode; Res_Type : O_Tnode) @@ -15058,10 +14803,15 @@ package body Translation is return New_Convert_Ov (New_Function_Call (Constr), Res_Type); end Translate_Std_Ulogic_Match; - function Translate_To_String - (Subprg : O_Dnode; Val : O_Enode; Arg2 : O_Enode) - return O_Enode + function Translate_To_String (Subprg : O_Dnode; + Res_Type : Iir; + Loc : Iir; + Val : O_Enode; + Arg2 : O_Enode := O_Enode_Null; + Arg3 : O_Enode := O_Enode_Null) + return O_Enode is + Val_Type : constant Iir := Get_Base_Type (Res_Type); Res : O_Dnode; Assoc : O_Assoc_List; begin @@ -15073,22 +14823,28 @@ package body Translation is New_Association (Assoc, Val); if Arg2 /= O_Enode_Null then New_Association (Assoc, Arg2); + if Arg3 /= O_Enode_Null then + New_Association (Assoc, Arg3); + end if; end if; - --New_Association - --(Assoc, New_Lit (Rtis.New_Rti_Address (Pinfo.Type_Rti))); New_Procedure_Call (Assoc); - return New_Address (New_Obj (Res), Std_String_Ptr_Node); + return M2E (Translate_Implicit_Array_Conversion + (Dv2M (Res, Get_Info (Val_Type), Mode_Value), + Val_Type, Res_Type, Loc)); end Translate_To_String; - function Translate_Bv_To_String - (Subprg : O_Dnode; Val : O_Enode; Val_Type : Iir) - return O_Enode + function Translate_Bv_To_String (Subprg : O_Dnode; + Val : O_Enode; + Val_Type : Iir; + Res_Type : Iir; + Loc : Iir) + return O_Enode is Arr : Mnode; begin Arr := Stabilize (E2M (Val, Get_Info (Val_Type), Mode_Value)); return Translate_To_String - (Subprg, + (Subprg, Res_Type, Loc, M2E (Chap3.Get_Array_Base (Arr)), M2E (Chap3.Range_To_Length (Chap3.Get_Array_Range (Arr, Val_Type, 1)))); @@ -15123,11 +14879,13 @@ package body Translation is function Translate_Predefined_TF_Array_Element (Op : Predefined_Boolean_Logical; Left, Right : Iir; - Res_Type : Iir) + Res_Type : Iir; + Loc : Iir) return O_Enode is Arr_Type : constant Iir := Get_Type (Left); - Res_Info : constant Type_Info_Acc := Get_Info (Res_Type); + Res_Btype : constant Iir := Get_Base_Type (Res_Type); + Res_Info : constant Type_Info_Acc := Get_Info (Res_Btype); Base_Ptr_Type : constant O_Tnode := Res_Info.T.Base_Ptr_Type (Mode_Value); Arr : Mnode; @@ -15184,11 +14942,12 @@ package body Translation is New_Assign_Stmt (M2Lp (Chap3.Get_Array_Bounds (Res)), M2Addr (Chap3.Get_Array_Bounds (Arr))); - return M2E (Res); + return Translate_Implicit_Conv (M2E (Res), Res_Btype, Res_Type, + Mode_Value, Loc); end Translate_Predefined_TF_Array_Element; function Translate_Predefined_TF_Reduction - (Op : Predefined_Boolean_Logical; Operand : Iir; Res_Type : Iir) + (Op : ON_Op_Kind; Operand : Iir; Res_Type : Iir) return O_Enode is Arr_Type : constant Iir := Get_Type (Operand); @@ -15202,16 +14961,11 @@ package body Translation is Len : O_Dnode; Label : O_Snode; begin - case Op is - when Iir_Predefined_Boolean_And - | Iir_Predefined_Boolean_Nand => - Init_Enum := Get_Nth_Element (Enums, 1); - when Iir_Predefined_Boolean_Or - | Iir_Predefined_Boolean_Nor - | Iir_Predefined_Boolean_Xor - | Iir_Predefined_Boolean_Xnor => - Init_Enum := Get_Nth_Element (Enums, 0); - end case; + if Op = ON_And then + Init_Enum := Get_Nth_Element (Enums, 1); + else + Init_Enum := Get_Nth_Element (Enums, 0); + end if; Res := Create_Temp_Init (Get_Ortho_Type (Res_Type, Mode_Value), New_Lit (Get_Ortho_Expr (Init_Enum))); @@ -15242,7 +14996,7 @@ package body Translation is Dec_Var (Len); New_Assign_Stmt (New_Obj (Res), - Translate_Predefined_Logical + New_Dyadic_Op (Op, New_Obj_Value (Res), M2E (Chap3.Index_Base (Chap3.Get_Array_Base (Arr), @@ -15253,6 +15007,123 @@ package body Translation is return New_Obj_Value (Res); end Translate_Predefined_TF_Reduction; + function Translate_Predefined_Array_Min_Max + (Is_Min : Boolean; + Left, Right : O_Enode; + Left_Type, Right_Type : Iir; + Res_Type : Iir; + Imp : Iir; + Loc : Iir) + return O_Enode + is + Arr_Type : constant Iir := Get_Base_Type (Left_Type); + Arr_Info : constant Type_Info_Acc := Get_Info (Arr_Type); + L, R : Mnode; + If_Blk : O_If_Block; + Res : Mnode; + begin + Res := Create_Temp (Arr_Info, Mode_Value); + L := Stabilize (E2M (Left, Get_Info (Left_Type), Mode_Value)); + R := Stabilize (E2M (Right, Get_Info (Right_Type), Mode_Value)); + Start_If_Stmt + (If_Blk, + New_Compare_Op + (ON_Eq, + Translate_Predefined_Lib_Operator (M2E (L), M2E (R), Imp), + New_Lit (Ghdl_Compare_Lt), + Std_Boolean_Type_Node)); + if Is_Min then + Copy_Fat_Pointer (Res, Translate_Implicit_Array_Conversion + (L, Left_Type, Arr_Type, Loc)); + else + Copy_Fat_Pointer (Res, Translate_Implicit_Array_Conversion + (R, Right_Type, Arr_Type, Loc)); + end if; + New_Else_Stmt (If_Blk); + if Is_Min then + Copy_Fat_Pointer (Res, Translate_Implicit_Array_Conversion + (R, Right_Type, Arr_Type, Loc)); + else + Copy_Fat_Pointer (Res, Translate_Implicit_Array_Conversion + (L, Left_Type, Arr_Type, Loc)); + end if; + Finish_If_Stmt (If_Blk); + + return M2E (Translate_Implicit_Array_Conversion + (Res, Arr_Type, Res_Type, Loc)); + end Translate_Predefined_Array_Min_Max; + + function Translate_Predefined_TF_Edge + (Is_Rising : Boolean; Left : Iir) + return O_Enode + is + Enums : constant Iir_List := + Get_Enumeration_Literal_List (Get_Base_Type (Get_Type (Left))); + Name : Mnode; + begin + Name := Stabilize (Chap6.Translate_Name (Left), True); + return New_Dyadic_Op + (ON_And, + New_Value (Chap14.Get_Signal_Field + (Name, Ghdl_Signal_Event_Field)), + New_Compare_Op + (ON_Eq, + New_Value (New_Access_Element (M2E (Name))), + New_Lit (Get_Ortho_Expr + (Get_Nth_Element (Enums, Boolean'Pos (Is_Rising)))), + Std_Boolean_Type_Node)); + end Translate_Predefined_TF_Edge; + + function Translate_Predefined_Std_Ulogic_Array_Match + (Subprg : O_Dnode; Left, Right : Iir; Res_Type : Iir) + return O_Enode + is + Res_Otype : constant O_Tnode := + Get_Ortho_Type (Res_Type, Mode_Value); + L_Type : constant Iir := Get_Type (Left); + R_Type : constant Iir := Get_Type (Right); + L_Expr, R_Expr : O_Enode; + L, R : Mnode; + Assoc : O_Assoc_List; + + Res : O_Dnode; + begin + Res := Create_Temp (Ghdl_I32_Type); + + Open_Temp; + -- Translate the arrays. Note that Translate_Expression may create + -- the info for the array type, so be sure to call it before calling + -- Get_Info. + L_Expr := Translate_Expression (Left); + L := Stabilize (E2M (L_Expr, Get_Info (L_Type), Mode_Value)); + + R_Expr := Translate_Expression (Right); + R := Stabilize (E2M (R_Expr, Get_Info (R_Type), Mode_Value)); + + Start_Association (Assoc, Subprg); + New_Association + (Assoc, + New_Convert_Ov (M2E (Chap3.Get_Array_Base (L)), Ghdl_Ptr_Type)); + New_Association + (Assoc, + M2E (Chap3.Range_To_Length + (Chap3.Get_Array_Range (L, L_Type, 1)))); + + New_Association + (Assoc, + New_Convert_Ov (M2E (Chap3.Get_Array_Base (R)), Ghdl_Ptr_Type)); + New_Association + (Assoc, + M2E (Chap3.Range_To_Length + (Chap3.Get_Array_Range (R, R_Type, 1)))); + + New_Assign_Stmt (New_Obj (Res), New_Function_Call (Assoc)); + + Close_Temp; + + return New_Convert_Ov (New_Obj_Value (Res), Res_Otype); + end Translate_Predefined_Std_Ulogic_Array_Match; + function Translate_Predefined_Operator (Imp : Iir_Implicit_Function_Declaration; Left, Right : Iir; @@ -15300,61 +15171,85 @@ package body Translation is -- same for the result. when Iir_Predefined_TF_Array_Element_And => return Translate_Predefined_TF_Array_Element - (Iir_Predefined_Boolean_And, Left, Right, Res_Type); + (Iir_Predefined_Boolean_And, Left, Right, Res_Type, Loc); when Iir_Predefined_TF_Element_Array_And => return Translate_Predefined_TF_Array_Element - (Iir_Predefined_Boolean_And, Right, Left, Res_Type); + (Iir_Predefined_Boolean_And, Right, Left, Res_Type, Loc); when Iir_Predefined_TF_Array_Element_Or => return Translate_Predefined_TF_Array_Element - (Iir_Predefined_Boolean_Or, Left, Right, Res_Type); + (Iir_Predefined_Boolean_Or, Left, Right, Res_Type, Loc); when Iir_Predefined_TF_Element_Array_Or => return Translate_Predefined_TF_Array_Element - (Iir_Predefined_Boolean_Or, Right, Left, Res_Type); + (Iir_Predefined_Boolean_Or, Right, Left, Res_Type, Loc); when Iir_Predefined_TF_Array_Element_Nand => return Translate_Predefined_TF_Array_Element - (Iir_Predefined_Boolean_Nand, Left, Right, Res_Type); + (Iir_Predefined_Boolean_Nand, Left, Right, Res_Type, Loc); when Iir_Predefined_TF_Element_Array_Nand => return Translate_Predefined_TF_Array_Element - (Iir_Predefined_Boolean_Nand, Right, Left, Res_Type); + (Iir_Predefined_Boolean_Nand, Right, Left, Res_Type, Loc); when Iir_Predefined_TF_Array_Element_Nor => return Translate_Predefined_TF_Array_Element - (Iir_Predefined_Boolean_Nor, Left, Right, Res_Type); + (Iir_Predefined_Boolean_Nor, Left, Right, Res_Type, Loc); when Iir_Predefined_TF_Element_Array_Nor => return Translate_Predefined_TF_Array_Element - (Iir_Predefined_Boolean_Nor, Right, Left, Res_Type); + (Iir_Predefined_Boolean_Nor, Right, Left, Res_Type, Loc); when Iir_Predefined_TF_Array_Element_Xor => return Translate_Predefined_TF_Array_Element - (Iir_Predefined_Boolean_Xor, Left, Right, Res_Type); + (Iir_Predefined_Boolean_Xor, Left, Right, Res_Type, Loc); when Iir_Predefined_TF_Element_Array_Xor => return Translate_Predefined_TF_Array_Element - (Iir_Predefined_Boolean_Xor, Right, Left, Res_Type); + (Iir_Predefined_Boolean_Xor, Right, Left, Res_Type, Loc); when Iir_Predefined_TF_Array_Element_Xnor => return Translate_Predefined_TF_Array_Element - (Iir_Predefined_Boolean_Xnor, Left, Right, Res_Type); + (Iir_Predefined_Boolean_Xnor, Left, Right, Res_Type, Loc); when Iir_Predefined_TF_Element_Array_Xnor => return Translate_Predefined_TF_Array_Element - (Iir_Predefined_Boolean_Xnor, Right, Left, Res_Type); + (Iir_Predefined_Boolean_Xnor, Right, Left, Res_Type, Loc); -- Avoid implicit conversion of the array parameters to the -- unbounded type for optimizing purpose. when Iir_Predefined_TF_Reduction_And => return Translate_Predefined_TF_Reduction - (Iir_Predefined_Boolean_And, Left, Res_Type); + (ON_And, Left, Res_Type); when Iir_Predefined_TF_Reduction_Or => return Translate_Predefined_TF_Reduction - (Iir_Predefined_Boolean_Or, Left, Res_Type); + (ON_Or, Left, Res_Type); when Iir_Predefined_TF_Reduction_Nand => - return Translate_Predefined_TF_Reduction - (Iir_Predefined_Boolean_Nand, Left, Res_Type); + return New_Monadic_Op + (ON_Not, + Translate_Predefined_TF_Reduction (ON_And, Left, Res_Type)); when Iir_Predefined_TF_Reduction_Nor => - return Translate_Predefined_TF_Reduction - (Iir_Predefined_Boolean_Nor, Left, Res_Type); + return New_Monadic_Op + (ON_Not, + Translate_Predefined_TF_Reduction (ON_Or, Left, Res_Type)); when Iir_Predefined_TF_Reduction_Xor => return Translate_Predefined_TF_Reduction - (Iir_Predefined_Boolean_Xor, Left, Res_Type); + (ON_Xor, Left, Res_Type); when Iir_Predefined_TF_Reduction_Xnor => - return Translate_Predefined_TF_Reduction - (Iir_Predefined_Boolean_Xnor, Left, Res_Type); + return New_Monadic_Op + (ON_Not, + Translate_Predefined_TF_Reduction (ON_Xor, Left, Res_Type)); + + when Iir_Predefined_Vector_Minimum => + return Translate_Predefined_Vector_Min_Max + (True, Left, Res_Type); + when Iir_Predefined_Vector_Maximum => + return Translate_Predefined_Vector_Min_Max + (False, Left, Res_Type); + + when Iir_Predefined_Bit_Rising_Edge + | Iir_Predefined_Boolean_Rising_Edge => + return Translate_Predefined_TF_Edge (True, Left); + when Iir_Predefined_Bit_Falling_Edge + | Iir_Predefined_Boolean_Falling_Edge => + return Translate_Predefined_TF_Edge (False, Left); + + when Iir_Predefined_Std_Ulogic_Array_Match_Equality => + return Translate_Predefined_Std_Ulogic_Array_Match + (Ghdl_Std_Ulogic_Array_Match_Eq, Left, Right, Res_Type); + when Iir_Predefined_Std_Ulogic_Array_Match_Inequality => + return Translate_Predefined_Std_Ulogic_Array_Match + (Ghdl_Std_Ulogic_Array_Match_Ne, Left, Right, Res_Type); when others => null; @@ -15416,6 +15311,13 @@ package body Translation is | Iir_Predefined_Boolean_Xnor => return Translate_Predefined_Logical (Iir_Predefined_Boolean_Xnor, Left_Tree, Right_Tree); + when Iir_Predefined_Bit_Match_Equality => + return New_Compare_Op (ON_Eq, Left_Tree, Right_Tree, + Get_Ortho_Type (Res_Type, Mode_Value)); + when Iir_Predefined_Bit_Match_Inequality => + return New_Compare_Op (ON_Neq, Left_Tree, Right_Tree, + Get_Ortho_Type (Res_Type, Mode_Value)); + when Iir_Predefined_Bit_Condition => return New_Compare_Op (ON_Eq, Left_Tree, New_Lit (Get_Ortho_Expr (Bit_1)), @@ -15645,34 +15547,143 @@ package body Translation is Left_Tree, Right_Tree, Res_Otype); when Iir_Predefined_Std_Ulogic_Match_Greater => return Translate_Std_Ulogic_Match - (Ghdl_Std_Ulogic_Match_Le, + (Ghdl_Std_Ulogic_Match_Lt, Right_Tree, Left_Tree, Res_Otype); when Iir_Predefined_Std_Ulogic_Match_Greater_Equal => return Translate_Std_Ulogic_Match - (Ghdl_Std_Ulogic_Match_Lt, + (Ghdl_Std_Ulogic_Match_Le, Right_Tree, Left_Tree, Res_Otype); + when Iir_Predefined_Bit_Array_Match_Equality => + return New_Compare_Op + (ON_Eq, + Translate_Predefined_Lib_Operator + (Left_Tree, Right_Tree, Imp), + New_Lit (Std_Boolean_True_Node), + Res_Otype); + when Iir_Predefined_Bit_Array_Match_Inequality => + return New_Compare_Op + (ON_Eq, + Translate_Predefined_Lib_Operator + (Left_Tree, Right_Tree, Imp), + New_Lit (Std_Boolean_False_Node), + Res_Otype); + + when Iir_Predefined_Array_Minimum => + return Translate_Predefined_Array_Min_Max + (True, Left_Tree, Right_Tree, Left_Type, Right_Type, + Res_Type, Imp, Loc); + when Iir_Predefined_Array_Maximum => + return Translate_Predefined_Array_Min_Max + (False, Left_Tree, Right_Tree, Left_Type, Right_Type, + Res_Type, Imp, Loc); + when Iir_Predefined_Integer_To_String => case Get_Info (Left_Type).Type_Mode is when Type_Mode_I32 => return Translate_To_String - (Ghdl_To_String_I32, - New_Convert_Ov (Left_Tree, Ghdl_I32_Type), - O_Enode_Null); + (Ghdl_To_String_I32, Res_Type, Loc, + New_Convert_Ov (Left_Tree, Ghdl_I32_Type)); when others => raise Internal_Error; end case; + when Iir_Predefined_Enum_To_String => + declare + Conv : O_Tnode; + Subprg : O_Dnode; + begin + case Get_Info (Left_Type).Type_Mode is + when Type_Mode_B1 => + Subprg := Ghdl_To_String_B1; + Conv := Ghdl_Bool_Type; + when Type_Mode_E8 => + Subprg := Ghdl_To_String_E8; + Conv := Ghdl_I32_Type; + when Type_Mode_E32 => + Subprg := Ghdl_To_String_E32; + Conv := Ghdl_I32_Type; + when others => + raise Internal_Error; + end case; + return Translate_To_String + (Subprg, Res_Type, Loc, + New_Convert_Ov (Left_Tree, Conv), + New_Lit (Rtis.New_Rti_Address + (Get_Info (Left_Type).Type_Rti))); + end; + when Iir_Predefined_Floating_To_String => + return Translate_To_String + (Ghdl_To_String_F64, Res_Type, Loc, + New_Convert_Ov (Left_Tree, Ghdl_Real_Type)); when Iir_Predefined_Real_To_String_Digits => return Translate_To_String - (Ghdl_To_String_F64_Digits, + (Ghdl_To_String_F64_Digits, Res_Type, Loc, New_Convert_Ov (Left_Tree, Ghdl_Real_Type), New_Convert_Ov (Right_Tree, Ghdl_I32_Type)); + when Iir_Predefined_Real_To_String_Format => + return Translate_To_String + (Ghdl_To_String_F64_Format, Res_Type, Loc, + New_Convert_Ov (Left_Tree, Ghdl_Real_Type), + Right_Tree); + when Iir_Predefined_Physical_To_String => + declare + Conv : O_Tnode; + Subprg : O_Dnode; + begin + case Get_Info (Left_Type).Type_Mode is + when Type_Mode_P32 => + Subprg := Ghdl_To_String_P32; + Conv := Ghdl_I32_Type; + when Type_Mode_P64 => + Subprg := Ghdl_To_String_P64; + Conv := Ghdl_I64_Type; + when others => + raise Internal_Error; + end case; + return Translate_To_String + (Subprg, Res_Type, Loc, + New_Convert_Ov (Left_Tree, Conv), + New_Lit (Rtis.New_Rti_Address + (Get_Info (Left_Type).Type_Rti))); + end; + when Iir_Predefined_Time_To_String_Unit => + return Translate_To_String + (Ghdl_Time_To_String_Unit, Res_Type, Loc, + Left_Tree, Right_Tree, + New_Lit (Rtis.New_Rti_Address + (Get_Info (Left_Type).Type_Rti))); when Iir_Predefined_Bit_Vector_To_Ostring => return Translate_Bv_To_String - (Ghdl_BV_To_Ostring, Left_Tree, Left_Type); + (Ghdl_BV_To_Ostring, Left_Tree, Left_Type, Res_Type, Loc); when Iir_Predefined_Bit_Vector_To_Hstring => return Translate_Bv_To_String - (Ghdl_BV_To_Hstring, Left_Tree, Left_Type); + (Ghdl_BV_To_Hstring, Left_Tree, Left_Type, Res_Type, Loc); + when Iir_Predefined_Array_Char_To_String => + declare + El_Type : constant Iir := Get_Element_Subtype (Left_Type); + Subprg : O_Dnode; + Arg : Mnode; + begin + Arg := Stabilize + (E2M (Left_Tree, Get_Info (Left_Type), Mode_Value)); + case Get_Info (El_Type).Type_Mode is + when Type_Mode_B1 => + Subprg := Ghdl_Array_Char_To_String_B1; + when Type_Mode_E8 => + Subprg := Ghdl_Array_Char_To_String_E8; + when Type_Mode_E32 => + Subprg := Ghdl_Array_Char_To_String_E32; + when others => + raise Internal_Error; + end case; + return Translate_To_String + (Subprg, Res_Type, Loc, + New_Convert_Ov (M2E (Chap3.Get_Array_Base (Arg)), + Ghdl_Ptr_Type), + Chap3.Get_Array_Length (Arg, Left_Type), + New_Lit (Rtis.New_Rti_Address + (Get_Info (El_Type).Type_Rti))); + end; when others => Ada.Text_IO.Put_Line @@ -15699,15 +15710,7 @@ package body Translation is | Type_Mode_File => New_Assign_Stmt (M2Lv (Target), Val); when Type_Mode_Fat_Acc => - declare - T, E : O_Dnode; - begin - T := Create_Temp_Ptr - (Target_Type, M2Lv (Target), Mode_Value); - E := Create_Temp_Init - (T_Info.Ortho_Ptr_Type (Mode_Value), Val); - Copy_Fat_Access (T, E, Target_Type); - end; + Chap3.Translate_Object_Copy (Target, Val, Target_Type); when Type_Mode_Fat_Array => declare T : Mnode; @@ -16403,14 +16406,14 @@ package body Translation is Val_M := Stabilize (E2M (Val, D_Info, Mode_Value)); Chap3.Translate_Object_Allocation (R, Alloc_Heap, D_Type, - M2Addr (Chap3.Get_Array_Bounds (Val_M))); + Chap3.Get_Array_Bounds (Val_M)); Val := M2E (Val_M); Rtype := A_Info.Ortho_Ptr_Type (Mode_Value); 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, O_Enode_Null); + (R, Alloc_Heap, D_Type, Mnode_Null); Rtype := A_Info.Ortho_Type (Mode_Value); when others => raise Internal_Error; @@ -16427,7 +16430,7 @@ package body Translation is D_Type : constant Iir := Get_Designated_Type (P_Type); D_Info : constant Type_Info_Acc := Get_Info (D_Type); Sub_Type : Iir; - Bounds : O_Enode; + Bounds : Mnode; Res : Mnode; Rtype : O_Tnode; begin @@ -16440,12 +16443,12 @@ package body Translation is Sub_Type := Get_Subtype_Indication (Expr); Sub_Type := Get_Type_Of_Subtype_Indication (Sub_Type); Chap3.Create_Array_Subtype (Sub_Type, True); - Bounds := M2E (Chap3.Get_Array_Type_Bounds (Sub_Type)); + Bounds := Chap3.Get_Array_Type_Bounds (Sub_Type); Rtype := P_Info.Ortho_Ptr_Type (Mode_Value); when Type_Mode_Acc => Res := Dp2M (Create_Temp (D_Info.Ortho_Ptr_Type (Mode_Value)), D_Info, Mode_Value); - Bounds := O_Enode_Null; + Bounds := Mnode_Null; Rtype := P_Info.Ortho_Type (Mode_Value); when others => raise Internal_Error; @@ -16465,52 +16468,26 @@ package body Translation is is Res_Info : constant Type_Info_Acc := Get_Info (Res_Type); Expr_Info : constant Type_Info_Acc := Get_Info (Expr_Type); + E : Mnode; begin + E := Stabilize (E2M (Expr, Expr_Info, Mode_Value)); case Res_Info.Type_Mode is when Type_Mode_Array => - declare - E : O_Dnode; - begin - E := Create_Temp_Init (Expr_Info.Ortho_Ptr_Type (Mode_Value), - Expr); - Chap3.Check_Array_Match - (Res_Type, T2M (Res_Type, Mode_Value), - Expr_Type, Dp2M (E, Expr_Info, Mode_Value), - Loc); - return New_Convert_Ov - (New_Value (Chap3.Get_Array_Ptr_Base_Ptr - (New_Obj (E), Expr_Type, Mode_Value)), - Res_Info.Ortho_Ptr_Type (Mode_Value)); - end; + Chap3.Check_Array_Match + (Res_Type, T2M (Res_Type, Mode_Value), + Expr_Type, E, + Loc); + return New_Convert_Ov + (M2Addr (Chap3.Get_Array_Base (E)), + Res_Info.Ortho_Ptr_Type (Mode_Value)); when Type_Mode_Fat_Array => declare - Res : O_Dnode; - E : O_Dnode; + Res : Mnode; begin - Res := Create_Temp (Res_Info.Ortho_Type (Mode_Value)); - Open_Temp; - E := Create_Temp_Init (Expr_Info.Ortho_Ptr_Type (Mode_Value), - Expr); - -- Convert base. - New_Assign_Stmt - (New_Selected_Element - (New_Obj (Res), Res_Info.T.Base_Field (Mode_Value)), - New_Value (Chap3.Get_Array_Ptr_Base_Ptr - (New_Obj (E), Expr_Type, Mode_Value))); - -- Copy subtype bounds. - New_Assign_Stmt - (New_Selected_Element - (New_Obj (Res), Res_Info.T.Bounds_Field (Mode_Value)), - Chap3.Get_Array_Bounds_Ptr (O_Lnode_Null, Expr_Type, - Mode_Value)); - -- Check array match. - Chap3.Check_Array_Match - (Res_Type, Dv2M (Res, Res_Info, Mode_Value), - Expr_Type, Dp2M (E, Expr_Info, Mode_Value), - Loc); - Close_Temp; - return New_Address - (New_Obj (Res), Res_Info.Ortho_Ptr_Type (Mode_Value)); + Res := Create_Temp (Res_Info); + Copy_Fat_Pointer (Res, E); + Chap3.Check_Array_Match (Res_Type, Res, Expr_Type, E, Loc); + return M2Addr (Res); end; when others => Error_Kind ("translate_array_subtype_conversion", Res_Type); @@ -16552,93 +16529,65 @@ package body Translation is (Expr : O_Enode; Expr_Type : Iir; Res_Type : Iir; Loc : Iir) return O_Enode is - Res : O_Dnode; - Res_Ptr : O_Dnode; - E : O_Dnode; + Res_Info : constant Type_Info_Acc := Get_Info (Res_Type); + Expr_Info : constant Type_Info_Acc := Get_Info (Expr_Type); + Res_Indexes : constant Iir_List := + Get_Index_Subtype_List (Res_Type); + Expr_Indexes : constant Iir_List := + Get_Index_Subtype_List (Expr_Type); + Res : Mnode; + E : Mnode; Bounds : O_Dnode; - Res_Indexes : Iir_List; - Expr_Indexes : Iir_List; R_El : Iir; E_El : Iir; - Res_Info : Type_Info_Acc; - Expr_Info : Type_Info_Acc; begin - Res_Info := Get_Info (Res_Type); - Expr_Info := Get_Info (Expr_Type); - Res := Create_Temp (Res_Info.Ortho_Type (Mode_Value)); + Res := Create_Temp (Res_Info, Mode_Value); Bounds := Create_Temp (Res_Info.T.Bounds_Type); + E := Stabilize (E2M (Expr, Expr_Info, Mode_Value)); Open_Temp; - Res_Ptr := Create_Temp_Ptr - (Res_Info.Ortho_Ptr_Type (Mode_Value), New_Obj (Res)); - E := Create_Temp_Init (Expr_Info.Ortho_Ptr_Type (Mode_Value), Expr); -- Set base. New_Assign_Stmt - (New_Selected_Element (New_Obj (Res), - Res_Info.T.Base_Field (Mode_Value)), - New_Convert_Ov (New_Value (Chap3.Get_Array_Ptr_Base_Ptr - (New_Obj (E), Expr_Type, Mode_Value)), + (M2Lp (Chap3.Get_Array_Base (Res)), + New_Convert_Ov (M2Addr (Chap3.Get_Array_Base (E)), Res_Info.T.Base_Ptr_Type (Mode_Value))); -- Set bounds. New_Assign_Stmt - (New_Selected_Element (New_Obj (Res), - Res_Info.T.Bounds_Field (Mode_Value)), + (M2Lp (Chap3.Get_Array_Bounds (Res)), New_Address (New_Obj (Bounds), Res_Info.T.Bounds_Ptr_Type)); + -- Convert bounds. - Res_Indexes := Get_Index_Subtype_List (Res_Type); - Expr_Indexes := Get_Index_Subtype_List (Expr_Type); for I in Natural loop R_El := Get_Index_Type (Res_Indexes, I); E_El := Get_Index_Type (Expr_Indexes, I); exit when R_El = Null_Iir; declare - Rb_Ptr : O_Dnode; - Eb_Ptr : O_Dnode; - Rr_Info : constant Type_Info_Acc := Get_Info (R_El); - Er_Info : constant Type_Info_Acc := - Get_Info (Get_Base_Type (E_El)); + Rb_Ptr : Mnode; + Eb_Ptr : Mnode; begin Open_Temp; - Rb_Ptr := Create_Temp_Init - (Rr_Info.T.Range_Ptr_Type, - Chap3.Get_Array_Ptr_Range_Ptr (New_Obj (Res_Ptr), - Res_Type, I + 1, - Mode_Value)); - Eb_Ptr := Create_Temp_Init - (Er_Info.T.Range_Ptr_Type, - Chap3.Get_Array_Ptr_Range_Ptr (New_Obj (E), Expr_Type, I + 1, - Mode_Value)); + Rb_Ptr := Stabilize + (Chap3.Get_Array_Range (Res, Res_Type, I + 1)); + Eb_Ptr := Stabilize + (Chap3.Get_Array_Range (E, Expr_Type, I + 1)); -- Convert left and right. New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (Rb_Ptr), - Rr_Info.T.Range_Left), + (M2Lv (Chap3.Range_To_Left (Rb_Ptr)), Translate_Type_Conversion - (New_Value_Selected_Acc_Value (New_Obj (Eb_Ptr), - Er_Info.T.Range_Left), - E_El, R_El, Loc)); + (M2E (Chap3.Range_To_Left (Eb_Ptr)), E_El, R_El, Loc)); New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (Rb_Ptr), - Rr_Info.T.Range_Right), + (M2Lv (Chap3.Range_To_Right (Rb_Ptr)), Translate_Type_Conversion - (New_Value_Selected_Acc_Value (New_Obj (Eb_Ptr), - Er_Info.T.Range_Right), - E_El, R_El, Loc)); + (M2E (Chap3.Range_To_Right (Eb_Ptr)), E_El, R_El, Loc)); -- Copy Dir and Length. - New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (Rb_Ptr), - Rr_Info.T.Range_Dir), - New_Value_Selected_Acc_Value (New_Obj (Eb_Ptr), - Er_Info.T.Range_Dir)); - New_Assign_Stmt - (New_Selected_Acc_Value (New_Obj (Rb_Ptr), - Rr_Info.T.Range_Length), - New_Value_Selected_Acc_Value (New_Obj (Eb_Ptr), - Er_Info.T.Range_Length)); + New_Assign_Stmt (M2Lv (Chap3.Range_To_Dir (Rb_Ptr)), + M2E (Chap3.Range_To_Dir (Eb_Ptr))); + New_Assign_Stmt (M2Lv (Chap3.Range_To_Length (Rb_Ptr)), + M2E (Chap3.Range_To_Length (Eb_Ptr))); Close_Temp; end; end loop; Close_Temp; - return New_Address (New_Obj (Res), - Res_Info.Ortho_Ptr_Type (Mode_Value)); + return M2E (Res); end Translate_Fat_Array_Type_Conversion; function Sig2val_Prepare_Composite @@ -17158,9 +17107,11 @@ package body Translation is Res := Chap14.Translate_Last_Value_Attribute (Expr); when Iir_Kind_High_Type_Attribute => - return Chap14.Translate_High_Low_Type_Attribute (Expr, True); + return Chap14.Translate_High_Low_Type_Attribute + (Get_Type (Expr), True); when Iir_Kind_Low_Type_Attribute => - return Chap14.Translate_High_Low_Type_Attribute (Expr, False); + return Chap14.Translate_High_Low_Type_Attribute + (Get_Type (Expr), False); when Iir_Kind_Left_Type_Attribute => return M2E (Chap3.Range_To_Left @@ -17558,11 +17509,14 @@ package body Translation is Finish_If_Stmt (If_Blk1); end Gen_Compare; + Arr_Type : constant Iir_Array_Type_Definition := + Get_Type (Get_Interface_Declaration_Chain (Subprg)); + Info : constant Type_Info_Acc := Get_Info (Arr_Type); + Id : constant Name_Id := + Get_Identifier (Get_Type_Declarator (Arr_Type)); + Arr_Ptr_Type : constant O_Tnode := Info.Ortho_Ptr_Type (Mode_Value); + F_Info : Subprg_Info_Acc; - Arr_Type : Iir_Array_Type_Definition; - Arr_Ptr_Type : O_Tnode; - Info : Type_Info_Acc; - Id : Name_Id; L, R : O_Dnode; Interface_List : O_Inter_List; If_Blk : O_If_Block; @@ -17572,11 +17526,6 @@ package body Translation is Label : O_Snode; El_Otype : O_Tnode; begin - Arr_Type := Get_Type (Get_Interface_Declaration_Chain (Subprg)); - Info := Get_Info (Arr_Type); - Id := Get_Identifier (Get_Type_Declarator (Arr_Type)); - Arr_Ptr_Type := Info.Ortho_Ptr_Type (Mode_Value); - F_Info := Add_Info (Subprg, Kind_Subprg); --Chap2.Clear_Instance_Data (F_Info.Subprg_Instance); @@ -17595,20 +17544,18 @@ package body Translation is (Get_Element_Subtype (Arr_Type), Mode_Value); Start_Subprogram_Body (F_Info.Ortho_Func); -- Compute length of L and R. - New_Var_Decl (Var_L_Len, Get_Identifier ("l_len"), + New_Var_Decl (Var_L_Len, Wki_L_Len, O_Storage_Local, Ghdl_Index_Type); - New_Var_Decl (Var_R_Len, Get_Identifier ("r_len"), + New_Var_Decl (Var_R_Len, Wki_R_Len, O_Storage_Local, Ghdl_Index_Type); New_Var_Decl (Var_Len, Wki_Length, O_Storage_Local, Ghdl_Index_Type); New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); - New_Assign_Stmt - (New_Obj (Var_L_Len), - Chap6.Get_Array_Ptr_Bound_Length - (New_Obj (L), Arr_Type, 1, Mode_Value)); - New_Assign_Stmt - (New_Obj (Var_R_Len), - Chap6.Get_Array_Ptr_Bound_Length - (New_Obj (R), Arr_Type, 1, Mode_Value)); + New_Assign_Stmt (New_Obj (Var_L_Len), + Chap6.Get_Array_Bound_Length + (Dp2M (L, Info, Mode_Value), Arr_Type, 1)); + New_Assign_Stmt (New_Obj (Var_R_Len), + Chap6.Get_Array_Bound_Length + (Dp2M (R, Info, Mode_Value), Arr_Type, 1)); -- Find the minimum length. Start_If_Stmt (If_Blk, New_Compare_Op (ON_Ge, @@ -17639,18 +17586,16 @@ package body Translation is El_Otype); New_Assign_Stmt (New_Obj (Var_L_El), - New_Value - (New_Indexed_Element - (New_Acc_Value (Chap3.Get_Array_Ptr_Base_Ptr - (New_Obj (L), Arr_Type, Mode_Value)), - New_Obj_Value (Var_I)))); + M2E (Chap3.Index_Base + (Chap3.Get_Array_Base (Dp2M (L, Info, Mode_Value)), + Arr_Type, + New_Obj_Value (Var_I)))); New_Assign_Stmt (New_Obj (Var_R_El), - New_Value - (New_Indexed_Element - (New_Acc_Value (Chap3.Get_Array_Ptr_Base_Ptr - (New_Obj (R), Arr_Type, Mode_Value)), - New_Obj_Value (Var_I)))); + M2E (Chap3.Index_Base + (Chap3.Get_Array_Base (Dp2M (R, Info, Mode_Value)), + Arr_Type, + New_Obj_Value (Var_I)))); Gen_Compare (Var_L_El, Var_R_El); Finish_Declare_Stmt; Inc_Var (Var_I); @@ -17820,8 +17765,10 @@ package body Translation is -- for each element: if element is not equal, return false New_Var_Decl (Var_I, Wki_I, O_Storage_Local, Ghdl_Index_Type); New_Var_Decl (Var_Len, Wki_Length, O_Storage_Local, Ghdl_Index_Type); + Open_Temp; New_Assign_Stmt (New_Obj (Var_Len), Chap3.Get_Array_Length (L, Arr_Type)); + Close_Temp; Init_Var (Var_I); Start_Loop_Stmt (Label); -- If the end of the array is reached, return TRUE. @@ -17968,10 +17915,8 @@ package body Translation is Chap2.Start_Subprg_Instance_Use (Subprg); New_Var_Decl (Var_Length, Wki_Length, O_Storage_Local, Ghdl_Index_Type); - New_Var_Decl (Var_L_Len, Get_Identifier ("l_len"), O_Storage_Local, - Ghdl_Index_Type); - New_Var_Decl (Var_R_Len, Get_Identifier ("r_len"), O_Storage_Local, - Ghdl_Index_Type); + New_Var_Decl (Var_L_Len, Wki_L_Len, O_Storage_Local, Ghdl_Index_Type); + New_Var_Decl (Var_R_Len, Wki_R_Len, O_Storage_Local, Ghdl_Index_Type); New_Var_Decl (Var_Bounds, Get_Identifier ("bounds"), O_Storage_Local, Info.T.Bounds_Ptr_Type); @@ -18179,12 +18124,15 @@ package body Translation is procedure Translate_Predefined_Array_Logical (Subprg : Iir) is - F_Info : Subprg_Info_Acc; - Arr_Type : Iir_Array_Type_Definition; - Arr_Ptr_Type : O_Tnode; + Arr_Type : constant Iir_Array_Type_Definition := + Get_Type (Get_Interface_Declaration_Chain (Subprg)); -- Info for the array type. - Info : Type_Info_Acc; - Id : Name_Id; + Info : constant Type_Info_Acc := Get_Info (Arr_Type); + -- Identifier of the type. + Id : constant Name_Id := + Get_Identifier (Get_Type_Declarator (Arr_Type)); + Arr_Ptr_Type : constant O_Tnode := Info.Ortho_Ptr_Type (Mode_Value); + F_Info : Subprg_Info_Acc; Interface_List : O_Inter_List; Var_Res : O_Dnode; Res : Mnode; @@ -18199,11 +18147,6 @@ package body Translation is Op : ON_Op_Kind; Do_Invert : Boolean; begin - Arr_Type := Get_Type (Get_Interface_Declaration_Chain (Subprg)); - Info := Get_Info (Arr_Type); - Id := Get_Identifier (Get_Type_Declarator (Arr_Type)); - Arr_Ptr_Type := Info.Ortho_Ptr_Type (Mode_Value); - F_Info := Add_Info (Subprg, Kind_Subprg); --Chap2.Clear_Instance_Data (F_Info.Subprg_Instance); F_Info.Use_Stack2 := True; @@ -18275,15 +18218,15 @@ package body Translation is Open_Temp; -- Get length of LEFT. New_Assign_Stmt (New_Obj (Var_Length), - Chap6.Get_Array_Ptr_Bound_Length - (New_Obj (L), Arr_Type, 1, Mode_Value)); + Chap6.Get_Array_Bound_Length + (Dp2M (L, Info, Mode_Value), Arr_Type, 1)); -- If dyadic, check RIGHT has the same length. if not Is_Monadic then Chap6.Check_Bound_Error (New_Compare_Op (ON_Neq, New_Obj_Value (Var_Length), - Chap6.Get_Array_Ptr_Bound_Length - (New_Obj (R), Arr_Type, 1, Mode_Value), + Chap6.Get_Array_Bound_Length + (Dp2M (R, Info, Mode_Value), Arr_Type, 1), Ghdl_Bool_Type), Subprg, 0); end if; @@ -18292,19 +18235,16 @@ package body Translation is Res := Dp2M (Var_Res, Info, Mode_Value); Chap3.Translate_Object_Allocation (Res, Alloc_Return, Arr_Type, - Chap3.Get_Array_Ptr_Bounds_Ptr - (New_Obj (L), Arr_Type, Mode_Value)); + Chap3.Get_Array_Bounds (Dp2M (L, Info, Mode_Value))); New_Assign_Stmt (New_Obj (Var_Base), M2Addr (Chap3.Get_Array_Base (Res))); New_Assign_Stmt (New_Obj (Var_L_Base), - New_Value (Chap3.Get_Array_Ptr_Base_Ptr - (New_Obj (L), Arr_Type, Mode_Value))); + M2Addr (Chap3.Get_Array_Base (Dp2M (L, Info, Mode_Value)))); if not Is_Monadic then New_Assign_Stmt (New_Obj (Var_R_Base), - New_Value (Chap3.Get_Array_Ptr_Base_Ptr - (New_Obj (R), Arr_Type, Mode_Value))); + M2Addr (Chap3.Get_Array_Base (Dp2M (R, Info, Mode_Value)))); end if; -- Do the logical operation on each element. @@ -18375,12 +18315,19 @@ package body Translation is is Tmp : O_Enode; begin + -- LEFT: + -- * I := 0; + if not To_Right then + Init_Var (Var_I); + end if; + -- * If R < LENGTH then Start_If_Stmt (If_Blk1, New_Compare_Op (ON_Lt, New_Obj_Value (Var_Rl), New_Obj_Value (Var_Length), Ghdl_Bool_Type)); + -- Shift the elements (that remains in the result). -- RIGHT: -- * for I = R to LENGTH - 1 loop -- * RES[I] := L[I - R] @@ -18391,7 +18338,6 @@ package body Translation is New_Assign_Stmt (New_Obj (Var_I), New_Obj_Value (Var_Rl)); Init_Var (Var_I1); else - Init_Var (Var_I); New_Assign_Stmt (New_Obj (Var_I1), New_Obj_Value (Var_Rl)); end if; Start_Loop_Stmt (Label); @@ -18413,12 +18359,16 @@ package body Translation is Inc_Var (Var_I); Inc_Var (Var_I1); Finish_Loop_Stmt (Label); - New_Else_Stmt (If_Blk1); + -- RIGHT: -- * else - -- * R := LENGTH - New_Assign_Stmt (New_Obj (Var_Rl), New_Obj_Value (Var_Length)); + -- * R := LENGTH; + if To_Right then + New_Else_Stmt (If_Blk1); + New_Assign_Stmt (New_Obj (Var_Rl), New_Obj_Value (Var_Length)); + end if; Finish_If_Stmt (If_Blk1); + -- Pad the result. -- RIGHT: -- * For I = 0 to R - 1 -- * RES[I] := 0/L[0/LENGTH-1] @@ -18840,7 +18790,7 @@ package body Translation is (Inter_List, Var_File, Get_Identifier ("FILE"), Ghdl_File_Index_Type); New_Interface_Decl - (Inter_List, Var_Val, Get_Identifier ("VAL"), + (Inter_List, Var_Val, Wki_Val, Tinfo.Ortho_Ptr_Type (Mode_Value)); Finish_Subprogram_Decl (Inter_List, F_Info.Ortho_Func); @@ -19058,7 +19008,9 @@ package body Translation is end if; when Iir_Predefined_Array_Equality - | Iir_Predefined_Array_Inequality => + | Iir_Predefined_Array_Inequality + | Iir_Predefined_Bit_Array_Match_Equality + | Iir_Predefined_Bit_Array_Match_Inequality => if Infos.Arr_Eq_Info = null then Translate_Predefined_Array_Equality (Subprg); Infos.Arr_Eq_Info := Get_Info (Subprg); @@ -19069,7 +19021,9 @@ package body Translation is when Iir_Predefined_Array_Greater | Iir_Predefined_Array_Greater_Equal | Iir_Predefined_Array_Less - | Iir_Predefined_Array_Less_Equal => + | Iir_Predefined_Array_Less_Equal + | Iir_Predefined_Array_Minimum + | Iir_Predefined_Array_Maximum => if Infos.Arr_Cmp_Info = null then Translate_Predefined_Array_Compare (Subprg); Infos.Arr_Cmp_Info := Get_Info (Subprg); @@ -19088,9 +19042,7 @@ package body Translation is Set_Info (Subprg, Infos.Arr_Concat_Info); end if; - when Iir_Predefined_Array_Minimum - | Iir_Predefined_Array_Maximum - | Iir_Predefined_Vector_Minimum + when Iir_Predefined_Vector_Minimum | Iir_Predefined_Vector_Maximum => null; @@ -19121,9 +19073,7 @@ package body Translation is | Iir_Predefined_TF_Array_Element_Xor | Iir_Predefined_TF_Element_Array_Xor | Iir_Predefined_TF_Array_Element_Xnor - | Iir_Predefined_TF_Element_Array_Xnor - | Iir_Predefined_Bit_Array_Match_Equality - | Iir_Predefined_Bit_Array_Match_Inequality => + | Iir_Predefined_TF_Element_Array_Xnor => null; when Iir_Predefined_Array_Sll @@ -19229,12 +19179,11 @@ package body Translation is package body Chap8 is procedure Translate_Return_Statement (Stmt : Iir_Return_Statement) is - Expr : Iir; + Subprg_Info : constant Ortho_Info_Acc := + Get_Info (Chap2.Current_Subprogram); + Expr : constant Iir := Get_Expression (Stmt); Ret_Type : Iir; Ret_Info : Type_Info_Acc; - Val : O_Dnode; - Area : Mnode; - Subprg_Info : Ortho_Info_Acc; procedure Gen_Return is begin @@ -19255,9 +19204,6 @@ package body Translation is end if; end Gen_Return_Value; begin - Subprg_Info := Get_Info (Chap2.Current_Subprogram); - - Expr := Get_Expression (Stmt); if Expr = Null_Iir then -- Return in a procedure. Gen_Return; @@ -19303,17 +19249,21 @@ package body Translation is -- the secondary stack, copy it to the area, and fill the fat -- pointer. -- Evaluate the result. - Area := Dp2M (Subprg_Info.Res_Interface, Ret_Info, Mode_Value); - Val := Create_Temp_Init - (Ret_Info.Ortho_Ptr_Type (Mode_Value), - Chap7.Translate_Expression (Expr, Ret_Type)); - Chap3.Translate_Object_Allocation - (Area, Alloc_Return, Ret_Type, - Chap3.Get_Array_Ptr_Bounds_Ptr - (New_Obj (Val), Ret_Type, Mode_Value)); - Chap3.Translate_Object_Copy - (Area, New_Obj_Value (Val), Ret_Type); - Gen_Return; + declare + Val : Mnode; + Area : Mnode; + begin + Area := Dp2M (Subprg_Info.Res_Interface, + Ret_Info, Mode_Value); + Val := Stabilize + (E2M (Chap7.Translate_Expression (Expr, Ret_Type), + Ret_Info, Mode_Value)); + Chap3.Translate_Object_Allocation + (Area, Alloc_Return, Ret_Type, + Chap3.Get_Array_Bounds (Val)); + Chap3.Translate_Object_Copy (Area, M2Addr (Val), Ret_Type); + Gen_Return; + end; when Type_Mode_Record | Type_Mode_Array | Type_Mode_Fat_Acc => @@ -19835,7 +19785,6 @@ package body Translation is Severity : O_Enode; Assocs : O_Assoc_List; Loc : O_Dnode; - Rti : O_Cnode; begin Loc := Chap4.Get_Location (Stmt); Expr := Get_Report_Expression (Stmt); @@ -19856,24 +19805,39 @@ package body Translation is New_Association (Assocs, Severity); New_Association (Assocs, New_Address (New_Obj (Loc), Ghdl_Location_Ptr_Node)); - if Current_Library_Unit /= Null_Iir - and then Get_Kind (Current_Library_Unit) = Iir_Kind_Package_Body - then - Rti := Rtis.New_Rti_Address - (Get_Info - (Get_Package (Current_Library_Unit)).Package_Rti_Const); - else - Rti := New_Null_Access (Rtis.Ghdl_Rti_Access); - end if; - New_Association (Assocs, New_Lit (Rti)); New_Procedure_Call (Assocs); end Translate_Report; + -- Return True if the current library unit is part of library IEEE. + function Is_Within_Ieee_Library return Boolean + is + Design_File : Iir; + Library : Iir; + begin + -- Guard. + if Current_Library_Unit = Null_Iir then + return False; + end if; + Design_File := + Get_Design_File (Get_Design_Unit (Current_Library_Unit)); + Library := Get_Library (Design_File); + return Get_Identifier (Library) = Std_Names.Name_Ieee; + end Is_Within_Ieee_Library; + procedure Translate_Assertion_Statement (Stmt : Iir_Assertion_Statement) is Expr : Iir; If_Blk : O_If_Block; + Subprg : O_Dnode; begin + -- Select the procedure to call in case of assertion (so that + -- assertions within the IEEE library could be ignored). + if Is_Within_Ieee_Library then + Subprg := Ghdl_Ieee_Assert_Failed; + else + Subprg := Ghdl_Assert_Failed; + end if; + Expr := Get_Assertion_Condition (Stmt); if Get_Expr_Staticness (Expr) = Locally then if Eval_Pos (Expr) = 1 then @@ -19881,7 +19845,7 @@ package body Translation is -- FIXME: generate a noop ? return; end if; - Translate_Report (Stmt, Ghdl_Assert_Failed, Severity_Level_Error); + Translate_Report (Stmt, Subprg, Severity_Level_Error); else -- An assertion is reported if the condition is false! Start_If_Stmt (If_Blk, @@ -19890,7 +19854,7 @@ package body Translation is -- Note: it is necessary to create a declare block, to avoid bad -- order with the if block. Open_Temp; - Translate_Report (Stmt, Ghdl_Assert_Failed, Severity_Level_Error); + Translate_Report (Stmt, Subprg, Severity_Level_Error); Close_Temp; Finish_If_Stmt (If_Blk); end if; @@ -20858,7 +20822,7 @@ package body Translation is Out_Conv : Iir; Out_Expr : Iir; Formal_Object_Kind : Object_Kind_Type; - Bounds : O_Enode; + Bounds : Mnode; Obj : Iir; begin -- Create an in-out result record for in-out arguments passed by @@ -20911,7 +20875,7 @@ package body Translation is end if; if Ftype_Info.Type_Mode = Type_Mode_Fat_Array then Chap3.Create_Array_Subtype (Actual_Type, True); - Bounds := M2E (Chap3.Get_Array_Type_Bounds (Actual_Type)); + Bounds := Chap3.Get_Array_Type_Bounds (Actual_Type); Param := Create_Temp (Ftype_Info, Formal_Object_Kind); Chap3.Translate_Object_Allocation (Param, Alloc_Stack, Formal_Type, Bounds); @@ -25035,18 +24999,23 @@ package body Translation is end Range_To_High_Low; function Translate_High_Low_Type_Attribute - (Attr : Iir; Is_High : Boolean) return O_Enode - is - Attr_Type : constant Iir := Get_Type (Attr); - Tinfo : constant Ortho_Info_Acc := Get_Info (Attr_Type); - begin - return M2E - (Chap14.Range_To_High_Low - (Lv2M (Chap7.Translate_Range (Get_Prefix (Attr), Attr_Type), - True, - Tinfo.T.Range_Type, Tinfo.T.Range_Ptr_Type, - Tinfo, Mode_Value), - Attr_Type, Is_High)); + (Atype : Iir; Is_High : Boolean) return O_Enode + is + Cons : constant Iir := Get_Range_Constraint (Atype); + begin + -- FIXME: improve code if constraint is a range expression. + if Get_Type_Staticness (Atype) = Locally then + if Get_Direction (Cons) = Iir_To xor Is_High then + return New_Lit + (Chap7.Translate_Static_Range_Left (Cons, Atype)); + else + return New_Lit + (Chap7.Translate_Static_Range_Right (Cons, Atype)); + end if; + else + return M2E (Range_To_High_Low + (Chap3.Type_To_Range (Atype), Atype, Is_High)); + end if; end Translate_High_Low_Type_Attribute; function Translate_High_Low_Array_Attribute (Expr : Iir; @@ -25054,6 +25023,7 @@ package body Translation is return O_Enode is begin + -- FIXME: improve code if index is a range expression. return M2E (Range_To_High_Low (Translate_Array_Attribute_To_Range (Expr), Get_Type (Expr), Is_High)); @@ -25339,12 +25309,9 @@ package body Translation is Data : Bool_Sigattr_Data_Type; Res : O_Dnode; Name : Mnode; - Prefix : Iir; - Prefix_Type : Iir; + Prefix : constant Iir := Get_Prefix (Attr); + Prefix_Type : constant Iir := Get_Type (Prefix); begin - Prefix := Get_Prefix (Attr); - Prefix_Type := Get_Type (Prefix); - if Get_Kind (Prefix_Type) in Iir_Kinds_Scalar_Type_Definition then -- Effecient handling for a scalar signal. Name := Chap6.Translate_Name (Prefix); @@ -26292,7 +26259,7 @@ package body Translation is New_Record_Field (Constr, Ghdl_Rtin_Unit64_Name, Get_Identifier ("name"), Char_Ptr_Type); New_Record_Field (Constr, Ghdl_Rtin_Unit64_Value, - Get_Identifier ("value"), Ghdl_I64_Type); + Wki_Val, Ghdl_I64_Type); Finish_Record_Type (Constr, Ghdl_Rtin_Unit64); New_Type_Decl (Get_Identifier ("__ghdl_rtin_unit64"), Ghdl_Rtin_Unit64); @@ -26759,10 +26726,9 @@ package body Translation is procedure Generate_Enumeration_Type_Definition (Atype : Iir) is + Info : constant Type_Info_Acc := Get_Info (Atype); Val : O_Cnode; - Info : Type_Info_Acc; begin - Info := Get_Info (Atype); Generate_Type_Rti (Info, Ghdl_Rtin_Type_Enum); Info.T.Rti_Max_Depth := 0; @@ -28607,6 +28573,9 @@ package body Translation is Wki_Cmp := Get_Identifier ("cmp"); Wki_Upframe := Get_Identifier ("UPFRAME"); Wki_Frame := Get_Identifier ("FRAME"); + Wki_Val := Get_Identifier ("val"); + Wki_L_Len := Get_Identifier ("l_len"); + Wki_R_Len := Get_Identifier ("r_len"); Sizetype := New_Unsigned_Type (32); New_Type_Decl (Get_Identifier ("__ghdl_size_type"), Sizetype); @@ -28994,7 +28963,7 @@ package body Translation is (Interfaces, Get_Identifier ("__ghdl_signal_init_" & Suffix), O_Storage_External); New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); - New_Interface_Decl (Interfaces, Param, Get_Identifier ("val"), Val_Type); + New_Interface_Decl (Interfaces, Param, Wki_Val, Val_Type); Finish_Subprogram_Decl (Interfaces, Init_Signal); -- procedure __ghdl_signal_simple_assign_XXX (sign : __ghdl_signal_ptr; @@ -29003,7 +28972,7 @@ package body Translation is (Interfaces, Get_Identifier ("__ghdl_signal_simple_assign_" & Suffix), O_Storage_External); New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); - New_Interface_Decl (Interfaces, Param, Get_Identifier ("val"), Val_Type); + New_Interface_Decl (Interfaces, Param, Wki_Val, Val_Type); Finish_Subprogram_Decl (Interfaces, Simple_Assign); -- procedure __ghdl_signal_start_assign_XXX (sign : __ghdl_signal_ptr; @@ -29016,7 +28985,7 @@ package body Translation is New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); New_Interface_Decl (Interfaces, Param, Get_Identifier ("reject"), Std_Time_Otype); - New_Interface_Decl (Interfaces, Param, Get_Identifier ("val"), + New_Interface_Decl (Interfaces, Param, Wki_Val, Val_Type); New_Interface_Decl (Interfaces, Param, Get_Identifier ("after"), Std_Time_Otype); @@ -29029,7 +28998,7 @@ package body Translation is (Interfaces, Get_Identifier ("__ghdl_signal_next_assign_" & Suffix), O_Storage_External); New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); - New_Interface_Decl (Interfaces, Param, Get_Identifier ("val"), + New_Interface_Decl (Interfaces, Param, Wki_Val, Val_Type); New_Interface_Decl (Interfaces, Param, Get_Identifier ("after"), Std_Time_Otype); @@ -29041,7 +29010,7 @@ package body Translation is (Interfaces, Get_Identifier ("__ghdl_signal_associate_" & Suffix), O_Storage_External); New_Interface_Decl (Interfaces, Param, Wki_Sig, Ghdl_Signal_Ptr); - New_Interface_Decl (Interfaces, Param, Get_Identifier ("val"), + New_Interface_Decl (Interfaces, Param, Wki_Val, Val_Type); Finish_Subprogram_Decl (Interfaces, Associate_Value); @@ -29076,10 +29045,10 @@ package body Translation is New_Interface_Decl (Interfaces, Param, Get_Identifier ("res"), Std_String_Ptr_Node); New_Interface_Decl - (Interfaces, Param, Get_Identifier ("val"), Val_Type); + (Interfaces, Param, Wki_Val, Val_Type); if Has_Td then New_Interface_Decl - (Interfaces, Param, Get_Identifier ("rti"), Rtis.Ghdl_Rti_Access); + (Interfaces, Param, Wki_Rti, Rtis.Ghdl_Rti_Access); end if; Finish_Subprogram_Decl (Interfaces, Image_Subprg); @@ -29087,7 +29056,7 @@ package body Translation is (Interfaces, Get_Identifier ("__ghdl_value_" & Name), O_Storage_External, Val_Type); New_Interface_Decl - (Interfaces, Param, Get_Identifier ("val"), Std_String_Ptr_Node); + (Interfaces, Param, Wki_Val, Std_String_Ptr_Node); if Has_Td then New_Interface_Decl (Interfaces, Param, Get_Identifier ("rti"), Rtis.Ghdl_Rti_Access); @@ -29106,13 +29075,31 @@ package body Translation is Start_Function_Decl (Interfaces, Get_Identifier ("__ghdl_std_ulogic_match_" & Name), O_Storage_External, Ghdl_I32_Type); - New_Interface_Decl - (Interfaces, Param, Wki_Left, Ghdl_I32_Type); - New_Interface_Decl - (Interfaces, Param, Wki_Right, Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Wki_Left, Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Wki_Right, Ghdl_I32_Type); Finish_Subprogram_Decl (Interfaces, Subprg); end Create_Std_Ulogic_Match_Subprogram; + -- function __ghdl_std_ulogic_array_match_NAME + -- (l : __ghdl_ptr; l_len : ghdl_index_type; + -- r : __ghdl_ptr; r_len : ghdl_index_type) + -- return __ghdl_i32; + procedure Create_Std_Ulogic_Array_Match_Subprogram (Name : String; + Subprg : out O_Dnode) + is + Interfaces : O_Inter_List; + Param : O_Dnode; + begin + Start_Function_Decl + (Interfaces, Get_Identifier ("__ghdl_std_ulogic_match_" & Name), + O_Storage_External, Ghdl_I32_Type); + New_Interface_Decl (Interfaces, Param, Wki_Left, Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_L_Len, Ghdl_Index_Type); + New_Interface_Decl (Interfaces, Param, Wki_Right, Ghdl_Ptr_Type); + New_Interface_Decl (Interfaces, Param, Wki_R_Len, Ghdl_Index_Type); + Finish_Subprogram_Decl (Interfaces, Subprg); + end Create_Std_Ulogic_Array_Match_Subprogram; + -- procedure NAME (res : std_string_ptr_node; -- val : VAL_TYPE; -- ARG2_NAME : ARG2_TYPE); @@ -29120,7 +29107,9 @@ package body Translation is Subprg : out O_Dnode; Val_Type : O_Tnode; Arg2_Type : O_Tnode := O_Tnode_Null; - Arg2_Name : String := "") + Arg2_Id : O_Ident := O_Ident_Nul; + Arg3_Type : O_Tnode := O_Tnode_Null; + Arg3_Id : O_Ident := O_Ident_Nul) is Interfaces : O_Inter_List; Param : O_Dnode; @@ -29128,12 +29117,16 @@ package body Translation is Start_Procedure_Decl (Interfaces, Get_Identifier (Name), O_Storage_External); New_Interface_Decl - (Interfaces, Param, Get_Identifier ("res"), Std_String_Ptr_Node); + (Interfaces, Param, Wki_Res, Std_String_Ptr_Node); New_Interface_Decl - (Interfaces, Param, Get_Identifier ("val"), Val_Type); + (Interfaces, Param, Wki_Val, Val_Type); if Arg2_Type /= O_Tnode_Null then New_Interface_Decl - (Interfaces, Param, Get_Identifier (Arg2_Name), Arg2_Type); + (Interfaces, Param, Arg2_Id, Arg2_Type); + if Arg3_Type /= O_Tnode_Null then + New_Interface_Decl + (Interfaces, Param, Arg3_Id, Arg3_Type); + end if; end if; Finish_Subprogram_Decl (Interfaces, Subprg); end Create_To_String_Subprogram; @@ -29166,13 +29159,11 @@ package body Translation is -- procedure __ghdl_assert_failed (str : __ghdl_array_template; -- severity : ghdl_int); - -- loc : __ghdl_location_acc; - -- unit : ghdl_rti_access); + -- loc : __ghdl_location_acc); -- procedure __ghdl_report (str : __ghdl_array_template; -- severity : ghdl_int); - -- loc : __ghdl_location_acc; - -- unit : ghdl_rti_access); + -- loc : __ghdl_location_acc); declare procedure Create_Report_Subprg (Name : String; Subprg : out O_Dnode) is @@ -29186,12 +29177,13 @@ package body Translation is Get_Ortho_Type (Severity_Level_Type_Definition, Mode_Value)); New_Interface_Decl (Interfaces, Param, Get_Identifier ("location"), Ghdl_Location_Ptr_Node); - New_Interface_Decl (Interfaces, Param, Get_Identifier ("unit"), - Rtis.Ghdl_Rti_Access); Finish_Subprogram_Decl (Interfaces, Subprg); end Create_Report_Subprg; begin - Create_Report_Subprg ("__ghdl_assert_failed", Ghdl_Assert_Failed); + Create_Report_Subprg + ("__ghdl_assert_failed", Ghdl_Assert_Failed); + Create_Report_Subprg + ("__ghdl_ieee_assert_failed", Ghdl_Ieee_Assert_Failed); Create_Report_Subprg ("__ghdl_psl_assert_failed", Ghdl_Psl_Assert_Failed); Create_Report_Subprg ("__ghdl_psl_cover", Ghdl_Psl_Cover); @@ -29766,8 +29758,7 @@ package body Translation is begin Start_Function_Decl (Interfaces, Get_Identifier (Name), O_Storage_External, Ghdl_Signal_Ptr); - New_Interface_Decl (Interfaces, Param, Get_Identifier ("val"), - Std_Time_Otype); + New_Interface_Decl (Interfaces, Param, Wki_Val, Std_Time_Otype); Finish_Subprogram_Decl (Interfaces, Res); end Create_Signal_Attribute; begin @@ -29807,8 +29798,7 @@ package body Translation is O_Storage_External, Ghdl_Signal_Ptr); New_Interface_Decl (Interfaces, Param, Get_Identifier ("sig"), Ghdl_Signal_Ptr); - New_Interface_Decl (Interfaces, Param, Get_Identifier ("val"), - Std_Time_Otype); + New_Interface_Decl (Interfaces, Param, Wki_Val, Std_Time_Otype); Finish_Subprogram_Decl (Interfaces, Ghdl_Create_Delayed_Signal); -- function __ghdl_signal_create_guard @@ -29932,6 +29922,11 @@ package body Translation is Create_Std_Ulogic_Match_Subprogram ("lt", Ghdl_Std_Ulogic_Match_Lt); Create_Std_Ulogic_Match_Subprogram ("le", Ghdl_Std_Ulogic_Match_Le); + Create_Std_Ulogic_Array_Match_Subprogram + ("eq", Ghdl_Std_Ulogic_Array_Match_Eq); + Create_Std_Ulogic_Array_Match_Subprogram + ("ne", Ghdl_Std_Ulogic_Array_Match_Ne); + -- Create To_String subprograms. Create_To_String_Subprogram ("__ghdl_to_string_i32", Ghdl_To_String_I32, Ghdl_I32_Type); @@ -29939,18 +29934,53 @@ package body Translation is ("__ghdl_to_string_f64", Ghdl_To_String_F64, Ghdl_Real_Type); Create_To_String_Subprogram ("__ghdl_to_string_f64_digits", Ghdl_To_String_F64_Digits, - Ghdl_Real_Type, Ghdl_I32_Type, "nbr_digits"); + Ghdl_Real_Type, Ghdl_I32_Type, Get_Identifier ("nbr_digits")); + Create_To_String_Subprogram + ("__ghdl_to_string_f64_format", Ghdl_To_String_F64_Format, + Ghdl_Real_Type, Std_String_Ptr_Node, Get_Identifier ("format")); declare Bv_Base_Ptr : constant O_Tnode := Get_Info (Bit_Vector_Type_Definition).T.Base_Ptr_Type (Mode_Value); begin Create_To_String_Subprogram ("__ghdl_bv_to_ostring", Ghdl_BV_To_Ostring, - Bv_Base_Ptr, Ghdl_Index_Type, "len"); + Bv_Base_Ptr, Ghdl_Index_Type, Wki_Length); Create_To_String_Subprogram ("__ghdl_bv_to_hstring", Ghdl_BV_To_Hstring, - Bv_Base_Ptr, Ghdl_Index_Type, "len"); + Bv_Base_Ptr, Ghdl_Index_Type, Wki_Length); end; + Create_To_String_Subprogram + ("__ghdl_to_string_b1", Ghdl_To_String_B1, Ghdl_Bool_Type, + Rtis.Ghdl_Rti_Access, Wki_Rti); + Create_To_String_Subprogram + ("__ghdl_to_string_e8", Ghdl_To_String_E8, Ghdl_I32_Type, + Rtis.Ghdl_Rti_Access, Wki_Rti); + Create_To_String_Subprogram + ("__ghdl_to_string_e32", Ghdl_To_String_E32, Ghdl_I32_Type, + Rtis.Ghdl_Rti_Access, Wki_Rti); + Create_To_String_Subprogram + ("__ghdl_to_string_p32", Ghdl_To_String_P32, Ghdl_I32_Type, + Rtis.Ghdl_Rti_Access, Wki_Rti); + Create_To_String_Subprogram + ("__ghdl_to_string_p64", Ghdl_To_String_P64, Ghdl_I64_Type, + Rtis.Ghdl_Rti_Access, Wki_Rti); + Create_To_String_Subprogram + ("__ghdl_timue_to_string_unit", Ghdl_Time_To_String_Unit, + Std_Time_Otype, Std_Time_Otype, Get_Identifier ("unit"), + Rtis.Ghdl_Rti_Access, Wki_Rti); + Create_To_String_Subprogram + ("__ghdl_array_char_to_string_b1", Ghdl_Array_Char_To_String_B1, + Ghdl_Ptr_Type, Ghdl_Index_Type, Wki_Length, + Rtis.Ghdl_Rti_Access, Wki_Rti); + Create_To_String_Subprogram + ("__ghdl_array_char_to_string_e8", Ghdl_Array_Char_To_String_E8, + Ghdl_Ptr_Type, Ghdl_Index_Type, Wki_Length, + Rtis.Ghdl_Rti_Access, Wki_Rti); + Create_To_String_Subprogram + ("__ghdl_array_char_to_string_e32", Ghdl_Array_Char_To_String_E32, + Ghdl_Ptr_Type, Ghdl_Index_Type, Wki_Length, + Rtis.Ghdl_Rti_Access, Wki_Rti); + end Post_Initialize; procedure Translate_Type_Implicit_Subprograms (Decl : in out Iir) @@ -30159,11 +30189,21 @@ package body Translation is Info.T := Ortho_Info_Type_Array_Init; Free_Type_Info (Info, True); end if; + when Iir_Kind_Implicit_Function_Declaration => + case Get_Implicit_Definition (I) is + when Iir_Predefined_Bit_Array_Match_Equality + | Iir_Predefined_Bit_Array_Match_Inequality => + -- Not in sequence. + null; + when others => + -- By default, info are not shared. + -- The exception is infos for implicit subprograms, + -- but they are always consecutive and not free twice + -- due to prev_info mechanism. + Free_Info (I); + end case; when others => -- By default, info are not shared. - -- The exception is infos for implicit subprograms, but - -- they are always consecutive and not free twice due to - -- prev_info mechanism. Free_Info (I); end case; Prev_Info := Info; |