-- GHDL Run Time (GRT) - 'image subprograms. -- Copyright (C) 2002, 2003, 2004, 2005 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. with System; use System; with System.Storage_Elements; -- Work around GNAT bug. with Ada.Unchecked_Conversion; with Grt.Processes; use Grt.Processes; with Grt.Vstrings; use Grt.Vstrings; 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 Return_String (Res : Std_String_Ptr; Str : String) 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)); 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); 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_B2 (Res : Std_String_Ptr; Val : Ghdl_B2; Rti : Ghdl_Rti_Access) is begin Return_Enum (Res, Rti, Ghdl_B2'Pos (Val)); end Ghdl_Image_B2; 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_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; Unit : Ghdl_C_String; Phys : Ghdl_Rtin_Type_Physical_Acc; Unit_Len : Natural; begin To_String (Str, First, Val); Phys := To_Ghdl_Rtin_Type_Physical_Acc (Rti); Unit := To_Ghdl_Rtin_Unit_Acc (Phys.Units (0)).Name; Unit_Len := strlen (Unit); declare L : 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 (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; Unit : Ghdl_C_String; Phys : Ghdl_Rtin_Type_Physical_Acc; Unit_Len : Natural; begin To_String (Str, First, Val); Phys := To_Ghdl_Rtin_Type_Physical_Acc (Rti); Unit := To_Ghdl_Rtin_Unit_Acc (Phys.Units (0)).Name; Unit_Len := strlen (Unit); declare L : 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 (1 .. Unit_Len); Return_String (Res, Str2); end; end Ghdl_Image_P32; -- 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); -- P : Natural; -- V : Ghdl_F64; -- Vd : Ghdl_F64; -- Exp : Integer; -- D : Integer; -- B : Boolean; -- begin -- -- Handle sign. -- if Val < 0.0 then -- Str (1) := '-'; -- P := 1; -- V := -Val; -- else -- P := 0; -- V := Val; -- end if; -- -- Compute the mantissa. -- -- FIXME: should do a dichotomy. -- if V = 0.0 then -- Exp := 0; -- elsif V < 1.0 then -- Exp := -1; -- while V * (10.0 ** (-Exp)) < 1.0 loop -- Exp := Exp - 1; -- end loop; -- else -- Exp := 0; -- while V / (10.0 ** Exp) >= 10.0 loop -- Exp := Exp + 1; -- end loop; -- end if; -- -- Normalize VAL: in [0; 10[ -- if Exp >= 0 then -- V := V / (10.0 ** Exp); -- else -- V := V * 10.0 ** (-Exp); -- end if; -- for I in 0 .. 15 loop -- Vd := Ghdl_F64'Floor (V); -- P := P + 1; -- Str (P) := Character'Val (48 + Integer (Vd)); -- V := (V - Vd) * 10.0; -- if I = 0 then -- P := P + 1; -- Str (P) := '.'; -- end if; -- exit when I > 0 and V < 10.0 ** (I + 1 - 15); -- end loop; -- if Exp /= 0 then -- -- LRM93 14.3 -- -- if the exponent is present, the `e' is written as a lower case -- -- character. -- P := P + 1; -- Str (P) := 'e'; -- if Exp < 0 then -- P := P + 1; -- Str (P) := '-'; -- Exp := -Exp; -- end if; -- B := False; -- for I in 0 .. 4 loop -- D := (Exp / 10000) mod 10; -- if D /= 0 or B or I = 4 then -- P := P + 1; -- Str (P) := Character'Val (48 + D); -- B := True; -- end if; -- Exp := (Exp - D * 10000) * 10; -- end loop; -- end if; -- Return_String (Res, Str (1 .. P)); -- end Ghdl_Image_F64; 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 (Str : System.Address; Size : Integer; Template : System.Address; Arg : Ghdl_F64); pragma Import (C, snprintf); function strlen (Str : System.Address) return Integer; pragma Import (C, strlen); Format : constant String := "%g" & Character'Val (0); begin snprintf (Str'Address, Str'Length, Format'Address, Val); Return_String (Res, Str (1 .. strlen (Str'Address))); end Ghdl_Image_F64; end Grt.Images;