aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--gcc/ada/exp_put_image.adb6
-rw-r--r--gcc/ada/libgnat/s-putima.adb33
-rw-r--r--gcc/ada/libgnat/s-putima.ads6
-rw-r--r--gcc/ada/rtsfind.ads4
4 files changed, 43 insertions, 6 deletions
diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb
index 763323f..657f618 100644
--- 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
--- 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
--- 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
--- 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,