ada: Put_Image aspect spec ignored for null extension.

If type T1 is is a tagged null record with a Put_Image aspect specification
and type T2 is a null extension of T1 (with no aspect specifications), then
evaluation of a T2'Image call should include a call to the specified procedure
(as opposed to yielding "(NULL RECORD)").

gcc/ada/

	* exp_put_image.adb
	(Build_Record_Put_Image_Procedure): Declare new Boolean-valued
	function Null_Record_Default_Implementation_OK; call it as part of
	deciding whether to generate "(NULL RECORD)" text.

diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb
index 94299e39661028c0f13300c88b8e7ca02e5a7be7..bf14eded93ec8c471536b8236690242d289816e4 100644 (file)
--- a/gcc/ada/exp_put_image.adb
+++ b/gcc/ada/exp_put_image.adb
@@ -580,6 +580,18 @@ package body Exp_Put_Image is
       function Make_Component_Name (C : Entity_Id) return Node_Id;
       --  Create a call that prints "Comp_Name => "
 
+      function Null_Record_Default_Implementation_OK
+        (Null_Record_Type : Entity_Id) return Boolean
+      is
+        (if Has_Aspect (Null_Record_Type, Aspect_Put_Image)
+           then False
+         elsif not Is_Derived_Type
+                     (Implementation_Base_Type (Null_Record_Type))
+           then True
+         else Null_Record_Default_Implementation_OK
+                (Implementation_Base_Type (Etype (Null_Record_Type))));
+      --  return True iff ok to emit "(NULL RECORD)" for given null record type
+
       ------------------------------------
       -- Make_Component_List_Attributes --
       ------------------------------------
@@ -852,7 +864,10 @@ package body Exp_Put_Image is
                           Type_Name))));
             end;
          end if;
-      elsif Is_Null_Record_Type (Btyp, Ignore_Privacy => True) then
+
+      elsif Is_Null_Record_Type (Btyp, Ignore_Privacy => True)
+        and then Null_Record_Default_Implementation_OK (Btyp)
+      then
 
          --  Interface types take this path.