https://gcc.gnu.org/g:15d3f36f76bda1720555b7f426957951d4e3b76d
commit r15-1778-g15d3f36f76bda1720555b7f426957951d4e3b76d
Author: Steve Baird <ba...@adacore.com>
Date: Thu Jun 13 15:39:37 2024 -0700
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:
---
gcc/ada/exp_put_image.adb | 17 ++++++++++++++++-
1 file changed, 16 insertions(+), 1 deletion(-)
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.
