aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--libraries/std/textio_body.vhdl144
-rw-r--r--src/ghdldrv/ghdlrun.adb2
-rw-r--r--src/grt/grt-files.ads3
-rw-r--r--src/grt/grt-lib.adb21
-rw-r--r--src/grt/grt-lib.ads7
-rw-r--r--src/grt/grt-types.ads3
-rw-r--r--src/std_names.adb1
-rw-r--r--src/std_names.ads5
8 files changed, 53 insertions, 133 deletions
diff --git a/libraries/std/textio_body.vhdl b/libraries/std/textio_body.vhdl
index 823b4b67e..36a11fc23 100644
--- a/libraries/std/textio_body.vhdl
+++ b/libraries/std/textio_body.vhdl
@@ -16,6 +16,8 @@
-- <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
@@ -334,6 +336,17 @@ package body textio is
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
@@ -350,133 +363,12 @@ package body textio is
-- STR contains the result of the conversion.
variable str : string (1 to 320);
- -- POS is the index of the next character to be put in STR.
- variable pos : positive := str'left;
-
- -- VAL contains the value to be converted.
- variable val : real;
-
- -- The exponent or mantissa computed is stored in MANTISSA. This is
- -- a signed number.
- variable mantissa : integer;
-
- variable b : boolean;
- variable d : natural;
-
- -- Append character C in STR.
- procedure add_char (c : character) is
- begin
- str (pos) := c;
- pos := pos + 1;
- end add_char;
-
- -- Add digit V in STR.
- procedure add_digit (v : natural) is
- begin
- add_char (character'val (character'pos ('0') + v));
- end add_digit;
-
- -- Add leading digit and substract it.
- procedure extract_leading_digit is
- variable d : natural range 0 to 10;
- begin
- -- Note: We need truncation but type conversion does rounding.
- -- FIXME: should consider precision.
- d := natural (val);
- if real (d) > val then
- d := d - 1;
- end if;
-
- val := (val - real (d)) * 10.0;
-
- add_digit (d);
- end extract_leading_digit;
+ variable len : natural;
begin
- -- Handle sign.
- -- There is no overflow here, since with IEEE implementations, sign is
- -- independant of the mantissa.
- -- LRM93 14.3
- -- The sign is never written if the value is non-negative.
- if value < 0.0 then
- add_char ('-');
- val := -value;
- else
- val := value;
- end if;
-
- -- Compute the mantissa.
- -- FIXME: should do a dichotomy.
- if val = 0.0 then
- mantissa := 0;
- elsif val < 1.0 then
- mantissa := -1;
- while val * (10.0 ** (-mantissa)) < 1.0 loop
- mantissa := mantissa - 1;
- end loop;
- else
- mantissa := 0;
- while val / (10.0 ** mantissa) >= 10.0 loop
- mantissa := mantissa + 1;
- end loop;
- end if;
-
- -- Normalize VAL: in [0; 10[
- if mantissa >= 0 then
- val := val / (10.0 ** mantissa);
- else
- val := val * 10.0 ** (-mantissa);
- end if;
-
- if digits = 0 then
- for i in 0 to 15 loop
- extract_leading_digit;
-
- if i = 0 then
- add_char ('.');
- end if;
- exit when i > 0 and val < 10.0 ** (i + 1 - 15);
- end loop;
+ textio_write_real (str, len, value, digits);
+ assert len <= str'length severity failure;
- -- LRM93 14.3
- -- if the exponent is present, the `e' is written as a lower case
- -- character.
- add_char ('e');
-
- if mantissa < 0 then
- add_char ('-');
- mantissa := -mantissa;
- end if;
- b := false;
- for i in 4 downto 0 loop
- d := (mantissa / 10000) mod 10;
- if d /= 0 or b or i = 0 then
- add_digit (d);
- b := true;
- end if;
- mantissa := (mantissa - d * 10000) * 10;
- end loop;
- else
- if mantissa < 0 then
- add_char ('0');
- mantissa := mantissa + 1;
- else
- loop
- extract_leading_digit;
- exit when mantissa = 0;
- mantissa := mantissa - 1;
- end loop;
- end if;
- add_char ('.');
- for i in 1 to digits loop
- if mantissa = 0 then
- extract_leading_digit;
- else
- add_char ('0');
- mantissa := mantissa + 1;
- end if;
- end loop;
- end if;
- write (l, str (1 to pos - 1), justified, field);
+ write (l, str (1 to len), justified, field);
end write;
--START-V08
@@ -493,8 +385,6 @@ package body textio is
end Hwrite;
--END-V08
- attribute foreign : string; --V87
-
procedure untruncated_text_read --V87
(variable f : text; str : out string; len : out natural); --V87
procedure untruncated_text_read --!V87
diff --git a/src/ghdldrv/ghdlrun.adb b/src/ghdldrv/ghdlrun.adb
index 6e2351343..55165fac4 100644
--- a/src/ghdldrv/ghdlrun.adb
+++ b/src/ghdldrv/ghdlrun.adb
@@ -189,6 +189,8 @@ package body Ghdlrun is
Def (Ortho, Grt.Files.Ghdl_Untruncated_Text_Read'Address);
elsif Name = "textio_read_real" then
Def (Ortho, Grt.Lib.Textio_Read_Real'Address);
+ elsif Name = "textio_write_real" then
+ Def (Ortho, Grt.Lib.Textio_Write_Real'Address);
elsif Name = "control_simulation" then
Def (Ortho, Grt.Lib.Ghdl_Control_Simulation'Address);
elsif Name = "get_resolution_limit" then
diff --git a/src/grt/grt-files.ads b/src/grt/grt-files.ads
index 3c6191f36..e5c797ec9 100644
--- a/src/grt/grt-files.ads
+++ b/src/grt/grt-files.ads
@@ -75,9 +75,6 @@ package Grt.Files is
function Ghdl_Text_Read_Length
(File : Ghdl_File_Index; Str : Std_String_Ptr) return Std_Integer;
- type Std_Integer_Acc is access Std_Integer;
- pragma Convention (C, Std_Integer_Acc);
-
procedure Ghdl_Untruncated_Text_Read
(File : Ghdl_File_Index; Str : Std_String_Ptr; Len : Std_Integer_Acc);
diff --git a/src/grt/grt-lib.adb b/src/grt/grt-lib.adb
index 3c16392be..9aa3558cc 100644
--- a/src/grt/grt-lib.adb
+++ b/src/grt/grt-lib.adb
@@ -22,6 +22,8 @@
-- covered by the GNU General Public License. This exception does not
-- however invalidate any other reasons why the executable file might be
-- covered by the GNU Public License.
+
+with Interfaces;
with Grt.Errors; use Grt.Errors;
with Grt.Options;
with Grt.Fcvt;
@@ -277,9 +279,26 @@ package body Grt.Lib is
subtype Str1 is String (1 .. Natural (Str.Bounds.Dim_1.Length));
begin
return Ghdl_F64 (Grt.Fcvt.From_String
- (Str1 (Str.Base (0 .. Str.Bounds.Dim_1.Length))));
+ (Str1 (Str.Base (0 .. Str.Bounds.Dim_1.Length - 1))));
end Textio_Read_Real;
+ procedure Textio_Write_Real (Str : Std_String_Ptr;
+ Len : Std_Integer_Acc;
+ V : Ghdl_F64;
+ Ndigits : Std_Integer)
+ is
+ -- FIXME: avoid that copy.
+ S : String (1 .. Natural (Str.Bounds.Dim_1.Length));
+ Last : Natural;
+ begin
+ Grt.Fcvt.Format_Digits
+ (S, Last, Interfaces.IEEE_Float_64 (V), Natural (Ndigits));
+ Len.all := Std_Integer (Last);
+ for I in 1 .. Last loop
+ Str.Base (Ghdl_Index_Type (I - 1)) := S (I);
+ end loop;
+ end Textio_Write_Real;
+
function Ghdl_Get_Resolution_Limit return Std_Time is
begin
return 1;
diff --git a/src/grt/grt-lib.ads b/src/grt/grt-lib.ads
index 97ee669a8..6e01ea9de 100644
--- a/src/grt/grt-lib.ads
+++ b/src/grt/grt-lib.ads
@@ -94,6 +94,11 @@ package Grt.Lib is
function Textio_Read_Real (Str : Std_String_Ptr) return Ghdl_F64;
+ procedure Textio_Write_Real (Str : Std_String_Ptr;
+ Len : Std_Integer_Acc;
+ V : Ghdl_F64;
+ Ndigits : Std_Integer);
+
function Ghdl_Get_Resolution_Limit return Std_Time;
procedure Ghdl_Control_Simulation
@@ -124,6 +129,8 @@ private
pragma Export (C, Textio_Read_Real,
"std__textio__textio_read_real");
+ pragma Export (C, Textio_Write_Real,
+ "std__textio__textio_write_real");
pragma Export (C, Ghdl_Get_Resolution_Limit,
"std__env__get_resolution_limit");
diff --git a/src/grt/grt-types.ads b/src/grt/grt-types.ads
index 5fb60f2d5..d9b17f67e 100644
--- a/src/grt/grt-types.ads
+++ b/src/grt/grt-types.ads
@@ -55,6 +55,9 @@ package Grt.Types is
subtype Std_Integer is Ghdl_I32;
+ type Std_Integer_Acc is access Std_Integer;
+ pragma Convention (C, Std_Integer_Acc);
+
type Std_Time is new Ghdl_I64;
Bad_Time : constant Std_Time := Std_Time'First;
diff --git a/src/std_names.adb b/src/std_names.adb
index 60d96d4f4..4e2f05f04 100644
--- a/src/std_names.adb
+++ b/src/std_names.adb
@@ -399,6 +399,7 @@ package body Std_Names is
Def ("maximum", Name_Maximum);
Def ("untruncated_text_read", Name_Untruncated_Text_Read);
Def ("textio_read_real", Name_Textio_Read_Real);
+ Def ("textio_write_real", Name_Textio_Write_Real);
Def ("get_resolution_limit", Name_Get_Resolution_Limit);
Def ("control_simulation", Name_Control_Simulation);
diff --git a/src/std_names.ads b/src/std_names.ads
index 0dc3143f3..2f75e8b0e 100644
--- a/src/std_names.ads
+++ b/src/std_names.ads
@@ -473,8 +473,9 @@ package Std_Names is
Name_Maximum : constant Name_Id := Name_First_Misc + 023;
Name_Untruncated_Text_Read : constant Name_Id := Name_First_Misc + 024;
Name_Textio_Read_Real : constant Name_Id := Name_First_Misc + 025;
- Name_Get_Resolution_Limit : constant Name_Id := Name_First_Misc + 026;
- Name_Control_Simulation : constant Name_Id := Name_First_Misc + 027;
+ Name_Textio_Write_Real : constant Name_Id := Name_First_Misc + 026;
+ Name_Get_Resolution_Limit : constant Name_Id := Name_First_Misc + 027;
+ Name_Control_Simulation : constant Name_Id := Name_First_Misc + 028;
Name_Last_Misc : constant Name_Id := Name_Control_Simulation;
Name_First_Ieee : constant Name_Id := Name_Last_Misc + 1;
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-16 08:43:41 +0000