[Ada] Put_Image improvements for strings

2020-06-15  Bob Duff  <duff@adacore.com>

gcc/ada/

	* exp_attr.adb (Put_Image): Use underlying type for strings.
	Remove unchecked union processing.
	* exp_put_image.adb (Tagged_Put_Image_Enabled): Use -gnatd_z to
	enable default Put_Image for tagged types.  This allows testing
	that feature.
	(Build_String_Put_Image_Call): Set Conversion_OK flag.
	(Make_Component_List_Attributes): Remove unchecked union
	processing.
	(Enable_Put_Image): Disable for unchecked unions.  Enable for
	nonscalar types (which were mistakenly disabled in earlier
	changes).
	* debug.adb: Document -gnatd_z switch.
	* libgnat/s-putima.adb (Put_Image_String, Put_Image_Wide_String,
	Put_Image_Wide_Wide_String): Double double-quote characters.
	Forget about special handling of control characters for now --
	that's rare enough to not be a priority, and it's not clear what
	the right thing to do is anyway.
	* namet.adb: Minor: Improve debugger-friendliness.
	* sinfo.ads: Minor: Add "???" comment.

diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb
index 1d614eb70c5bb3d0609cc377f75f72d8db5ac919..63b14b2bd6d466a257d067b57edf02bb1d0e6ca7 100644 (file)
--- 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
+   --  d_z  Enable Put_Image on tagged types
 
    --  d_A  Stop generation of ALI file
    --  d_B
@@ -993,6 +993,9 @@ package body Debug is
    --       a call to routine Ada.Synchronous_Task_Control.Suspend_Until_True
    --       or Ada.Synchronous_Barriers.Wait_For_Release.
 
+   --  d_z  Enable the default Put_Image on tagged types that are not
+   --       predefined.
+
    --  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 a7b9007ffe2d4f9fa7abb138eba68058937d70c8..182ce1554bcada9c7b528536d309eba2b45df339 100644 (file)
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -5505,20 +5505,7 @@ package body Exp_Attr is
                Analyze (N);
                return;
 
-            --  ???It would be nice to call Build_String_Put_Image_Call below
-            --  if U_Type is a standard string type, but it currently generates
-            --  something like:
-            --
-            --     Put_Image_String (Sink, String (X));
-            --
-            --  so if X is of a private type whose full type is "new String",
-            --  then the type conversion is illegal. To fix that, we would need
-            --  to do unchecked conversions of access values, taking care to
-            --  deal with thin and fat pointers properly. For now, we just fall
-            --  back to Build_Array_Put_Image_Procedure in these cases, so the
-            --  following says "Root_Type (Entity (Pref))" instead of "U_Type".
-
-            elsif Is_Standard_String_Type (Root_Type (Entity (Pref))) then
+            elsif Is_Standard_String_Type (U_Type) then
                Rewrite (N, Build_String_Put_Image_Call (N));
                Analyze (N);
                return;
@@ -5558,21 +5545,6 @@ package body Exp_Attr is
 
             else
                pragma Assert (Is_Record_Type (U_Type));
-
-               --  Program_Error is raised when calling the default
-               --  implementation of the Put_Image attribute of an
-               --  Unchecked_Union type. ???It would be friendlier to print a
-               --  canned string. See handling of unchecked unions in
-               --  exp_put_image.adb (which is not reachable).
-
-               if Is_Unchecked_Union (Base_Type (U_Type)) then
-                  Rewrite (N,
-                    Make_Raise_Program_Error (Loc,
-                      Reason => PE_Unchecked_Union_Restriction));
-                  Set_Etype (N, Standard_Void_Type);
-                  return;
-               end if;
-
                Build_Record_Put_Image_Procedure
                  (Loc, Full_Base (U_Type), Decl, Pname);
                Insert_Action (N, Decl);

diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb
index 0d1325890b2ec6afbb8da910598987e977c93aa5..4d63e39213163ef36f66518ddfa5065fca47db9d 100644 (file)
--- a/gcc/ada/exp_put_image.adb
+++ b/gcc/ada/exp_put_image.adb
@@ -27,6 +27,7 @@ with Atree;    use Atree;
 with Einfo;    use Einfo;
 with Exp_Tss;  use Exp_Tss;
 with Exp_Util;
