From: Marc Poulhiès <poulhies@adacore.com>
Date: Tue, 3 Jun 2025 12:50:58 +0000 (+0200)
Subject: ada: Add procedure to write an extended access as a String
X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=32c70b25f0c12e448c7fdf3782ef827807d6e7b6;p=thirdparty%2Fgcc.git

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 ce3390b5038..c11bc43cfca 100644
--- 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 25dd7c13914..ea26e02c3a9 100644
--- 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 c2d392abfdb..accdcf12bf7 100644
--- 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 c26a3b9c5aa..c82af1154fe 100644
--- 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,