From f4689c2660cb26e341f79f8104d46c808427f6c0 Mon Sep 17 00:00:00 2001 From: Tristan Gingold Date: Wed, 24 Apr 2019 20:45:17 +0200 Subject: libraries: rename _body files. Fix #699 --- libraries/std/env-body.vhdl | 65 ++ libraries/std/env_body.vhdl | 65 -- libraries/std/textio-body.vhdl | 1558 ++++++++++++++++++++++++++++++++++++++++ libraries/std/textio_body.vhdl | 1558 ---------------------------------------- 4 files changed, 1623 insertions(+), 1623 deletions(-) create mode 100644 libraries/std/env-body.vhdl delete mode 100644 libraries/std/env_body.vhdl create mode 100644 libraries/std/textio-body.vhdl delete mode 100644 libraries/std/textio_body.vhdl (limited to 'libraries/std') diff --git a/libraries/std/env-body.vhdl b/libraries/std/env-body.vhdl new file mode 100644 index 000000000..d36519fc9 --- /dev/null +++ b/libraries/std/env-body.vhdl @@ -0,0 +1,65 @@ +-- Std.Env package declaration. This file is part of GHDL. +-- This file was written from the clause 14.3 of the VHDL LRM. +-- Copyright (C) 2014 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 Env is + procedure control_simulation (Is_Stop : Boolean; + Has_Status : Boolean; + Status : Integer); + attribute foreign of control_simulation : procedure is "GHDL intrinsic"; + + procedure control_simulation (Is_Stop : Boolean; + Has_Status : Boolean; + Status : Integer) is + begin + assert false report "must not be called" severity failure; + end control_simulation; + + procedure Stop (Status : Integer) is + begin + control_simulation (True, True, Status); + end Stop; + + procedure Stop is + begin + control_simulation (True, False, -1); + end Stop; + + procedure Finish (status : integer) is + begin + control_simulation (False, True, Status); + end Finish; + + procedure Finish is + begin + control_simulation (False, False, -1); + end Finish; + + function Get_Resolution_Limit return Delay_Length; + attribute foreign of Get_Resolution_Limit : function is "GHDL intrinsic"; + + function Get_Resolution_Limit return Delay_Length is + begin + assert false report "must not be called" severity failure; + end Get_Resolution_Limit; + + function Resolution_Limit return Delay_Length is + begin + return Get_Resolution_Limit; + end Resolution_Limit; +end package body Env; diff --git a/libraries/std/env_body.vhdl b/libraries/std/env_body.vhdl deleted file mode 100644 index d36519fc9..000000000 --- a/libraries/std/env_body.vhdl +++ /dev/null @@ -1,65 +0,0 @@ --- Std.Env package declaration. This file is part of GHDL. --- This file was written from the clause 14.3 of the VHDL LRM. --- Copyright (C) 2014 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 Env is - procedure control_simulation (Is_Stop : Boolean; - Has_Status : Boolean; - Status : Integer); - attribute foreign of control_simulation : procedure is "GHDL intrinsic"; - - procedure control_simulation (Is_Stop : Boolean; - Has_Status : Boolean; - Status : Integer) is - begin - assert false report "must not be called" severity failure; - end control_simulation; - - procedure Stop (Status : Integer) is - begin - control_simulation (True, True, Status); - end Stop; - - procedure Stop is - begin - control_simulation (True, False, -1); - end Stop; - - procedure Finish (status : integer) is - begin - control_simulation (False, True, Status); - end Finish; - - procedure Finish is - begin - control_simulation (False, False, -1); - end Finish; - - function Get_Resolution_Limit return Delay_Length; - attribute foreign of Get_Resolution_Limit : function is "GHDL intrinsic"; - - function Get_Resolution_Limit return Delay_Length is - begin - assert false report "must not be called" severity failure; - end Get_Resolution_Limit; - - function Resolution_Limit return Delay_Length is - begin - return Get_Resolution_Limit; - end Resolution_Limit; -end package body Env; 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 +-- . + +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; diff --git a/libraries/std/textio_body.vhdl b/libraries/std/textio_body.vhdl deleted file mode 100644 index d01cb8bad..000000000 --- a/libraries/std/textio_body.vhdl +++ /dev/null @@ -1,1558 +0,0 @@ --- 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 --- . - -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; -- cgit v1.2.3