From 3e7ea99b431504dec539a63ec1e9b4ec1ecf4434 Mon Sep 17 00:00:00 2001 From: Ronan Desplanques Date: Tue, 7 Oct 2025 15:04:46 +0200 Subject: [PATCH] ada: Make Long_Long_Float'Write deterministic 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. --- 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.47.3