From 9c195bf5d86d67ea5eb419ccf6e48dc153e57c68 Mon Sep 17 00:00:00 2001 From: Tristan Gingold Date: Tue, 4 Nov 2014 20:14:19 +0100 Subject: Move sources to src/ subdirectory. --- translate/grt/grt-images.adb | 387 ------------------------------------------- 1 file changed, 387 deletions(-) delete mode 100644 translate/grt/grt-images.adb (limited to 'translate/grt/grt-images.adb') diff --git a/translate/grt/grt-images.adb b/translate/grt/grt-images.adb deleted file mode 100644 index 342c98f..0000000 --- a/translate/grt/grt-images.adb +++ /dev/null @@ -1,387 +0,0 @@ --- GHDL Run Time (GRT) - 'image subprograms. --- Copyright (C) 2002 - 2014 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GCC; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. --- --- As a special exception, if other files instantiate generics from this --- unit, or you link this unit with other files to produce an executable, --- this unit does not by itself cause the resulting executable to be --- covered by the GNU General Public License. This exception does not --- however invalidate any other reasons why the executable file might be --- covered by the GNU Public License. -with System; use System; -with System.Storage_Elements; -- Work around GNAT bug. -pragma Unreferenced (System.Storage_Elements); -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 - (Source => System.Address, Target => Std_String_Basep); - - function To_Std_String_Boundp is new Ada.Unchecked_Conversion - (Source => System.Address, Target => Std_String_Boundp); - - procedure Set_String_Bounds (Res : Std_String_Ptr; Len : Ghdl_Index_Type) - is - begin - 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; - Set_String_Bounds (Res, Str'Length); - end Return_String; - - procedure Return_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); - Return_String (Res, Str (1 .. strlen (Str))); - end Return_Enum; - - procedure Ghdl_Image_B1 - (Res : Std_String_Ptr; Val : Ghdl_B1; Rti : Ghdl_Rti_Access) - is - begin - Return_Enum (Res, Rti, Ghdl_B1'Pos (Val)); - end Ghdl_Image_B1; - - procedure Ghdl_Image_E8 - (Res : Std_String_Ptr; Val : Ghdl_E8; Rti : Ghdl_Rti_Access) - is - begin - Return_Enum (Res, Rti, Ghdl_E8'Pos (Val)); - end Ghdl_Image_E8; - - procedure Ghdl_Image_E32 - (Res : Std_String_Ptr; Val : Ghdl_E32; Rti : Ghdl_Rti_Access) - is - begin - Return_Enum (Res, Rti, Ghdl_E32'Pos (Val)); - end Ghdl_Image_E32; - - procedure Ghdl_Image_I32 (Res : Std_String_Ptr; Val : Ghdl_I32) - is - Str : String (1 .. 11); - First : Natural; - begin - To_String (Str, First, Val); - Return_String (Res, Str (First .. Str'Last)); - end Ghdl_Image_I32; - - procedure Ghdl_Image_P64 - (Res : Std_String_Ptr; Val : Ghdl_I64; Rti : Ghdl_Rti_Access) - is - Str : String (1 .. 21); - 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 - To_String (Str, First, Val); - Unit_Name := Get_Physical_Unit_Name (Phys.Units (0)); - 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_Image_P64; - - procedure Ghdl_Image_P32 - (Res : Std_String_Ptr; Val : Ghdl_I32; Rti : Ghdl_Rti_Access) - is - Str : String (1 .. 11); - 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 - To_String (Str, First, Val); - Unit_Name := Get_Physical_Unit_Name (Phys.Units (0)); - 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_Image_P32; - - procedure Ghdl_Image_F64 (Res : Std_String_Ptr; Val : Ghdl_F64) - is - Str : String (1 .. 24); - P : Natural; - begin - To_String (Str, P, Val); - Return_String (Res, Str (1 .. P)); - end Ghdl_Image_F64; - - procedure Ghdl_To_String_I32 (Res : Std_String_Ptr; Val : Ghdl_I32) - renames Ghdl_Image_I32; - procedure Ghdl_To_String_F64 (Res : Std_String_Ptr; Val : Ghdl_F64) - renames Ghdl_Image_F64; - - procedure Ghdl_To_String_F64_Digits - (Res : Std_String_Ptr; Val : Ghdl_F64; Nbr_Digits : Ghdl_I32) - is - Str : String_Real_Digits; - P : Natural; - begin - To_String (Str, P, Val, Nbr_Digits); - 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 - 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 - 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_Char (Res : Std_String_Ptr; Val : Std_Character) is - begin - Return_String (Res, (1 => Val)); - end Ghdl_To_String_Char; - - procedure Ghdl_To_String_P32 - (Res : Std_String_Ptr; Val : Ghdl_I32; Rti : Ghdl_Rti_Access) - renames Ghdl_Image_P32; - - 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) --- -- + exp_digits (4) -> 24. --- Str : String (1 .. 25); - --- procedure Snprintf_G (Str : System.Address; --- Size : Integer; --- Arg : Ghdl_F64); --- pragma Import (C, Snprintf_G, "__ghdl_snprintf_g"); - --- function strlen (Str : System.Address) return Integer; --- pragma Import (C, strlen); --- begin --- Snprintf_G (Str'Address, Str'Length, Val); --- Return_String (Res, Str (1 .. strlen (Str'Address))); --- end Ghdl_Image_F64; - -end Grt.Images; -- cgit