ada: Default Put_Image for composite derived types is missing information

The output generated by a call to Some_Derived_Composite_Type'Put_Image
(in Ada2022 code) is incomplete in some cases, notably for a type derived
from a container type (i.e., from the Set/Map/List/Vector type declared in
an instance of one of Ada's predefined container generics) with no
user-specified Put_Image procedure.

gcc/ada/

	* aspects.ads (Find_Aspect): Add Boolean parameter Or_Rep_Item
	(defaulted to False).
	* aspects.adb (Find_Aspect): If new Boolean parameter Or_Rep_Item
	is True, then instead of returning an empty result if no
	appropriate N_Aspect_Specification node is found, return an
	appropriate N_Attribute_Definition_Clause if one is found.
	* exp_put_image.ads: Change name of Enable_Put_Image function to
	Put_Image_Enabled.
	* exp_put_image.adb (Build_Record_Put_Image_Procedure): Detect the
	case where a call to the Put_Image procedure of a derived type can
	be transformed into a call to the parent type's Put_Image
	procedure (with a type conversion to the parent type as the actual
	parameter).
	(Put_Image_Enabled): Change name of function (previously
	Enable_Put_Image). Return True in more cases. In particular,
	return True for a type with an explicitly specified Put_Image
	aspect even if the type is declared in a predefined unit (or in an
	instance of a predefined generic unit).
	* exp_attr.adb: Changes due to Put_Image_Enabled function name
	change.

diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb
index c14769c640cbdf2234d8de8f76ebf9240fb67f27..86dbd183565d5fb0bf3a70ff8bcc63036fe17da0 100644 (file)
--- a/gcc/ada/aspects.adb
+++ b/gcc/ada/aspects.adb
@@ -193,13 +193,14 @@ package body Aspects is
    function Find_Aspect
      (Id            : Entity_Id;
       A             : Aspect_Id;
-      Class_Present : Boolean := False) return Node_Id
+      Class_Present : Boolean := False;
+      Or_Rep_Item   : Boolean := False) return Node_Id
    is
-      Decl  : Node_Id;
-      Item  : Node_Id;
-      Owner : Entity_Id;
-      Spec  : Node_Id;
-
+      Decl                 : Node_Id;
+      Item                 : Node_Id;
+      Owner                : Entity_Id;
+      Spec                 : Node_Id;
+      Alternative_Rep_Item : Node_Id := Empty;
    begin
       Owner := Id;
 
@@ -231,6 +232,18 @@ package body Aspects is
            and then Class_Present = Sinfo.Nodes.Class_Present (Item)
          then
             return Item;
+
+         --  We could do something similar here for an N_Pragma node
+         --  when Get_Aspect_Id (Pragma_Name (Item)) = A, but let's
+         --  wait for a demonstrated need.
+
+         elsif Or_Rep_Item
+           and then not Class_Present
+           and then Nkind (Item) = N_Attribute_Definition_Clause
+           and then Get_Aspect_Id (Chars (Item)) = A
+         then
+            --  Remember this candidate in case we don't find anything better
+            Alternative_Rep_Item := Item;
          end if;
 
          Next_Rep_Item (Item);
@@ -266,9 +279,10 @@ package body Aspects is
       end if;
 
       --  The entity does not carry any aspects or the desired aspect was not
-      --  found.
+      --  found. We have no N_Aspect_Specification node to return, but
+      --  Alternative_Rep_Item may have been set (if Or_Rep_Item is True).
 
-      return Empty;
+      return Alternative_Rep_Item;
    end Find_Aspect;
 
    --------------------------

diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
index 056779780371fb7067b3125931c3aed2de56765b..f718227a7aff42794f83a978196b54b0788714f9 100644 (file)
--- a/gcc/ada/aspects.ads
+++ b/gcc/ada/aspects.ads
@@ -1156,10 +1156,18 @@ package Aspects is
 
    function Find_Aspect (Id            : Entity_Id;
                          A             : Aspect_Id;
-                         Class_Present : Boolean := False) return Node_Id;
+                         Class_Present : Boolean := False;
+                         Or_Rep_Item   : Boolean := False) return Node_Id;
    --  Find the aspect specification of aspect A (or A'Class if Class_Present)
    --  associated with entity I.
-   --  Return Empty if Id does not have the requested aspect.
+   --  If found, then return the aspect specification.
+   --  If not found and Or_Rep_Item is true, then look for a representation
+   --  item (as opposed to an N_Aspect_Specification node) which specifies
+   --  the given aspect; if found, then return the representation item.
+   --  [Currently only N_Attribute_Definition_Clause representation items
+   --  are checked for, but support for detecting N_Pragma representation
+   --  items could easily be added in the future if there is a need.]
+   --  Otherwise, return Empty.
 
    function Find_Value_Of_Aspect
      (Id            : Entity_Id;

diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 6b498eb2d772b52ca150a4d404a20b8ae28c56f5..dddc05437b4e59c561b08c6d7168ebe6ea7ad558 100644 (file)
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -5906,7 +5906,7 @@ package body Exp_Attr is
          if No (Pname) then
             --  If Put_Image is disabled, call the "unknown" version
 
-            if not Enable_Put_Image (U_Type) then
+            if not Put_Image_Enabled (U_Type) then
                Rewrite (N, Build_Unknown_Put_Image_Call (N));
                Analyze (N);
                return;
@@ -5937,7 +5937,7 @@ package body Exp_Attr is
 
                --  ????Need Find_Optional_Prim_Op instead of Find_Prim_Op,
                --  because we might be deriving from a predefined type, which
-               --  currently has Enable_Put_Image False.
+               --  currently has Put_Image_Enabled False.
 
                if No (Pname) then
                   Rewrite (N, Build_Unknown_Put_Image_Call (N));

diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb
index 0c357f1c54700f6d2c25915e1619a78d906ca18f..6684d4178e6b3913438456aea89b57cfabab1f82 100644 (file)
--- a/gcc/ada/exp_put_image.adb
+++ b/gcc/ada/exp_put_image.adb
@@ -815,7 +815,7 @@ package body Exp_Put_Image is
 
    begin
       if Ada_Version < Ada_2022
-        or else not Enable_Put_Image (Btyp)
+        or else not Put_Image_Enabled (Btyp)
       then
          --  generate a very simple Put_Image implementation
 
@@ -845,6 +845,26 @@ package body Exp_Put_Image is
              Parameter_Associations => New_List
                (Make_Identifier (Loc, Name_S),
                 Make_String_Literal (Loc, "(NULL RECORD)"))));
