From 15d3f36f76bda1720555b7f426957951d4e3b76d Mon Sep 17 00:00:00 2001 From: Steve Baird Date: Thu, 13 Jun 2024 15:39:37 -0700 Subject: 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. --- gcc/ada/exp_put_image.adb | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) (limited to 'gcc/ada') diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb index 94299e3..bf14ede 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. -- cgit v1.1