diff options
Diffstat (limited to 'libraries/std/textio-body.vhdl')
| -rw-r--r-- | libraries/std/textio-body.vhdl | 1558 |
1 files changed, 1558 insertions, 0 deletions
diff --git a/libraries/std/textio-body.vhdl b/libraries/std/textio-body.vhdl new file mode 100644 index 000000000..d01cb8bad --- /dev/null +++ b/libraries/std/textio-body.vhdl @@ -0,0 +1,1558 @@ +-- 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 COPYING3. If not see +-- <http://www.gnu.org/licenses/>. + +package body textio is + attribute foreign : string; --V87 + +--START-V08 + -- LRM08 16.4 + -- The JUSTIFY operation formats a string value within a field that is at + -- least at long as required to contain the value. Parameter FIELD + -- specifies the desired field width. Since the actual field width will + -- always be at least large enough to hold the string value, the default + -- value 0 for the FIELD parameter has the effect of causing the string + -- value to be contained in a field of exactly the right widteh (i.e., no + -- additional leading or tailing spaces). Parameter JUSTIFIED specified + -- whether the string value is to be right- or left-justified within the + -- field; the default is right-justified. If the FIELD parameter describes + -- a field width larger than the number of characters in the string value, + -- space characters are used to fill the remaining characters in the field. + -- + -- TG: Note that the bounds of the result are not specified! + function Justify (Value: String; + Justified : Side := Right; + Field: Width := 0 ) return String + is + constant len : Width := Value'Length; + begin + if Field <= Len then + return Value; + else + case Justified is + when Right => + return (1 to Field - Len => ' ') & Value; + when Left => + return Value & (1 to Field - Len => ' '); + end case; + end if; + end Justify; +--END-V08 + + -- 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. --!V87 + constant nbsp : character := character'val (160); --!V87 + + function is_whitespace (c : character) return Boolean is + begin + case c is + when ' ' + | NBSP --!V87 + | HT => + return True; + when others => + return False; + end case; + end is_Whitespace; + + procedure writeline (variable f: out text; l: inout line) is --V87 + procedure writeline (file f: text; l: inout line) is --!V87 + 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. + null; + 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; + write (f, (1 => LF)); + end writeline; + +--START-V08 + procedure Tee (file f : Text; L : inout LINE) is + begin + -- LRM08 16.4 Package TEXTIO + -- The procedure TEE additionally causes the current line to be written + -- to the file OUTPUT. + if l = null then + null; + else + write (f, l.all); + write (Output, l.all); + deallocate (l); + l := new string'(""); + end if; + write (f, (1 => LF)); + write (output, (1 => LF)); + end Tee; +--END-V08 + + 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; + + procedure textio_write_real + (s : out string; len : out natural; value: real; ndigits : natural); + + attribute foreign of textio_write_real : procedure is "GHDL intrinsic"; + + procedure textio_write_real + (s : out string; len : out natural; value: real; ndigits : natural) is + begin + assert false report "must not be called" severity failure; + end textio_write_real; + + -- 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); + + variable len : natural; + begin + textio_write_real (str, len, value, digits); + assert len <= str'length severity failure; + + write (l, str (1 to len), justified, field); + end write; + +--START-V08 + procedure Owrite (L : inout line; value : in Bit_Vector; + Justified : in Side := Right; Field : in Width := 0) is + begin + write (l, to_ostring (value), justified, field); + end Owrite; + + procedure Hwrite (L : inout line; value : in Bit_Vector; + Justified : in Side := Right; Field : in Width := 0) is + begin + write (l, to_hstring (value), justified, field); + end Hwrite; +--END-V08 + + procedure untruncated_text_read --V87 + (variable f : text; str : out string; len : out natural); --V87 + procedure untruncated_text_read --!V87 + (file f : text; str : out string; len : out natural); --!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 --!V87 + 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) --!V87 + 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 + -- call, the object designated by that value is deallocated before the + -- new object is created. + if l /= null then + deallocate (l); + end if; + + -- End of file is not expected. The user should check endfile before + -- calling readline. + assert not endfile (f) + report "eof in std.textio.readline" severity failure; + + -- We read the input in 128-byte chunks. + -- We keep reading until we reach a newline or there is no more input. + -- The loop invariant is that old_l is allocated and contains the + -- previous chunks read, and posn = old_l.all'length. + posn := 0; + loop + untruncated_text_read (f, str, len); + exit when len = 0; + if str (len) = LF or str (len) = CR then + -- LRM 14.3 + -- The representation of the line does not contain the representation + -- of the end of the line. + is_eol := true; + len := len - 1; + -- End of line is any of LF/CR/CR+LF/LF+CR. + if len > 0 and (str (len) = LF or str (len) = CR) then + len := len - 1; + end if; + elsif endfile (f) then + is_eol := true; + else + is_eol := false; + end if; + l := new string (1 to posn + len); + if old_l /= null then + l (1 to posn) := old_l (1 to posn); + deallocate (old_l); + end if; + l (posn + 1 to posn + len) := str (1 to len); + exit when is_eol; + posn := posn + len; + old_l := l; + end loop; + end readline; + + -- Replaces L with L (LEFT to/downto L'RIGHT) + procedure trim (l : inout line; left : natural) + is + variable nl : line; + begin + if l = null then + return; + end if; + if l'left < l'right then + -- Ascending. + if left > l'right then + nl := new string'(""); + else + nl := new string (left to l'right); +-- nl := new string (1 to l'right + 1 - left); + nl.all := l (left to l'right); + end if; + else + -- Descending + if left < l'right then + nl := new string'(""); + else + nl := new string (left downto l'right); +-- nl := new string (left - l'right + 1 downto 1); + nl.all := l (left downto l'right); + end if; + end if; + deallocate (l); + l := nl; + end trim; + + -- Replaces L with L (LEFT + 1 to L'RIGHT or LEFT - 1 downto L'RIGHT) + procedure trim_next (l : inout line; left : natural) + is + variable nl : line; + begin + if l = null then + return; + end if; + if l'left < l'right then + -- Ascending. + trim (l, left + 1); + else + -- Descending + trim (l, left - 1); + end if; + end trim_next; + + function to_lower (c : character) return character is + begin + if c >= 'A' and c <= 'Z' then + return character'val (character'pos (c) + 32); + else + return c; + end if; + end to_lower; + + procedure read (l: inout line; value: out character; good: out boolean) + is + variable nl : line; + begin + if l = null or l'length = 0 then + good := false; + else + value := l (l'left); + trim_next (l, l'left); + good := true; + end if; + end read; + + procedure read (l: inout line; value: out character) + is + variable res : boolean; + begin + read (l, value, res); + assert res = true + report "character read failure" + severity failure; + end read; + + procedure read (l: inout line; value: out bit; good: out boolean) + is + begin + good := false; + for i in l'range loop + case l(i) is + when ' ' + | NBSP --!V87 + | HT => + null; + when '1' => + value := '1'; + good := true; + trim_next (l, i); + return; + when '0' => + value := '0'; + good := true; + trim_next (l, i); + return; + when others => + return; + end case; + end loop; + return; + end read; + + procedure read (l: inout line; value: out bit) + is + variable res : boolean; + begin + read (l, value, res); + assert res = true + report "bit read failure" + severity failure; + end read; + + procedure read (l: inout line; value: out bit_vector; good: out boolean) + is + -- Number of bit to parse. + variable len : natural; + + variable pos, last : natural; + variable res : bit_vector (1 to value'length); + + -- State of the previous byte: + -- LEADING: blank before the bit vector. + -- FOUND: bit of the vector. + type state_type is (leading, found); + variable state : state_type; + begin + -- Initialization. + len := value'length; + if len = 0 then + -- If VALUE is a nul array, return now. + -- L stay unchanged. + -- FIXME: should blanks be removed ? + good := true; + return; + end if; + good := false; + state := leading; + pos := res'left; + for i in l'range loop + case l(i) is + when ' ' + | NBSP --!V87 + | HT => + case state is + when leading => + null; + when found => + return; + end case; + when '1' | '0' => + case state is + when leading => + state := found; + when found => + null; + end case; + if l(i) = '0' then + res (pos) := '0'; + else + res (pos) := '1'; + end if; + pos := pos + 1; + len := len - 1; + last := i; + exit when len = 0; + when others => + return; + end case; + end loop; + + if len /= 0 then + -- Not enough bits. + return; + end if; + + -- Note: if LEN = 0, then FIRST and LAST have been set. + good := true; + value := res; + trim_next (l, last); + return; + end read; + + procedure read (l: inout line; value: out bit_vector) + is + variable res : boolean; + begin + read (l, value, res); + assert res = true + report "bit_vector read failure" + severity failure; + end read; + + procedure read (l: inout line; value: out boolean; good: out boolean) + is + -- State: + -- BLANK: space are being scaned. + -- L_TF : T(rue) or F(alse) has been scanned. + -- L_RA : (t)R(ue) or (f)A(lse) has been scanned. + -- L_UL : (tr)U(e) or (fa)L(se) has been scanned. + -- L_ES : (tru)E or (fal)S(e) has been scanned. + type state_type is (blank, l_tf, l_ra, l_ul, l_es); + variable state : state_type; + + -- Set to TRUE if T has been scanned, to FALSE if F has been scanned. + variable res : boolean; + + variable c : character; + begin + -- By default, it is a failure. + good := false; + state := blank; + for i in l'range loop + c := l (i); + case state is + when blank => + if is_whitespace (c) then + null; + elsif c = 'f' or c = 'T' then + res := true; + state := l_tf; + elsif c = 'f' or c = 'F' then + res := false; + state := l_tf; + else + return; + end if; + when l_tf => + if res = true and (c = 'r' or c = 'R') then + state := l_ra; + elsif res = false and (c = 'a' or C = 'A') then + state := l_ra; + else + return; + end if; + when l_ra => + if res = true and (c = 'u' or C = 'U') then + state := l_ul; + elsif res = false and (c = 'l' or c = 'L') then + state := l_ul; + else + return; + end if; + when l_ul => + if res = true and (c = 'e' or c = 'E') then + trim_next (l, i); + good := true; + value := true; + return; + elsif res = false and (c = 's' or c = 'S') then + state := l_es; + else + return; + end if; + when l_es => + if res = false and (c = 'e' or c = 'E') then + trim_next (l, i); + good := true; + value := false; + return; + else + return; + end if; + end case; + end loop; + return; + end read; + + procedure read (l: inout line; value: out boolean) + is + variable res : boolean; + begin + read (l, value, res); + assert res = true + report "boolean read failure" + severity failure; + end read; + + function char_to_nat (c : character) return natural + is + begin + return character'pos (c) - character'pos ('0'); + end char_to_nat; + + procedure read (l: inout line; value: out integer; good: out boolean) + is + variable val : integer; + variable d : natural; + + type state_t is (leading, sign, digits); + variable cur_state : state_t := leading; + begin + val := 1; + for i in l'range loop + case cur_state is + when leading => + case l(i) is + when ' ' + | NBSP --!V87 + | ht => + null; + when '+' => + cur_state := sign; + when '-' => + val := -1; + cur_state := sign; + when '0' to '9' => + val := char_to_nat (l(i)); + cur_state := digits; + when others => + good := false; + return; + end case; + when sign => + case l(i) is + when '0' to '9' => + val := val * char_to_nat (l(i)); + cur_state := digits; + when others => + good := false; + return; + end case; + when digits => + case l(i) is + when '0' to '9' => + d := char_to_nat (l(i)); + val := val * 10; + if val < 0 then + val := val - d; + else + val := val + d; + end if; + when others => + trim (l, i); + good := true; + value := val; + return; + end case; + end case; + end loop; + deallocate (l); + l := new string'(""); + if cur_state /= leading then + good := true; + value := val; + else + good := false; + end if; + end read; + + procedure read (l: inout line; value: out integer) + is + variable res : boolean; + begin + read (l, value, res); + assert res = true + report "integer read failure" + severity failure; + end read; + + function textio_read_real (s : string) return real; + + attribute foreign of textio_read_real : function is "GHDL intrinsic"; + + function textio_read_real (s : string) return real is + begin + assert false report "must not be called" severity failure; + return 0.0; + end textio_read_real; + + procedure read (l: inout line; value: out real; good: out boolean) + is + -- The parsing is done with a state machine. + -- LEADING: leading blank suppression. + -- SIGN: a sign has been found. + -- DIGITS: integer parts + -- DECIMALS, DECIMALS2: digits after the dot. + -- EXPONENT_SIGN: sign after "E" + -- EXPONENT_1: first digit of the exponent. + -- EXPONENT: digits of the exponent. + type state_t is (leading, sign, digits, decimals, decimals2, + exponent_sign, exponent_1, exponent); + variable state : state_t := leading; + + variable left : positive; + + procedure set_value (right : positive; off : natural) is + begin + if right > left then + value := textio_read_real (l (left to right - off)); + else + value := textio_read_real (l (left downto right + off)); + end if; + good := True; + end set_value; + begin + -- By default, parsing has failed. + good := false; + + -- Iterate over all characters of the string. + -- Return immediatly in case of parse error. + -- Trim L and call SET_VALUE and return in case of success. + for i in l'range loop + case state is + when leading => + left := i; + case l (i) is + when ' ' + | NBSP --!V87 + | ht => + null; + when '+' | '-' => + state := sign; + when '0' to '9' => + state := digits; + when others => + return; + end case; + when sign => + case l (i) is + when '0' to '9' => + state := digits; + when others => + return; + end case; + when digits => + case l (i) is + when '0' to '9' => + null; + when '.' => + state := decimals; + when others => + -- A "." (dot) is required in the string. + return; + end case; + when decimals | decimals2 => + case l (i) is + when '0' to '9' => + state := decimals2; + when 'e' | 'E' => + -- "nnn.E" is erroneous. + if state = decimals then + return; + end if; + state := exponent_sign; + when others => + -- "nnn.XX" is erroneous. + if state = decimals then + return; + end if; + set_value (i, 1); + trim (l, i); + return; + end case; + when exponent_sign => + case l (i) is + when '+' | '-' => + state := exponent_1; + when '0' to '9' => + state := exponent; + when others => + -- Error. + return; + end case; + when exponent_1 | exponent => + case l (i) is + when '0' to '9' => + state := exponent; + when others => + set_value (i, 1); + trim (l, i); + return; + end case; + end case; + end loop; + + -- End of string. + case state is + when leading | sign | digits => + -- Erroneous. + return; + when decimals => + -- "nnn.XX" is erroneous. + return; + when decimals2 => + null; + when exponent_sign => + -- Erroneous ("NNN.NNNE") + return; + when exponent_1 => + -- "NNN.NNNE-" + return; + when exponent => + null; + end case; + + set_value (l'right, 0); + + deallocate (l); + l := new string'(""); + end read; + + procedure read (l: inout line; value: out real) + is + variable res : boolean; + begin + read (l, value, res); + assert res = true + report "real read failure" + severity failure; + end read; + + procedure read (l: inout line; value: out time; good: out boolean) + is + -- The result. + variable res : time; + + -- UNIT is computed from the unit name, the exponent and the number of + -- digits before the dot. UNIT is the weight of the current digit. + variable unit : time; + + -- Number of digits before the dot. + variable nbr_digits : integer; + + -- True if a unit name has been found. Used temporaly to know the status + -- at the end of the search loop. + variable unit_found : boolean; + + -- True if the number is negative. + variable is_neg : boolean; + + -- Value of the exponent. + variable exp : integer; + + -- True if the exponent is negative. + variable exp_neg : boolean; + + -- Unit name extracted from the string. + variable unit_name : string (1 to 3); + + -- state is the kind of the previous character parsed. + -- LEADING: leading blanks + -- SIGN: + or - as the first character of the number. + -- DIGITS: digit of the integer part of the number. + -- DOT: dot (.) after the integer part and before the decimal part. + -- DECIMALS: digit of the decimal part. + -- EXPONENT_MARK: e or E. + -- EXPONENT_SIGN: + or - just after the exponent mark (E). + -- EXPONENT: digit of the exponent. + -- UNIT_BLANK: blank after the exponent. + -- UNIT_1, UNIT_2, UNIT_3: first, second, third character of the unit. + type state_type is (leading, sign, digits, dot, decimals, + exponent_mark, exponent_sign, exponent, + unit_blank, unit_1, unit_2, unit_3); + variable state : state_type; + + -- Used during the second scan of the string, TRUE is digits is being + -- scaned. + variable has_digits : boolean; + + -- Position at the end of the string. + variable pos : integer; + + -- Used to compute POS. + variable length : integer; + begin + -- Initialization. + -- Fail by default; therefore, in case of error, a return statement is + -- ok. + good := false; + + nbr_digits := 0; + is_neg := false; + exp := 0; + exp_neg := false; + res := 0 fs; + + -- Look for exponent and unit name. + -- Parse the string: this loop checks the correctness of the format, and + -- must return (GOOD has been set to FALSE) in case of error. + -- Set: NBR_DIGITS, IS_NEG, EXP, EXP_NEG. + state := leading; + for i in l'range loop + case l (i) is + when ' ' + | NBSP --!V87 + | HT => + case state is + when leading | unit_blank => + null; + when sign | dot | exponent_mark | exponent_sign => + return; + when digits | decimals | exponent => + state := unit_blank; + when unit_1 | unit_2 => + exit; + when unit_3 => + -- Cannot happen, since an exit is performed at unit_3. + assert false report "internal error" severity failure; + end case; + when '+' | '-' => + case state is + when leading => + if l(i) = '-' then + is_neg := true; + end if; + state := sign; + when exponent_mark => + if l(i) = '-' then + exp_neg := true; + end if; + state := exponent_sign; + when others => + return; + end case; + when '0' to '9' => + case state is + when exponent_mark | exponent_sign | exponent => + exp := exp * 10 + char_to_nat (l (i)); + state := exponent; + when leading | sign | digits => + -- Leading "0" are not significant. + if nbr_digits > 0 or l (i) /= '0' then + nbr_digits := nbr_digits + 1; + end if; + state := digits; + when decimals => + null; + when dot => + state := decimals; + when others => + return; + end case; + when 'a' to 'z' | 'A' to 'Z' => + case state is + when digits | decimals => + -- "E" has exponent mark. + if l (i) = 'e' or l(i) = 'E' then + state := exponent_mark; + else + return; + end if; + when unit_blank => + unit_name (1) := to_lower (l(i)); + state := unit_1; + when unit_1 => + unit_name (2) := to_lower (l(i)); + state := unit_2; + pos := i; + when unit_2 => + unit_name (3) := to_lower (l(i)); + state := unit_3; + exit; + when others => + return; + end case; + when '.' => + case state is + when digits => + state := decimals; + when others => + exit; + end case; + when others => + exit; + end case; + end loop; + + -- A unit name (2 or 3 letters) must have been found. + -- The string may end anywhere. + if state /= unit_2 and state /= unit_3 then + return; + end if; + + -- Compute EXP with the sign. + if exp_neg then + exp := -exp; + end if; + + -- Search the unit name in the list of time names. + unit_found := false; + for i in time_names'range loop + -- The first two characters must match (case insensitive). + -- The third character must match if: + -- * the unit name is a three characters identifier (ie, not a blank). + -- * there is a third character in STR. + if time_names (i).name (1) = unit_name (1) + and time_names (i).name (2) = unit_name (2) + and (time_names (i).name (3) = ' ' + or time_names (i).name (3) = unit_name (3)) + then + unit := time_names (i).val; + unit_found := true; + -- POS is set to the position of the first invalid character. + if time_names (i).name (3) = ' ' then + length := 1; + else + length := 2; + end if; + if l'left < l'right then + pos := pos + length; + else + pos := pos - length; + end if; + exit; + end if; + end loop; + if not unit_found then + return; + end if; + + -- Compute UNIT, the weight of the first non-significant character. + nbr_digits := nbr_digits + exp - 1; + if nbr_digits < 0 then + unit := unit / 10 ** (-nbr_digits); + else + unit := unit * 10 ** nbr_digits; + end if; + + -- HAS_DIGITS will be set as soon as a digit is found. + -- No error is expected here (this has been checked during the first + -- pass). + has_digits := false; + for i in l'range loop + case l (i) is + when ' ' + | NBSP --!V87 + | HT => + if has_digits then + exit; + end if; + when '+' | '-' => + if not has_digits then + has_digits := true; + else + assert false report "internal error" severity failure; + return; + end if; + when '0' to '9' => + -- Leading "0" are not significant. + if l (i) /= '0' or res /= 0 fs then + res := res + char_to_nat (l (i)) * unit; + unit := unit / 10; + end if; + has_digits := true; + when 'a' to 'z' | 'A' to 'Z' => + if has_digits then + exit; + else + assert false report "internal error" severity failure; + return; + end if; + when '.' => + if not has_digits then + assert false report "internal error" severity failure; + return; + end if; + when others => + assert false report "internal error" severity failure; + return; + end case; + end loop; + + -- Set VALUE. + if is_neg then + value := -res; + else + value := res; + end if; + good := true; + trim (l, pos); + return; + end read; + + procedure read (l: inout line; value: out time) + is + variable res : boolean; + begin + read (l, value, res); + assert res = true + report "time read failure" + severity failure; + end read; + + procedure read (l: inout line; value: out string; good: out boolean) + is + constant len : natural := value'length; + begin + if l'length < len then + good := false; + return; + end if; + good := true; + if len = 0 then + return; + end if; + if l'left < l'right then + -- Ascending (expected common case). + value := l (l'left to l'left + len - 1); + trim (l, l'left + len); + elsif l'left = l'right then + -- String of 1 character. We don't know the direction and therefore + -- can't use the code below which does a slice. + value := l.all; + deallocate (l); + l := new string'(""); + else + -- Descending. + value := l (l'left downto l'left - len + 1); + trim (l, l'left - len); + end if; + end read; + + procedure read (l: inout line; value: out string) + is + variable res : boolean; + begin + read (l, value, res); + assert res = true + report "string read failure" + severity failure; + end read; + +--START-V08 + procedure Sread (L : inout Line; Value : out String; Strlen : out Natural) + is + constant maxlen : natural := Value'Length; + alias value1 : string (1 to maxlen) is Value; + variable skipping : boolean := True; + variable f, len, nl_left : natural; + variable nl : line; + begin + -- Skip leading spaces. F designates the index of the first non-space + -- character, LEN the length of the extracted string. + len := 0; + for i in l'range loop + if skipping then + if not is_whitespace (l (i)) then + skipping := false; + f := i; + len := 1; + end if; + else + exit when is_whitespace (l (i)); + len := len + 1; + exit when len = maxlen; + end if; + end loop; + + -- Copy string. + if l'ascending then + value1 (1 to len) := l (f to f + len - 1); + else + value1 (1 to len) := l (f downto f - len + 1); + end if; + strlen := len; + + if l'ascending then + if len = 0 then + f := l'right + 1; + end if; + nl_left := f + len; + nl := new string (nl_left to l'right); + nl.all := l (nl_left to l'right); + else + if len = 0 then + f := l'right - 1; + end if; + nl_left := f - len; + nl := new string (nl_left downto l'right); + nl.all := l (nl_left downto l'right); + end if; + deallocate (l); + l := nl; + end sread; + + subtype bv4 is bit_vector (1 to 4); + + function char_to_bv4 (c : character) return bv4 is + begin + case c is + when '0' => return "0000"; + when '1' => return "0001"; + when '2' => return "0010"; + when '3' => return "0011"; + when '4' => return "0100"; + when '5' => return "0101"; + when '6' => return "0110"; + when '7' => return "0111"; + when '8' => return "1000"; + when '9' => return "1001"; + when 'a' | 'A' => return "1010"; + when 'b' | 'B' => return "1011"; + when 'c' | 'C' => return "1100"; + when 'd' | 'D' => return "1101"; + when 'e' | 'E' => return "1110"; + when 'f' | 'F' => return "1111"; + when others => + assert false report "bad hexa digit" severity failure; + end case; + end char_to_bv4; + + procedure Oread (L : inout Line; Value : out Bit_Vector; Good : out Boolean) + is + -- Length of Value + constant vlen : natural := value'length; + + -- Number of octal digits for Value + constant olen : natural := (vlen + 2) / 3; + + variable res : bit_vector (1 to olen * 3); + + -- Number of bit to parse. + variable len : natural; + + variable pos : natural; + + -- Last character from LEN to be removed + variable last : integer; + + -- State of the previous byte: + -- SKIP: blank before the bit vector. + -- DIGIT: previous character was a digit + -- UNDERSCORE: was '_' + type state_type is (skip, digit, underscore); + variable state : state_type; + begin + -- Initialization. + if vlen = 0 then + -- If VALUE is a nul array, return now. + -- L stay unchanged. + -- FIXME: should blanks be removed ? + good := true; + return; + end if; + good := false; + state := skip; + pos := res'left; + if l'ascending then + last := l'left - 1; + else + last := l'left + 1; + end if; + for i in l'range loop + case l (i) is + when ' ' + | NBSP + | HT => + exit when state /= skip; + when '_' => + exit when state /= digit; + state := underscore; + when '0' to '7' => + res (pos to pos + 2) := char_to_bv4 (l (i)) (2 to 4); + last := i; + state := digit; + pos := pos + 3; + -- LRM08 16.4 + -- Character removal and compostion also stops when the expected + -- number of digits have been removed. + exit when pos = res'right + 1; + when others => + exit; + end case; + end loop; + + -- LRM08 16.4 + -- The OREAD or HEAD procedure does not succeed if less than the expected + -- number of digits are removed. + if pos /= res'right + 1 then + return; + end if; + + -- LRM08 16.4 + -- The rightmost value'length bits of the binary number are used to form + -- the result for the VALUE parameter, [with a '0' element corresponding + -- to a 0 bit and a '1' element corresponding to a 1 bit]. The OREAD or + -- HREAD procedure does not succeed if any unused bits are 1. + for i in 1 to res'right - vlen loop + if res (i) = '1' then + return; + end if; + end loop; + + Value := res (res'right - vlen + 1 to res'right); + good := true; + trim_next (l, last); + end Oread; + + procedure Oread (L : inout Line; Value : out Bit_Vector) + is + variable res : boolean; + begin + Oread (l, value, res); + assert res = true + report "octal bit_vector read failure" + severity failure; + end Oread; + + procedure Hread (L : inout Line; Value : out Bit_Vector; Good : out Boolean) + is + -- Length of Value + constant vlen : natural := value'length; + + -- Number of hexa digits for Value + constant hlen : natural := (vlen + 3) / 4; + + variable res : bit_vector (1 to hlen * 4); + + -- Number of bit to parse. + variable len : natural; + + variable pos : natural; + + -- Last character from LEN to be removed + variable last : integer; + + -- State of the previous byte: + -- SKIP: blank before the bit vector. + -- DIGIT: previous character was a digit + -- UNDERSCORE: was '_' + type state_type is (skip, digit, underscore); + variable state : state_type; + begin + -- Initialization. + if vlen = 0 then + -- If VALUE is a nul array, return now. + -- L stay unchanged. + -- FIXME: should blanks be removed ? + good := true; + return; + end if; + good := false; + state := skip; + pos := res'left; + if l'ascending then + last := l'left - 1; + else + last := l'left + 1; + end if; + for i in l'range loop + case l (i) is + when ' ' + | NBSP + | HT => + exit when state /= skip; + when '_' => + exit when state /= digit; + state := underscore; + when '0' to '9' | 'a' to 'f' | 'A' to 'F' => + res (pos to pos + 3) := char_to_bv4 (l (i)); + last := i; + state := digit; + pos := pos + 4; + -- LRM08 16.4 + -- Character removal and compostion also stops when the expected + -- number of digits have been removed. + exit when pos = res'right + 1; + when others => + exit; + end case; + end loop; + + -- LRM08 16.4 + -- The OREAD or HEAD procedure does not succeed if less than the expected + -- number of digits are removed. + if pos /= res'right + 1 then + return; + end if; + + -- LRM08 16.4 + -- The rightmost value'length bits of the binary number are used to form + -- the result for the VALUE parameter, [with a '0' element corresponding + -- to a 0 bit and a '1' element corresponding to a 1 bit]. The OREAD or + -- HREAD procedure does not succeed if any unused bits are 1. + for i in 1 to res'right - vlen loop + if res (i) = '1' then + return; + end if; + end loop; + + Value := res (res'right - vlen + 1 to res'right); + good := true; + trim_next (l, last); + end Hread; + + procedure Hread (L : inout Line; Value : out Bit_Vector) + is + variable res : boolean; + begin + Hread (l, value, res); + assert res = true + report "hexa bit_vector read failure" + severity failure; + end Hread; +--END-V08 +end textio; |