[Ada] Put_Image: Enable for access-to-subprogram types

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

gcc/ada/

	* libgnat/s-putima.ads, libgnat/s-putima.adb
	(Put_Image_Access_Subp, Put_Image_Access_Prot): New procedures
	for printing access-to-subprogram objects.  Remove an explicit
	" ", because Put_Image includes the annoying leading blank.
	* rtsfind.ads: Add new procedures in s-putima.
	* exp_put_image.adb: Call new procedures as appropriate.

diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb
index 763323f..657f618 100644 (file)
--- a/gcc/ada/exp_put_image.adb
+++ b/gcc/ada/exp_put_image.adb
@@ -314,7 +314,11 @@ package body Exp_Put_Image is
          end if;
 
       elsif Is_Access_Type (U_Type) then
-         if P_Size = System_Address_Size then
+         if Is_Access_Protected_Subprogram_Type (U_Type) then
+            Lib_RE := RE_Put_Image_Access_Prot;
+         elsif Is_Access_Subprogram_Type (U_Type) then
+            Lib_RE := RE_Put_Image_Access_Subp;
+         elsif P_Size = System_Address_Size then
             Lib_RE := RE_Put_Image_Thin_Pointer;
          else
             pragma Assert (P_Size = 2 * System_Address_Size);

diff --git a/gcc/ada/libgnat/s-putima.adb b/gcc/ada/libgnat/s-putima.adb
index 2f976ac..d7d530b 100644 (file)
--- a/gcc/ada/libgnat/s-putima.adb
+++ b/gcc/ada/libgnat/s-putima.adb
@@ -118,16 +118,20 @@ package body System.Put_Images is
    generic
       type Designated (<>) is private;
       type Pointer is access all Designated;
-   procedure Put_Image_Pointer (S : in out Sink'Class; X : Pointer);
+   procedure Put_Image_Pointer
+     (S : in out Sink'Class; X : Pointer; Type_Kind : String);
 
-   procedure Put_Image_Pointer (S : in out Sink'Class; X : Pointer) is
+   procedure Put_Image_Pointer
+     (S : in out Sink'Class; X : Pointer; Type_Kind : String)
+   is
       function Cast is new Unchecked_Conversion
         (System.Address, Unsigned_Address);
    begin
       if X = null then
          Put_UTF_8 (S, "null");
       else
-         Put_UTF_8 (S, "(access ");
+         Put_UTF_8 (S, "(");
+         Put_UTF_8 (S, Type_Kind);
          Hex.Put_Image (S, Cast (X.all'Address));
          Put_UTF_8 (S, ")");
       end if;
@@ -135,10 +139,29 @@ package body System.Put_Images is
 
    procedure Thin_Instance is new Put_Image_Pointer (Byte, Thin_Pointer);
    procedure Put_Image_Thin_Pointer
-     (S : in out Sink'Class; X : Thin_Pointer) renames Thin_Instance;
+     (S : in out Sink'Class; X : Thin_Pointer)
+   is
+   begin
+      Thin_Instance (S, X, "access");
+   end Put_Image_Thin_Pointer;
+
    procedure Fat_Instance is new Put_Image_Pointer (Byte_String, Fat_Pointer);
    procedure Put_Image_Fat_Pointer
-     (S : in out Sink'Class; X : Fat_Pointer) renames Fat_Instance;
+     (S : in out Sink'Class; X : Fat_Pointer)
+   is
+   begin
+      Fat_Instance (S, X, "access");
+   end Put_Image_Fat_Pointer;
+
+   procedure Put_Image_Access_Subp (S : in out Sink'Class; X : Thin_Pointer) is
+   begin
+      Thin_Instance (S, X, "access subprogram");
+   end Put_Image_Access_Subp;
+
+   procedure Put_Image_Access_Prot (S : in out Sink'Class; X : Thin_Pointer) is
+   begin
+      Thin_Instance (S, X, "access protected subprogram");
+   end Put_Image_Access_Prot;
 
    procedure Put_Image_String (S : in out Sink'Class; X : String) is
    begin

diff --git a/gcc/ada/libgnat/s-putima.ads b/gcc/ada/libgnat/s-putima.ads
index 0bedd3d..3015a41 100644 (file)
--- a/gcc/ada/libgnat/s-putima.ads
+++ b/gcc/ada/libgnat/s-putima.ads
@@ -69,6 +69,12 @@ package System.Put_Images is
    --  Print "null", or the address of the designated object as an unsigned
    --  hexadecimal integer.
 
+   procedure Put_Image_Access_Subp (S : in out Sink'Class; X : Thin_Pointer);
+   --  For access-to-subprogram types
+
+   procedure Put_Image_Access_Prot (S : in out Sink'Class; X : Thin_Pointer);
+   --  For access-to-protected-subprogram types
+
    procedure Put_Image_String (S : in out Sink'Class; X : String);
    procedure Put_Image_Wide_String (S : in out Sink'Class; X : Wide_String);
    procedure Put_Image_Wide_Wide_String

diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads
index 3dee2c0..5ddb050 100644 (file)
--- a/gcc/ada/rtsfind.ads
+++ b/gcc/ada/rtsfind.ads
@@ -1179,6 +1179,8 @@ package Rtsfind is
      RE_Put_Image_Long_Long_Unsigned,    -- System.Put_Images
      RE_Put_Image_Thin_Pointer,          -- System.Put_Images
      RE_Put_Image_Fat_Pointer,           -- System.Put_Images
+     RE_Put_Image_Access_Subp,           -- System.Put_Images
+     RE_Put_Image_Access_Prot,           -- System.Put_Images
      RE_Put_Image_String,                -- System.Put_Images
      RE_Put_Image_Wide_String,           -- System.Put_Images
      RE_Put_Image_Wide_Wide_String,      -- System.Put_Images
@@ -2580,6 +2582,8 @@ package Rtsfind is
      RE_Put_Image_Long_Long_Unsigned     => System_Put_Images,
      RE_Put_Image_Thin_Pointer           => System_Put_Images,
      RE_Put_Image_Fat_Pointer            => System_Put_Images,
+     RE_Put_Image_Access_Subp            => System_Put_Images,
+     RE_Put_Image_Access_Prot            => System_Put_Images,
      RE_Put_Image_String                 => System_Put_Images,
      RE_Put_Image_Wide_String            => System_Put_Images,
      RE_Put_Image_Wide_Wide_String       => System_Put_Images,