+with Debug;    use Debug;
 with Lib;      use Lib;
 with Namet;    use Namet;
 with Nlists;   use Nlists;
@@ -44,7 +45,7 @@ with Uintp;    use Uintp;
 
 package body Exp_Put_Image is
 
-   Tagged_Put_Image_Enabled : constant Boolean := False;
+   Tagged_Put_Image_Enabled : Boolean renames Debug_Flag_Underscore_Z;
    --  ???Set True to enable Put_Image for at least some tagged types
 
    -----------------------
@@ -410,18 +411,21 @@ package body Exp_Put_Image is
 
       --  Convert parameter to the required type (i.e. the type of the
       --  corresponding parameter), and call the appropriate routine.
+      --  We set the Conversion_OK flag in case the type is private.
 
       declare
          Libent : constant Entity_Id := RTE (Lib_RE);
+         Conv   : constant Node_Id :=
+           OK_Convert_To
+            (Etype (Next_Formal (First_Formal (Libent))),
+             Relocate_Node (Item));
       begin
          return
            Make_Procedure_Call_Statement (Loc,
              Name => New_Occurrence_Of (Libent, Loc),
              Parameter_Associations => New_List (
                Relocate_Node (Sink),
-               Convert_To
-                (Etype (Next_Formal (First_Formal (Libent))),
-                 Relocate_Node (Item))));
+               Conv));
       end;
    end Build_String_Put_Image_Call;
 
@@ -585,24 +589,11 @@ package body Exp_Put_Image is
             --  selector, since there are cases in which we make a reference
             --  to a hidden discriminant that is not visible.
 
-            --  If the enclosing record is an unchecked_union, we use the
-            --  default expressions for the discriminant (it must exist)
-            --  because we cannot generate a reference to it, given that it is
-            --  not stored. ????This seems unfriendly. It should just print
-            --  "(unchecked union)" instead. (Note that this code is
-            --  unreachable -- see exp_attr.)
-
-            if Is_Unchecked_Union (Scope (Entity (Name (VP)))) then
-               D_Ref :=
-                 New_Copy_Tree
-                   (Discriminant_Default_Value (Entity (Name (VP))));
-            else
-               D_Ref :=
-                  Make_Selected_Component (Loc,
-                    Prefix        => Make_Identifier (Loc, Name_V),
-                    Selector_Name =>
-                      New_Occurrence_Of (Entity (Name (VP)), Loc));
-            end if;
+            D_Ref :=
+               Make_Selected_Component (Loc,
+                 Prefix        => Make_Identifier (Loc, Name_V),
+                 Selector_Name =>
+                   New_Occurrence_Of (Entity (Name (VP)), Loc));
 
             Append_To (Result,
               Make_Case_Statement (Loc,
@@ -715,8 +706,6 @@ package body Exp_Put_Image is
             (Make_Identifier (Loc, Name_S))));
 
       --  Generate Put_Images for the discriminants of the type
-      --  If the type is an unchecked union, use the default values of
-      --  the discriminants, because they are not stored.
 
       Append_List_To (Stms,
         Make_Component_Attributes (Discriminant_Specifications (Type_Decl)));
@@ -901,7 +890,15 @@ package body Exp_Put_Image is
          return False;
       end if;
 
-      return Is_Scalar_Type (Typ) or else not In_Predefined_Unit (Typ);
+      --  Disable for unchecked unions, because there is no way to know the
+      --  discriminant value, and therefore no way to know which components
+      --  should be printed.
+
+      if Is_Unchecked_Union (Typ) then
+         return False;
+      end if;
+
+      return True;
    end Enable_Put_Image;
 
    ---------------------------------
@@ -941,6 +938,12 @@ package body Exp_Put_Image is
       --  enabled for tagged types, and we've seen a tagged type. Note that
       --  Tagged_Seen is set True by the parser if the "tagged" reserved word
       --  is seen; this flag tells us whether we have any tagged types.
