From 76790ce35751b7db120cbde496782c161d376c60 Mon Sep 17 00:00:00 2001 From: Tristan Gingold Date: Thu, 11 Sep 2014 05:39:42 +0200 Subject: vhdl2008: add translation and support for most of implicit operators. --- translate/grt/grt-cbinding.c | 2 +- translate/grt/grt-errors.adb | 6 ++ translate/grt/grt-errors.ads | 3 + translate/grt/grt-images.adb | 198 +++++++++++++++++++++++++++++++++-- translate/grt/grt-images.ads | 38 +++++++ translate/grt/grt-lib.adb | 109 ++++++++++--------- translate/grt/grt-lib.ads | 35 +++---- translate/grt/grt-processes.adb | 4 +- translate/grt/grt-rtis.ads | 2 + translate/grt/grt-rtis_utils.adb | 22 ++++ translate/grt/grt-rtis_utils.ads | 6 ++ translate/grt/grt-std_logic_1164.adb | 70 +++++++++++-- translate/grt/grt-std_logic_1164.ads | 17 +++ translate/grt/grt-types.ads | 16 +++ translate/grt/grt-values.adb | 17 +-- 15 files changed, 433 insertions(+), 112 deletions(-) (limited to 'translate/grt') diff --git a/translate/grt/grt-cbinding.c b/translate/grt/grt-cbinding.c index 4da06c594..b95c0f0a9 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 2d4d8f689..eddea38c1 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 483ceab67..c797a71bd 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 49bce9d75..59830c137 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 a5d8415a3..b85f8e6a0 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 3c10417aa..d2b095c67 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 b0dc0a3e5..4dac2c8d2 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 3d40f3a96..64db682e2 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 c441b4000..6bb76597e 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 4df5d6f6f..0d4328e7e 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 0cb6e3e81..10c1a0f28 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 49d96e766..5be308bd6 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 d6b1b7d59..4d1569553 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 96bd97b51..fed822554 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 209f658a5..3d703bc85 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; -- cgit v1.2.3