diff options
Diffstat (limited to 'translate/grt/grt-images.adb')
| -rw-r--r-- | translate/grt/grt-images.adb | 233 |
1 files changed, 233 insertions, 0 deletions
diff --git a/translate/grt/grt-images.adb b/translate/grt/grt-images.adb new file mode 100644 index 000000000..8b85d59ec --- /dev/null +++ b/translate/grt/grt-images.adb @@ -0,0 +1,233 @@ +-- 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 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; |