From c324c77eeda3203bc9280b7aeefc9aea13503792 Mon Sep 17 00:00:00 2001 From: Bob Duff Date: Thu, 19 Mar 2020 18:17:36 -0400 Subject: [PATCH] [Ada] Put_Image attribute 2020-06-12 Bob Duff gcc/ada/ * debug.adb: Remove usage of -gnatd_z. * exp_attr.adb, exp_put_image.ads, exp_put_image.adb: Clean up the enable/disable code. If Put_Image is disabled for a type, systematically call the "unknown" version. Improve comments. Consolidate workarounds. Remove usage of -gnatd_z. --- gcc/ada/debug.adb | 5 +---- gcc/ada/exp_attr.adb | 15 ++++++++++++--- gcc/ada/exp_put_image.adb | 38 ++++++++++++++++++-------------------- gcc/ada/exp_put_image.ads | 5 +++-- 4 files changed, 34 insertions(+), 29 deletions(-) diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 0c86d96..1d614eb 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -170,7 +170,7 @@ package body Debug is -- d_w -- d_x -- d_y - -- d_z Enable Put_Image + -- d_z -- d_A Stop generation of ALI file -- d_B @@ -993,9 +993,6 @@ package body Debug is -- a call to routine Ada.Synchronous_Task_Control.Suspend_Until_True -- or Ada.Synchronous_Barriers.Wait_For_Release. - -- d_z The Put_Image attribute is a work in progress, and is disabled by - -- default. This enables it. - -- d_A Do not generate ALI files by setting Opt.Disable_ALI_File. -- d_F The compiler encodes the full path from an invocation construct to diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 356d3db..fc7aefa 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -5463,7 +5463,9 @@ package body Exp_Attr is return; end if; - -- If there is a TSS for Put_Image, just call it + -- If there is a TSS for Put_Image, just call it. This is true for + -- tagged types (if enabled) and if there is a user-specified + -- Put_Image. Pname := TSS (U_Type, TSS_Put_Image); if No (Pname) then @@ -5478,10 +5480,17 @@ package body Exp_Attr is end if; if No (Pname) then + -- If Put_Image is disabled, call the "unknown" version + + if not Enable_Put_Image (U_Type) then + Rewrite (N, Build_Unknown_Put_Image_Call (N)); + Analyze (N); + return; + -- For elementary types, we call the routine in System.Put_Images -- directly. - if Is_Elementary_Type (U_Type) then + elsif Is_Elementary_Type (U_Type) then Rewrite (N, Build_Elementary_Put_Image_Call (N)); Analyze (N); return; @@ -5535,7 +5544,7 @@ package body Exp_Attr is Analyze (N); return; - -- All other record type cases, including protected records + -- All other record type cases else pragma Assert (Is_Record_Type (U_Type)); diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb index db7c65b..c8119c7 100644 --- a/gcc/ada/exp_put_image.adb +++ b/gcc/ada/exp_put_image.adb @@ -24,7 +24,6 @@ ------------------------------------------------------------------------------ with Atree; use Atree; -with Debug; use Debug; with Einfo; use Einfo; with Exp_Tss; use Exp_Tss; with Exp_Util; @@ -341,9 +340,6 @@ package body Exp_Put_Image is -- -- Note that this is putting a leading space for reals. - -- ???Work around the fact that Put_Image doesn't work for private - -- types whose full type is real. - if Is_Real_Type (U_Type) then return Build_Unknown_Put_Image_Call (N); end if; @@ -620,9 +616,7 @@ package body Exp_Put_Image is procedure Append_Component_Attr (Clist : List_Id; C : Entity_Id) is Component_Typ : constant Entity_Id := Put_Image_Base_Type (Etype (C)); begin - if Ekind (C) /= E_Void - and then Enable_Put_Image (Component_Typ) - then + if Ekind (C) /= E_Void then Append_To (Clist, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Component_Typ, Loc), @@ -819,12 +813,8 @@ package body Exp_Put_Image is -- Enable_Put_Image -- ---------------------- - function Enable_Put_Image (T : Entity_Id) return Boolean is + function Enable_Put_Image (Typ : Entity_Id) return Boolean is begin - if not Debug_Flag_Underscore_Z then -- ????True to disable for all types - return False; - end if; - -- There's a bit of a chicken&egg problem. The compiler is likely to -- have trouble if we refer to the Put_Image of Sink itself, because -- Sink is part of the parameter profile: @@ -840,12 +830,20 @@ package body Exp_Put_Image is -- scalar types are expanded inline. We certainly want to be able to use -- Integer'Put_Image, for example. - -- ???Work around a bug: Put_Image does not work for Remote_Types. - -- We check the containing package, rather than the type itself, because - -- we want to include types in the private part of a Remote_Types - -- package. + -- ???Temporarily disable to work around bugs: + -- + -- Put_Image does not work for Remote_Types. We check the containing + -- package, rather than the type itself, because we want to include + -- types in the private part of a Remote_Types package. + -- + -- Put_Image on tagged types triggers some bugs. + -- + -- Put_Image doesn't work for private types whose full type is real. - if Is_Remote_Types (Scope (T)) then + if Is_Remote_Types (Scope (Typ)) + or else Is_Tagged_Type (Typ) + or else Is_Real_Type (Typ) + then return False; end if; @@ -856,17 +854,17 @@ package body Exp_Put_Image is -- predefined types. declare - Parent_Scope : constant Entity_Id := Scope (Scope (T)); + Parent_Scope : constant Entity_Id := Scope (Scope (Typ)); begin if Present (Parent_Scope) and then Is_RTU (Parent_Scope, Ada_Strings) - and then Chars (Scope (T)) = Name_Find ("text_output") + and then Chars (Scope (Typ)) = Name_Find ("text_output") then return False; end if; end; - return Is_Scalar_Type (T) or else not In_Predefined_Unit (T); + return Is_Scalar_Type (Typ) or else not In_Predefined_Unit (Typ); end Enable_Put_Image; --------------------------------- diff --git a/gcc/ada/exp_put_image.ads b/gcc/ada/exp_put_image.ads index b245b05..82c1c59 100644 --- a/gcc/ada/exp_put_image.ads +++ b/gcc/ada/exp_put_image.ads @@ -38,8 +38,9 @@ package Exp_Put_Image is -- are calls to T'Put_Image in different units, there will be duplicates; -- each unit will get a copy of the T'Put_Image procedure. - function Enable_Put_Image (T : Entity_Id) return Boolean; - -- True if Put_Image should be enabled for type T + function Enable_Put_Image (Typ : Entity_Id) return Boolean; + -- True if the predefined Put_Image should be enabled for type T. Put_Image + -- is always enabled if there is a user-specified one. function Build_Put_Image_Profile (Loc : Source_Ptr; Typ : Entity_Id) return List_Id; -- 2.7.4