diff options
Diffstat (limited to 'translate/grt/grt-images.adb')
| -rw-r--r-- | translate/grt/grt-images.adb | 198 |
1 files changed, 190 insertions, 8 deletions
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) |