diff mbox series

[COMMITTED,09/13] ada: Put_Image aspect spec ignored for null extension.

Message ID 20240702132130.523603-9-poulhies@adacore.com
State New
Headers show
Series [COMMITTED,01/13] ada: Document that -gnatdJ is unused | expand

Commit Message

Marc Poulhiès July 2, 2024, 1:21 p.m. UTC 
From: Steve Baird <baird@adacore.com>

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.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/exp_put_image.adb | 17 ++++++++++++++++-
 1 file changed, 16 insertions(+), 1 deletion(-)
diff mbox series

Patch

diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb
index 94299e39661..bf14eded93e 100644
--- 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.