ada: Add procedure to write an extended access as a String

Add the Put_Image_Extended_Access_Pointer procedure for supporting
Ext_Access'Image.

gcc/ada/ChangeLog:

	* libgnat/s-putima.ads (Ext_Access_Pointer): New.
	(Put_Image_Extended_Access_Pointer): New.
	* libgnat/s-putima.adb (Ext_Acc_Instance): New.
	(Put_Image_Extended_Access_Pointer): New.
	* rtsfind.ads (RE_Id, RE_Unit_Table): Set value for
	RE_Put_Image_Extended_Access_Pointer.
	* exp_put_image.adb (Build_Elementary_Put_Image_Call): Handle extended
	access.

diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb
index ce3390b5038463f69cfb9812cab8ca28fe12fa8b..c11bc43cfcabab9bb1317ac2804c2cb352a5ea5c 100644 (file)
--- a/gcc/ada/exp_put_image.adb
+++ b/gcc/ada/exp_put_image.adb
@@ -363,6 +363,9 @@ package body Exp_Put_Image is
             Lib_RE := RE_Put_Image_Access_Prot_Subp;
          elsif Is_Access_Subprogram_Type (Base_Type (U_Type)) then
             Lib_RE := RE_Put_Image_Access_Subp;
+         elsif Is_Extended_Access_Type (Base_Type (U_Type)) then
+            pragma Assert (No (P_Size));
+            Lib_RE := RE_Put_Image_Extended_Access_Pointer;
          elsif P_Size = System_Address_Size then
             Lib_RE := RE_Put_Image_Thin_Pointer;
          else

diff --git a/gcc/ada/libgnat/s-putima.adb b/gcc/ada/libgnat/s-putima.adb
index 25dd7c13914792b7f937f5df7b3d2ed7c52291e9..ea26e02c3a9657f8d56c2e4f8e0e10ce5f0884ac 100644 (file)
--- a/gcc/ada/libgnat/s-putima.adb
+++ b/gcc/ada/libgnat/s-putima.adb
@@ -159,6 +159,16 @@ package body System.Put_Images is
       Fat_Instance (S, X, "access");
    end Put_Image_Fat_Pointer;
 
+   procedure Ext_Acc_Instance is new
+     Put_Image_Pointer (Byte_String, Ext_Access_Pointer);
+
+   procedure Put_Image_Extended_Access_Pointer
+     (S : in out Sink'Class; X : Ext_Access_Pointer)
+   is
+   begin
+      Ext_Acc_Instance (S, X, "extended access");
+   end Put_Image_Extended_Access_Pointer;
+
    procedure Put_Image_Access_Subp (S : in out Sink'Class; X : Thin_Pointer) is
    begin
       Thin_Instance (S, X, "access subprogram");

diff --git a/gcc/ada/libgnat/s-putima.ads b/gcc/ada/libgnat/s-putima.ads
index c2d392abfdb92709b6d54e70545d1648310c3573..accdcf12bf7948941331ead3c96a52ce74e25b00 100644 (file)
--- a/gcc/ada/libgnat/s-putima.ads
+++ b/gcc/ada/libgnat/s-putima.ads
@@ -72,10 +72,20 @@ package System.Put_Images with Pure is
    type Byte_String is array (Positive range <>) of Byte with Alignment => 1;
    type Thin_Pointer is access all Byte with Storage_Size => 0;
    type Fat_Pointer is access all Byte_String with Storage_Size => 0;
+   type Ext_Access_Pointer is access all Byte_String with Storage_Size => 0;
+
    procedure Put_Image_Thin_Pointer (S : in out Sink'Class; X : Thin_Pointer);
+   --  Print "(access)" followed by "null", or the address of the designated
+   --  object as an unsigned hexadecimal integer.
+
    procedure Put_Image_Fat_Pointer (S : in out Sink'Class; X : Fat_Pointer);
-   --  Print "null", or the address of the designated object as an unsigned
-   --  hexadecimal integer.
+   --  Print "(access)" followed by "null", or the address of the designated
+   --  object as an unsigned hexadecimal integer.
+
+   procedure Put_Image_Extended_Access_Pointer
+     (S : in out Sink'Class; X : Ext_Access_Pointer);
+   --  Print "(extended access)" followed by "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

diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads
index c26a3b9c5aa562b80e0d8e408e7a15825cdf5917..c82af1154feac784edcafa4c3a6b6bf41527ef97 100644 (file)
--- a/gcc/ada/rtsfind.ads
+++ b/gcc/ada/rtsfind.ads
@@ -1660,6 +1660,7 @@ package Rtsfind is
      RE_Put_Image_Long_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_Extended_Access_Pointer, -- System.Put_Images
      RE_Put_Image_Access_Subp,           -- System.Put_Images
      RE_Put_Image_Access_Prot_Subp,      -- System.Put_Images
      RE_Put_Image_String,                -- System.Put_Images
@@ -3441,6 +3442,7 @@ package Rtsfind is
      RE_Put_Image_Long_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_Extended_Access_Pointer => System_Put_Images,
      RE_Put_Image_Access_Subp            => System_Put_Images,
      RE_Put_Image_Access_Prot_Subp       => System_Put_Images,
      RE_Put_Image_String                 => System_Put_Images,