diff options
| author | Bob Duff <duff@adacore.com> | 2020-03-30 10:18:34 -0400 |
|---|---|---|
| committer | Pierre-Marie de Rodat <derodat@adacore.com> | 2020-06-15 04:04:23 -0400 |
| commit | bfdb362c000c1502ca4757bb7e5ce5cb42a6a5ae (patch) | |
| tree | cd959190cea65f1ed1d2ba126aca9c3ca04d996e /gcc/ada/libgnat | |
| parent | 3dd1cc4a05f57e0d65435a055d532e699c574403 (diff) | |
| download | gcc-bfdb362c000c1502ca4757bb7e5ce5cb42a6a5ae.zip gcc-bfdb362c000c1502ca4757bb7e5ce5cb42a6a5ae.tar.gz gcc-bfdb362c000c1502ca4757bb7e5ce5cb42a6a5ae.tar.bz2 | |
[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.
Diffstat (limited to 'gcc/ada/libgnat')
| -rw-r--r-- | gcc/ada/libgnat/s-putima.adb | 33 | ||||
| -rw-r--r-- | gcc/ada/libgnat/s-putima.ads | 6 |
2 files changed, 34 insertions, 5 deletions
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 |