+
+      elsif Is_Derived_Type (Btyp)
+         and then (not Is_Tagged_Type (Btyp) or else Is_Null_Extension (Btyp))
+      then
+         declare
+            Parent_Type : constant Entity_Id := Base_Type (Etype (Btyp));
+         begin
+            Append_To (Stms,
+              Make_Attribute_Reference (Loc,
+              Prefix         => New_Occurrence_Of (Parent_Type, Loc),
+              Attribute_Name => Name_Put_Image,
+              Expressions    => New_List (
+                                  Make_Identifier (Loc, Name_S),
+                                  Make_Type_Conversion (Loc,
+                                    Subtype_Mark => New_Occurrence_Of
+                                                      (Parent_Type, Loc),
+                                    Expression => Make_Identifier
+                                                    (Loc, Name_V)))));
+         end;
+
       else
          Append_To (Stms,
            Make_Procedure_Call_Statement (Loc,
@@ -951,11 +971,11 @@ package body Exp_Put_Image is
                 Entity (Prefix (N)), Append_NUL => False))));
    end Build_Unknown_Put_Image_Call;
 
-   ----------------------
-   -- Enable_Put_Image --
-   ----------------------
+   -----------------------
+   -- Put_Image_Enabled --
+   -----------------------
 
-   function Enable_Put_Image (Typ : Entity_Id) return Boolean is
+   function Put_Image_Enabled (Typ : Entity_Id) return Boolean is
    begin
       --  If this function returns False for a non-scalar type Typ, then
       --    a) calls to Typ'Image will result in calls to
@@ -969,13 +989,13 @@ package body Exp_Put_Image is
       --  The name "Sink" here is a short nickname for
       --  "Ada.Strings.Text_Buffers.Root_Buffer_Type".
       --
+
       --  Put_Image does not work for Remote_Types. We check the containing
       --  package, rather than the type itself, because we want to include
       --  types in the private part of a Remote_Types package.
 
       if Is_Remote_Types (Scope (Typ))
         or else Is_Remote_Call_Interface (Typ)
-        or else (Is_Tagged_Type (Typ) and then In_Predefined_Unit (Typ))
       then
          return False;
       end if;
@@ -994,6 +1014,20 @@ package body Exp_Put_Image is
          return False;
       end if;
 
+      if Is_Tagged_Type (Typ) then
+         if Is_Class_Wide_Type (Typ) then
+            return Put_Image_Enabled (Find_Specific_Type (Base_Type (Typ)));
+         elsif Present (Find_Aspect (Typ, Aspect_Put_Image,
+                                     Or_Rep_Item => True))
+         then
+            null;
+         elsif Is_Derived_Type (Typ) then
+            return Put_Image_Enabled (Etype (Base_Type (Typ)));
+         elsif In_Predefined_Unit (Typ) then
+            return False;
+         end if;
+      end if;
+
       --  ???Disable Put_Image on type Root_Buffer_Type declared in
       --  Ada.Strings.Text_Buffers. Note that we can't call Is_RTU on
       --  Ada_Strings_Text_Buffers, because it's not known yet (we might be
@@ -1030,7 +1064,7 @@ package body Exp_Put_Image is
       end if;
 
       return True;
-   end Enable_Put_Image;
+   end Put_Image_Enabled;
 
    -------------------------
    -- Make_Put_Image_Name --

diff --git a/gcc/ada/exp_put_image.ads b/gcc/ada/exp_put_image.ads
index a4c94120154d6f4ad68390f78e651f42f465e24d..9af4d9e5b232bead19c64d4a1d2bacb09c71a40c 100644 (file)
--- a/gcc/ada/exp_put_image.ads
+++ b/gcc/ada/exp_put_image.ads
@@ -39,7 +39,7 @@ package Exp_Put_Image is
    --  are calls to T'Put_Image in different units, there will be duplicates;
    --  each unit will get a copy of the T'Put_Image procedure.
 
-   function Enable_Put_Image (Typ : Entity_Id) return Boolean;
+   function Put_Image_Enabled (Typ : Entity_Id) return Boolean;
    --  True if the predefined Put_Image should be enabled for type T. Put_Image
    --  is always enabled if there is a user-specified one.