From: Ronan Desplanques <[email protected]>
On some platforms, Long_Long_Float'Size (and Long_Long_Float'Stream_Size)
is 128 but only 80 bits are effectively used. This pack makes it so
'Write in this case write zeros for the padding bits instead of
unspecified values.
gcc/ada/ChangeLog:
* gen_il-fields.ads (Is_IEEE_Extended_Precision): New flag.
* gen_il-gen-gen_entities.adb: Likewise.
* gen_il-internals.adb (Image): Likewise.
* treepr.adb (Image): Likewise.
* einfo.ads: Document new flag.
* cstand.adb (Copy_Float_Type, Register_Float_Type): Use new flag.
* libgnat/s-stratt.ads (W_80IEEE): New procedure.
* libgnat/s-stratt.adb (W_80IEEE): Likewise.
* exp_strm.adb (Get_Primitives): Select new procedure when
appropriate.
* rtsfind.ads: Register new runtime procedure.
* sem_ch3.adb (Build_Derived_Numeric_Type,
Analyze_Subtype_Declaration): Propagate new flag.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/cstand.adb | 12 +++++++++---
gcc/ada/einfo.ads | 10 ++++++++++
gcc/ada/exp_strm.adb | 8 ++++++++
gcc/ada/gen_il-fields.ads | 1 +
gcc/ada/gen_il-gen-gen_entities.adb | 3 ++-
gcc/ada/gen_il-internals.adb | 2 ++
gcc/ada/libgnat/s-stratt.adb | 17 +++++++++++++++++
gcc/ada/libgnat/s-stratt.ads | 2 ++
gcc/ada/rtsfind.ads | 2 ++
gcc/ada/sem_ch3.adb | 6 ++++++
gcc/ada/treepr.adb | 2 ++
11 files changed, 61 insertions(+), 4 deletions(-)
diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb
index cdf2b5d6c30..8dd169a0dba 100644
--- a/gcc/ada/cstand.adb
+++ b/gcc/ada/cstand.adb
@@ -298,6 +298,7 @@ package body CStand is
Build_Float_Type
(To, UI_To_Int (Digits_Value (From)), Float_Rep (From),
UI_To_Int (Esize (From)), UI_To_Int (Alignment (From)));
+ Set_Is_IEEE_Extended_Precision (To, Is_IEEE_Extended_Precision (From));
end Copy_Float_Type;
----------------------
@@ -2100,17 +2101,22 @@ package body CStand is
Size : Positive;
Alignment : Natural)
is
- pragma Unreferenced (Precision);
- -- See Build_Float_Type for the rationale
-
Ent : constant Entity_Id := New_Standard_Entity (Name);
+ IEEE_Extended_Precision_Size : constant := 80;
begin
Set_Defining_Identifier (New_Node (N_Full_Type_Declaration, Stloc), Ent);
Set_Scope (Ent, Standard_Standard);
Build_Float_Type
(Ent, Pos (Digs), Float_Rep, Int (Size), Nat (Alignment / 8));
+ -- We mostly disregard Precision, see Build_Float_Type for the
+ -- rationale. The only thing we use it for is to detect 80-bit IEEE
+ -- extended precision, in order to adjust the behavior of 'Write.
+ if Precision = IEEE_Extended_Precision_Size then
+ Set_Is_IEEE_Extended_Precision (Ent);
+ end if;
+
Append_New_Elmt (Ent, Back_End_Float_Types);
end Register_Float_Type;
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index b9548a78f84..cd00fe265e1 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -3552,6 +3552,15 @@ package Einfo is
-- a wrapper to handle inherited class-wide pre/post conditions that call
-- overridden primitives or as a wrapper of a controlling function.
+-- Is_IEEE_Extended_Precision
+-- Defined in floating point types and subtypes. Indicates that the type
+-- corresponds to the 80-bit IEEE extended precision format. That format
+-- effectively uses 80 bits per value, but we set its Size to a larger
+-- value for the reasons explained in the documentation comment of
+-- Build_Float_Type. We also perform some extra work to consistently set
+-- the extra bits to zero in the 'Write implementation, which is why we
+-- need this flag.
+
-- Itype_Printed
-- Defined in all type and subtype entities. Set in Itypes if the Itype
-- has been printed by Sprint. This is used to avoid printing an Itype
@@ -5529,6 +5538,7 @@ package Einfo is
-- Digits_Value
-- Float_Rep (Float_Rep_Kind)
-- Default_Aspect_Value (base type only)
+ -- Is_IEEE_Extended_Precision
-- Scalar_Range
-- Static_Real_Or_String_Predicate
-- Machine_Emax_Value (synth)
diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb
index 3bb6966dc1c..f933a2e425f 100644
--- a/gcc/ada/exp_strm.adb
+++ b/gcc/ada/exp_strm.adb
@@ -501,6 +501,14 @@ package body Exp_Strm is
then
return Prims (RE_I_LF, RE_W_LF);
+ elsif Is_IEEE_Extended_Precision (U_Type) then
+ -- For 80-bit IEEE extended precision values, we use a special
+ -- write routine that sets the unused bytes to zero. The reason
+ -- why we don't set Stream_Size to 80 and stream only the
+ -- meaningful bits is that the user is allowed to select the XDR
+ -- implementation of streaming at bind time, and XDR does not
+ -- allow 80 bits floating point values.
+ return Prims (RE_I_LLF, RE_W_80IEEE);
elsif P_Size = Standard_Long_Long_Float_Size then
return Prims (RE_I_LLF, RE_W_LLF);
else
diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads
index 6cd1355d119..5e954186e05 100644
--- a/gcc/ada/gen_il-fields.ads
+++ b/gcc/ada/gen_il-fields.ads
@@ -818,6 +818,7 @@ package Gen_IL.Fields is
Is_Volatile_Object,
Is_Volatile_Full_Access,
Is_Wrapper,
+ Is_IEEE_Extended_Precision,
Itype_Printed,
Kill_Elaboration_Checks,
Known_To_Have_Preelab_Init,
diff --git a/gcc/ada/gen_il-gen-gen_entities.adb
b/gcc/ada/gen_il-gen-gen_entities.adb
index bd091cbe823..95b172ad5f1 100644
--- a/gcc/ada/gen_il-gen-gen_entities.adb
+++ b/gcc/ada/gen_il-gen-gen_entities.adb
@@ -630,7 +630,8 @@ begin -- Gen_IL.Gen.Gen_Entities
-- first named subtype).
Ab (Float_Kind, Real_Kind,
- (Sm (Digits_Value, Upos)));
+ (Sm (Digits_Value, Upos),
+ Sm (Is_IEEE_Extended_Precision, Flag)));
Cc (E_Floating_Point_Type, Float_Kind);
-- Floating point type, used for the anonymous base type of the
diff --git a/gcc/ada/gen_il-internals.adb b/gcc/ada/gen_il-internals.adb
index 77685f25c6a..bd2d4804c52 100644
--- a/gcc/ada/gen_il-internals.adb
+++ b/gcc/ada/gen_il-internals.adb
@@ -311,6 +311,8 @@ package body Gen_IL.Internals is
return "Is_Elaboration_Warnings_OK_Id";
when Is_Elaboration_Warnings_OK_Node =>
return "Is_Elaboration_Warnings_OK_Node";
+ when Is_IEEE_Extended_Precision =>
+ return "Is_IEEE_Extended_Precision";
when Is_Known_Guaranteed_ABE =>
return "Is_Known_Guaranteed_ABE";
when Is_RACW_Stub_Type =>
diff --git a/gcc/ada/libgnat/s-stratt.adb b/gcc/ada/libgnat/s-stratt.adb
index 844c530af3d..61bfa38f638 100644
--- a/gcc/ada/libgnat/s-stratt.adb
+++ b/gcc/ada/libgnat/s-stratt.adb
@@ -1036,4 +1036,21 @@ package body System.Stream_Attributes is
Ada.Streams.Write (Stream.all, From_WWC (Item));
end W_WWC;
+ N_IEEE_Extended_Precision_Bytes : constant := 10;
+
+ procedure W_80IEEE (Stream : not null access RST; Item : Long_Long_Float) is
+ begin
+ if XDR_Support then
+ XDR.W_LLF (Stream, Item);
+ return;
+ end if;
+
+ declare
+ X : S_LLF := From_LLF (Item);
+ begin
+ X (N_IEEE_Extended_Precision_Bytes + 1 .. X'Last) := (others => 0);
+ Ada.Streams.Write (Stream.all, X);
+ end;
+ end W_80IEEE;
+
end System.Stream_Attributes;
diff --git a/gcc/ada/libgnat/s-stratt.ads b/gcc/ada/libgnat/s-stratt.ads
index 87f1357caaa..9f27f5a8198 100644
--- a/gcc/ada/libgnat/s-stratt.ads
+++ b/gcc/ada/libgnat/s-stratt.ads
@@ -171,6 +171,8 @@ package System.Stream_Attributes is
procedure W_WC (Stream : not null access RST; Item : Wide_Character);
procedure W_WWC (Stream : not null access RST; Item : Wide_Wide_Character);
+ procedure W_80IEEE (Stream : not null access RST; Item : Long_Long_Float);
+
function Block_IO_OK return Boolean;
-- Indicate whether the current setting supports block IO. See
-- System.Strings.Stream_Ops (s-ststop) for details on block IO.
diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads
index c82af1154fe..ee529e122ab 100644
--- a/gcc/ada/rtsfind.ads
+++ b/gcc/ada/rtsfind.ads
@@ -1900,6 +1900,7 @@ package Rtsfind is
RE_W_U24, -- System.Stream_Attributes
RE_W_WC, -- System.Stream_Attributes
RE_W_WWC, -- System.Stream_Attributes
+ RE_W_80IEEE, -- System.Stream_Attributes
RE_Storage_Array_Input, -- System.Strings.Stream_Ops
RE_Storage_Array_Input_Blk_IO, -- System.Strings.Stream_Ops
@@ -3565,6 +3566,7 @@ package Rtsfind is
RE_W_U24 => System_Stream_Attributes,
RE_W_WC => System_Stream_Attributes,
RE_W_WWC => System_Stream_Attributes,
+ RE_W_80IEEE => System_Stream_Attributes,
RE_Storage_Array_Input => System_Strings_Stream_Ops,
RE_Storage_Array_Input_Blk_IO => System_Strings_Stream_Ops,
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 79986bb48c5..2a42d89d971 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -5944,6 +5944,8 @@ package body Sem_Ch3 is
Set_Scalar_Range (Id, Scalar_Range (T));
Set_Digits_Value (Id, Digits_Value (T));
Set_Is_Constrained (Id, Is_Constrained (T));
+ Set_Is_IEEE_Extended_Precision
+ (Id, Is_IEEE_Extended_Precision (T));
-- If the floating point type has dimensions, these will be
-- inherited subsequently when Analyze_Dimensions is called.
@@ -8206,10 +8208,14 @@ package body Sem_Ch3 is
Set_Digits_Value (Implicit_Base, Digits_Value (Parent_Base));
Set_Float_Rep (Implicit_Base, Float_Rep (Parent_Base));
+ Set_Is_IEEE_Extended_Precision
+ (Implicit_Base, Is_IEEE_Extended_Precision (Parent_Base));
if No_Constraint then
Set_Digits_Value (Derived_Type, Digits_Value (Parent_Type));
end if;
+ Set_Is_IEEE_Extended_Precision
+ (Derived_Type, Is_IEEE_Extended_Precision (Parent_Base));
elsif Is_Fixed_Point_Type (Parent_Type) then
diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb
index fbad71a3765..9d789879f11 100644
--- a/gcc/ada/treepr.adb
+++ b/gcc/ada/treepr.adb
@@ -338,6 +338,8 @@ package body Treepr is
return "Is_Elaboration_Checks_OK_Id";
when F_Is_Elaboration_Warnings_OK_Id =>
return "Is_Elaboration_Warnings_OK_Id";
+ when F_Is_IEEE_Extended_Precision =>
+ return "Is_IEEE_Extended_Precision";
when F_Is_RACW_Stub_Type =>
return "Is_RACW_Stub_Type";
when F_LSP_Subprogram =>
--
2.51.0
