grt-images.adb

vhdl集成电路设计软件.需要用gcc-4.0.2版本编译.

--  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;