+      --  It's unfortunate to have this Tagged_Seen processing so scattered
+      --  about, but we need to know if there are tagged types where this is
+      --  called in Analyze_Compilation_Unit, before we have analyzed any type
+      --  declarations. This mechanism also prevents doing RTE (RE_Sink) when
+      --  compiling the compiler itself. Packages Ada.Strings.Text_Output and
+      --  friends are not included in the compiler.
       --
       --  Don't do it if type Sink is unavailable in the runtime.
 

diff --git a/gcc/ada/libgnat/s-putima.adb b/gcc/ada/libgnat/s-putima.adb
index 50597b2422a1e1aaf004bb5481ec3060ca8aac7e..2f976ac97f7a6139726a3b98f384c409d1c69a05 100644 (file)
--- a/gcc/ada/libgnat/s-putima.adb
+++ b/gcc/ada/libgnat/s-putima.adb
@@ -142,17 +142,25 @@ package body System.Put_Images is
 
    procedure Put_Image_String (S : in out Sink'Class; X : String) is
    begin
-      --  ????We should double double quotes, and maybe do something nice with
-      --  control characters.
       Put_UTF_8 (S, """");
-      Put_String (S, X);
+      for C of X loop
+         if C = '"' then
+            Put_UTF_8 (S, """");
+         end if;
+         Put_Character (S, C);
+      end loop;
       Put_UTF_8 (S, """");
    end Put_Image_String;
 
    procedure Put_Image_Wide_String (S : in out Sink'Class; X : Wide_String) is
    begin
       Put_UTF_8 (S, """");
-      Put_Wide_String (S, X);
+      for C of X loop
+         if C = '"' then
+            Put_UTF_8 (S, """");
+         end if;
+         Put_Wide_Character (S, C);
+      end loop;
       Put_UTF_8 (S, """");
    end Put_Image_Wide_String;
 
@@ -160,7 +168,12 @@ package body System.Put_Images is
      (S : in out Sink'Class; X : Wide_Wide_String) is
    begin
       Put_UTF_8 (S, """");
-      Put_Wide_Wide_String (S, X);
+      for C of X loop
+         if C = '"' then
+            Put_UTF_8 (S, """");
+         end if;
+         Put_Wide_Wide_Character (S, C);
+      end loop;
       Put_UTF_8 (S, """");
    end Put_Image_Wide_Wide_String;
 

diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb
index 60c1050522e590eac9063f113dc0f911f2c6c8af..6cc05bb40aadd8c1060a3356cb26c6856e5d993c 100644 (file)
--- a/gcc/ada/namet.adb
+++ b/gcc/ada/namet.adb
@@ -1179,11 +1179,13 @@ package body Namet is
       Hash_Index : Hash_Index_Type;
       --  Computed hash index
 
+      Result : Valid_Name_Id;
+
    begin
       --  Quick handling for one character names
 
       if Buf.Length = 1 then
-         return Valid_Name_Id (First_Name_Id + Character'Pos (Buf.Chars (1)));
+         Result := First_Name_Id + Character'Pos (Buf.Chars (1));
 
       --  Otherwise search hash table for existing matching entry
 
@@ -1210,7 +1212,8 @@ package body Namet is
                   end if;
                end loop;
 
-               return New_Id;
+               Result := New_Id;
+               goto Done;
 
                --  Current entry in hash chain does not match
 
@@ -1248,8 +1251,11 @@ package body Namet is
 
          Name_Chars.Append (ASCII.NUL);
 
-         return Name_Entries.Last;
+         Result := Name_Entries.Last;
       end if;
+
+      <<Done>>
+      return Result;
    end Name_Find;
 
    function Name_Find (S : String) return Valid_Name_Id is

diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index d0739b8443a2927feb2868ad887ba7586da10955..7bec540ccee53192c85267301e57f386a3d1b445 100644 (file)
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -1029,7 +1029,7 @@ package Sinfo is
    --    Present in N_Raise_Expression nodes that appear in the body of the
    --    special predicateM function used to test a predicate in the context
    --    of a membership test, where raise expression results in returning a
-   --    value of False rather than raising an exception.
+   --    value of False rather than raising an exception.???obsolete flag
 
    --  Corresponding_Aspect (Node3-Sem)
    --    Present in N_Pragma node. Used to point back to the source aspect from