[gcc r16-1796] ada: Record type Put_Image procedures omitting discriminant values

[Marc Poulhies]

https://gcc.gnu.org/g:6e3b7d9476a115da19735d6f9fe811a416087af2

commit r16-1796-g6e3b7d9476a115da19735d6f9fe811a416087af2
Author: Steve Baird <baird@adacore.com>
Date:   Fri Apr 11 17:38:29 2025 -0700

    ada: Record type Put_Image procedures omitting discriminant values
    
    If a type T has a partial view with a known_discriminant_part and no
    user-specified Put_Image aspect specification, then the output generated
    by  T'Put_Image would incorrectly omit the discriminant values.
    
    gcc/ada/ChangeLog:
    
            * exp_put_image.adb (Build_Record_Put_Image_Procedure): If
            Discriminant_Specifications takes us from the full view of a type
            to an (intentionally) unanalyzed subtree, then instead find
            discriminant entities by calling Discriminant_Specifications on
            the partial view of the type.

Diff:
---
 gcc/ada/exp_put_image.adb | 55 +++++++++++++++++++++++++++++++++++------------
 1 file changed, 41 insertions(+), 14 deletions(-)

diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb
index ae5fa40fa380..40b2a65b8212 100644
--- a/gcc/ada/exp_put_image.adb
+++ b/gcc/ada/exp_put_image.adb
@@ -695,17 +695,15 @@ package body Exp_Put_Image is
            Put_Image_Base_Type
              (Get_Corresponding_Mutably_Tagged_Type_If_Present (Etype (C)));
       begin
-         if Ekind (C) /= E_Void then
-            Append_To (Clist,
-              Make_Attribute_Reference (Loc,
-                Prefix         => New_Occurrence_Of (Component_Typ, Loc),
-                Attribute_Name => Name_Put_Image,
-                Expressions    => New_List (
-                  Make_Identifier (Loc, Name_S),
-                  Make_Selected_Component (Loc,
-                    Prefix        => Make_Identifier (Loc, Name_V),
-                    Selector_Name => New_Occurrence_Of (C, Loc)))));
-         end if;
+         Append_To (Clist,
+           Make_Attribute_Reference (Loc,
+             Prefix         => New_Occurrence_Of (Component_Typ, Loc),
+             Attribute_Name => Name_Put_Image,
+             Expressions    => New_List (
+               Make_Identifier (Loc, Name_S),
+               Make_Selected_Component (Loc,
+                 Prefix        => Make_Identifier (Loc, Name_V),
+                 Selector_Name => New_Occurrence_Of (C, Loc)))));
       end Append_Component_Attr;
 
       -------------------------------
@@ -944,9 +942,38 @@ package body Exp_Put_Image is
 
          --  Generate Put_Images for the discriminants of the type
 
-         Append_List_To (Stms,
-           Make_Component_Attributes
-             (Discriminant_Specifications (Type_Decl)));
+         declare
+            Discrim_Specs : List_Id := Discriminant_Specifications (Type_Decl);
+            Partial_View  : Entity_Id;
+         begin
+            if Present (First (Discrim_Specs))
+              and then Ekind (Defining_Identifier (First (Discrim_Specs))) =
+                       E_Void
+            then
+               --  If the known discriminant part is repeated for the
+               --  completion of a private type declaration, then the
+               --  second copy is (by design) not analyzed. So we'd better
+               --  use the first copy instead.
+
+               Partial_View := Incomplete_Or_Partial_View
+                                 (Defining_Identifier (Type_Decl));
+
+               pragma Assert (Ekind (Partial_View) in
+                              E_Private_Type
+                                | E_Limited_Private_Type
+                                | E_Record_Type_With_Private);
+
+               Discrim_Specs :=
+                 Discriminant_Specifications (Parent (Partial_View));
+
+               pragma Assert (Present (First (Discrim_Specs)));
+               pragma Assert
+                 (Ekind (Defining_Identifier (First (Discrim_Specs))) /=
+                  E_Void);
+            end if;
+
+            Append_List_To (Stms, Make_Component_Attributes (Discrim_Specs));
+         end;
 
          Rdef := Type_Definition (Type_Decl);