From bfdb362c000c1502ca4757bb7e5ce5cb42a6a5ae Mon Sep 17 00:00:00 2001 From: Bob Duff Date: Mon, 30 Mar 2020 10:18:34 -0400 Subject: [PATCH] [Ada] Put_Image: Enable for access-to-subprogram types 2020-06-15 Bob Duff 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. --- gcc/ada/exp_put_image.adb | 6 +++++- gcc/ada/libgnat/s-putima.adb | 33 ++++++++++++++++++++++++++++----- gcc/ada/libgnat/s-putima.ads | 6 ++++++ gcc/ada/rtsfind.ads | 4 ++++ 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, -- 2.7.4