First import from sources

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 0000000..8b85d59
--- /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;