textio_body.vhdl

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

--  Std.Textio package body.  This file is part of GHDL.
--  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.

package body textio is
  -- output routines for standard types

  --  TIME_NAMES associates time units with textual names.
  --  Textual names are in lower cases, since according to LRM93 14.3:
  --   when written, the identifier is expressed in lowercase characters.
  --  The length of the names are 3 characters, the last one may be a space
  --  for 2 characters long names.
  type time_unit is
    record
      val : time;
      name : string (1 to 3);
    end record;
  type time_names_type is array (1 to 8) of time_unit;
  constant time_names : time_names_type :=
    ((fs, "fs "), (ps, "ps "), (ns, "ns "), (us, "us "),
     (ms, "ms "), (sec, "sec"), (min, "min"), (hr, "hr "));

  --  Non breaking space character.                     --V93
  constant nbsp : character := character'val (160);	--V93

  procedure writeline (f: out text; l: inout line) is --V87
  procedure writeline (file f: text; l: inout line) is --V93
  begin
    if l = null then
      -- LRM93 14.3
      -- If parameter L contains a null access value at the start of the call,
      -- the a null string is written to the file.
      write (f, "");
    else
      -- LRM93 14.3
      -- Procedure WRITELINE causes the current line designated by parameter L
      -- to be written to the file and returns with the value of parameter L
      -- designating a null string.
      write (f, l.all);
      deallocate (l);
      l := new string'("");
    end if;
  end writeline;

  procedure write
    (l: inout line; value: in string;
    justified: in side := right; field: in width := 0)
  is
    variable length: natural;
    variable nl: line;
  begin
    -- l can be null.
    if l = null then
      length := 0;
    else
      length := l.all'length;
    end if;
    if value'length < field then
      nl := new string (1 to length + field);
      if length /= 0 then
        nl (1 to length) := l.all;
      end if;
      if justified = right then
        nl (length + 1 to length + field - value'length) := (others => ' ');
        nl (nl.all'high - value'length + 1 to nl.all'high) := value;
      else
        nl (length + 1 to length + value'length) := value;
        nl (length + value'length + 1 to nl.all'high) := (others => ' ');
      end if;
    else
      nl := new string (1 to length + value'length);
      if length /= 0 then
        nl (1 to length) := l.all;
      end if;
      nl (length + 1 to nl.all'high) := value;
    end if;
    deallocate (l);
    l := nl;
  end write;

  procedure write
    (l: inout line; value: in integer;
    justified: in side := right; field: in width := 0)
  is
    variable str: string (11 downto 1);
    variable val: integer := value;
    variable digit: natural;
    variable index: natural := 0;
  begin
    --  Note: the absolute value of VAL cannot be directly taken, since
    --  it may be greather that the maximum value of an INTEGER.
    loop
      --  LRM93 7.2.6
      --  (A rem B) has the sign of A and an absolute value less then
      --   the absoulte value of B.
      digit := abs (val rem 10);
      val := val / 10;
      index := index + 1;
      str (index) := character'val(48 + digit);
      exit when val = 0;
    end loop;
    if value < 0 then
      index := index + 1;
      str(index) := '-';
    end if;
    write (l, str (index downto 1), justified, field);
  end write;

  procedure write
    (l: inout line; value: in boolean;
    justified: in side := right; field: in width := 0)
  is
  begin
    if value then
      write (l, string'("TRUE"), justified, field);
    else
      write (l, string'("FALSE"), justified, field);
    end if;
  end write;

  procedure write
    (l: inout line; value: in character;
    justified: in side := right; field: in width := 0)
  is
    variable str: string (1 to 1);
  begin
    str (1) := value;
    write (l, str, justified, field);
  end write;

  function bit_to_char (value : in bit) return character is
  begin
    case value is
      when '0' =>
        return '0';
      when '1' =>
        return '1';
    end case;
  end bit_to_char;

  procedure write
    (l: inout line; value: in bit;
    justified: in side := right; field: in width := 0)
  is
    variable str : string (1 to 1);
  begin
    str (1) := bit_to_char (value);
    write (l, str, justified, field);
  end write;

  procedure write
    (l: inout line; value: in bit_vector;
    justified: in side := right; field: in width := 0)
  is
    constant length : natural := value'length;
    alias n_value : bit_vector (1 to value'length) is value;
    variable str : string (1 to length);
  begin
    for i in str'range loop
      str (i) := bit_to_char (n_value (i));
    end loop;
    write (l, str, justified, field);
  end write;

  procedure write
    (l: inout line; value : in time;
    justified: in side := right; field: in width := 0; unit : in TIME := ns)
  is
    --  Copy of VALUE on which we are working.
    variable val : time := value;

    --  Copy of UNIT on which we are working.
    variable un : time := unit;

    --  Digit extract from VAL/UN.
    variable d : integer; -- natural range 0 to 9;

    --  Index for unit name.
    variable n : integer;

    --  Result.
    variable str : string (1 to 28);

    --  Current character in RES.
    variable pos : natural := 1;

    --  Add a character to STR.
    procedure add_char (c : character) is
    begin
      str (pos) := c;
      pos := pos + 1;
    end add_char;
  begin
    --  Note:
    --  Care is taken to avoid overflow.  Time may be 64 bits while integer
    --   may be only 32 bits.

    --  Handle sign.
    --  Note: VAL cannot be negated since its range may be not symetric
    --  around 0.
    if val < 0 ns then
      add_char ('-');
    end if;

    --  Search for the first digit.
    --  Note: we must start from unit, since all units are not a power of 10.
    --  Note: UN can be multiplied only after we know it is possible.  This
    --   is a to avoid overflow.
    if un <= 0 fs then
      assert false report "UNIT argument is not positive" severity error;
      un := 1 ns;
    end if;
    while val / 10 >= un or val / 10 <= -un loop
      un := un * 10;
    end loop;

    --  Extract digits one per one.
    loop
      d := val / un;
      add_char (character'val (abs d + character'pos ('0')));
      val := val - d * un;
      exit when val = 0 ns and un <= unit;
      if un = unit then
	add_char ('.');
      end if;
      --  Stop as soon as precision will be lost.
      --  This can happen only for hr and min.
      --  FIXME: change the algorithm to display all the digits.
      exit when (un / 10) * 10 /= un;
      un := un / 10;
    end loop;

    add_char (' ');

    --  Search the time unit name in the time table.
    n := 0;
    for i in time_names'range loop
      if time_names (i).val = unit then
	n := i;
	exit;
      end if;
    end loop;
    assert n /= 0 report "UNIT argument is not a unit name" severity error;
    if n = 0 then
      add_char ('?');
    else
      add_char (time_names (n).name (1));
      add_char (time_names (n).name (2));
      if time_names (n).name (3) /= ' ' then
	add_char (time_names (n).name (3));
      end if;
    end if;

    --  Write the result.
    write (l, str (1 to pos - 1), justified, field);
  end write;

  -- Parameter DIGITS specifies how many digits to the right of the decimal
  -- point are to be output when writing a real number; the default value 0
  -- indicates that the number should be output in standard form, consisting
  -- of a normalized mantissa plus exponent (e.g., 1.079236E23). If DIGITS is
  -- nonzero, then the real number is output as an integer part followed by
  -- '.' followed by the fractional part, using the specified number of digits
  -- (e.g., 3.14159).
  -- Note: Nan, +Inf, -Inf are not to be considered, since these numbers are
  --  not in the bounds defined by any real range.
  procedure write (L: inout line; value: in real;
                   justified: in side := right; field: in width := 0;
		   digits: in natural := 0)
  is
    --  STR contains the result of the conversion.
    variable str : string (1 to 320);

    --  POS is the index of the next character to be put in STR.
    variable pos : positive := str'left;

    --  VAL contains the value to be converted.
    variable val : real;

    --  The exponent or mantissa computed is stored in MANTISSA.  This is
    --  a signed number.
    variable mantissa : integer;

    variable b : boolean;
    variable d : natural;

    --  Append character C in STR.
    procedure add_char (c : character) is
    begin
      str (pos) := c;
      pos := pos + 1;
    end add_char;

    --  Add digit V in STR.
    procedure add_digit (v : natural) is
    begin
      add_char (character'val (character'pos ('0') + v));
    end add_digit;

    --  Add leading digit and substract it.
    procedure extract_leading_digit is
      variable d : natural range 0 to 10;
    begin
      --  Note: We need truncation but type conversion does rounding.
      --  FIXME: should consider precision.
      d := natural (val);
      if real (d) > val then
	d := d - 1;
      end if;

      val := (val - real (d)) * 10.0;

      add_digit (d);
    end extract_leading_digit;
  begin
    --  Handle sign.
    --  There is no overflow here, since with IEEE implementations, sign is
    --  independant of the mantissa.
    --  LRM93 14.3
    --  The sign is never written if the value is non-negative.
    if value < 0.0 then
      add_char ('-');
      val := -value;
    else
      val := value;
    end if;

    --  Compute the mantissa.
    --  FIXME: should do a dichotomy.
    if val = 0.0 then
      mantissa := 0;
    elsif val < 1.0 then
      mantissa := -1;
      while val * (10.0 ** (-mantissa)) < 1.0 loop
	mantissa := mantissa - 1;
      end loop;
    else
      mantissa := 0;
      while val / (10.0 ** mantissa) >= 10.0 loop
	mantissa := mantissa + 1;
      end loop;
    end if;

    --  Normalize VAL: in [0; 10[
    if mantissa >= 0 then
      val := val / (10.0 ** mantissa);
    else
      val := val * 10.0 ** (-mantissa);
    end if;

    if digits = 0 then
      for i in 0 to 15 loop
	extract_leading_digit;

	if i = 0 then
	  add_char ('.');
	end if;
	exit when i > 0 and val < 10.0 ** (i + 1 - 15);
      end loop;

      --  LRM93 14.3
      --  if the exponent is present, the `e' is written as a lower case 
      --  character.
      add_char ('e');

      if mantissa < 0 then
	add_char ('-');
	mantissa := -mantissa;
      end if;
      b := false;
      for i in 4 downto 0 loop
	d := (mantissa / 10000) mod 10;
	if d /= 0 or b or i = 0 then
	  add_digit (d);
	  b := true;
	end if;
	mantissa := (mantissa - d * 10000) * 10;
      end loop;
    else
      if mantissa < 0 then
	add_char ('0');
	mantissa := mantissa + 1;
      else
	loop
	  extract_leading_digit;
	  exit when mantissa = 0;
	  mantissa := mantissa - 1;
	end loop;
      end if;
      add_char ('.');
      for i in 1 to digits loop
	if mantissa = 0 then
	  extract_leading_digit;
	else
	  add_char ('0');
	  mantissa := mantissa + 1;
	end if;
      end loop;
    end if;
    write (l, str (1 to pos - 1), justified, field);
  end write;

  procedure untruncated_text_read                              --V87
    (variable f : text; str : out string; len : out natural);  --V87
  procedure untruncated_text_read                              --V93
    (file f : text; str : out string; len : out natural);      --V93

  attribute foreign : string;                                  --V87
  attribute foreign of untruncated_text_read : procedure is "GHDL intrinsic";

  procedure untruncated_text_read
    (variable f : text; str : out string; len : out natural) is    --V87
    (file f : text; str : out string; len : out natural) is    --V93
  begin
    assert false report "must not be called" severity failure;
  end untruncated_text_read;
  
  procedure readline (variable f: in text; l: inout line) --V87
  procedure readline (file f: text; l: inout line) --V93
  is
    variable len, nlen, posn : natural;
    variable nl, old_l : line;
    variable str : string (1 to 128);
    variable is_eol : boolean;
  begin
    --  LRM93 14.3
    --  If parameter L contains a non-null access value at the start of the