[gcc r12-2030] [Ada] Fix some "current instance" bugs

[gcc r12-2030] [Ada] Fix some "current instance" bugs

[Pierre-Marie de Rodat]

https://gcc.gnu.org/g:77630ba95a5b0220fdbb460727cf12e45a0c1115

commit r12-2030-g77630ba95a5b0220fdbb460727cf12e45a0c1115
Author: Steve Baird <baird@adacore.com>
Date:   Thu Apr 29 11:44:29 2021 -0700

    [Ada] Fix some "current instance" bugs
    
    gcc/ada/
    
            * exp_ch3.adb (Build_Record_Init_Proc.Build_Assignment): When
            building the assignment statement corresponding to the default
            expression for a component, we make a copy of the expression.
            When making that copy (and if we have seen a component that
            requires late initialization), pass a Map parameter into the
            call to New_Copy_Tree to redirect references to the type to
            instead refer to the _Init formal parameter of the init proc.
            This includes hoisting the declaration of Has_Late_Init_Comp out
            one level so that it becomes available to Build_Assignment.
            (Find_Current_Instance): Return True for other kinds of current
            instance references, instead of just access-valued attribute
            references such as T'Access.
            * sem_util.adb (Is_Aliased_View): Return True for the _Init
            formal parameter of an init procedure. The changes in
            exp_ch3.adb can have the effect of replacing a "T'Access"
            attribute reference in an init procedure with an "_Init'Access"
            attribute reference. We want such an attribute reference to be
            legal. However, we do not simply mark the formal parameter as
            being aliased because that might impact callers.
            (Is_Object_Image): Return True if Is_Current_Instance returns
            True for the prefix of an Image (or related attribute) attribute
            reference.

Diff:
---
 gcc/ada/exp_ch3.adb  | 51 ++++++++++++++++++++-------------------------------
 gcc/ada/sem_util.adb | 13 ++++++++++++-
 2 files changed, 32 insertions(+), 32 deletions(-)

diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 2f997a39fc8..504410dd00a 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -1926,6 +1926,7 @@ package body Exp_Ch3 is
       Proc_Id   : Entity_Id;
       Rec_Type  : Entity_Id;
       Set_Tag   : Entity_Id := Empty;
+      Has_Late_Init_Comp : Boolean := False; -- set in Build_Init_Statements
 
       function Build_Assignment
         (Id      : Entity_Id;
@@ -2021,35 +2022,27 @@ package body Exp_Ch3 is
              Selector_Name => New_Occurrence_Of (Id, Default_Loc));
          Set_Assignment_OK (Lhs);
 
-         --  Case of an access attribute applied to the current instance.
-         --  Replace the reference to the type by a reference to the actual
-         --  object. (Note that this handles the case of the top level of
-         --  the expression being given by such an attribute, but does not
-         --  cover uses nested within an initial value expression. Nested
-         --  uses are unlikely to occur in practice, but are theoretically
-         --  possible.) It is not clear how to handle them without fully
-         --  traversing the expression. ???
-
-         if Kind = N_Attribute_Reference
-           and then Attribute_Name (Default) in Name_Unchecked_Access
-                                              | Name_Unrestricted_Access
-           and then Is_Entity_Name (Prefix (Default))
-           and then Is_Type (Entity (Prefix (Default)))
-           and then Entity (Prefix (Default)) = Rec_Type
-         then
-            Exp :=
-              Make_Attribute_Reference (Default_Loc,
-                Prefix         =>
-                  Make_Identifier (Default_Loc, Name_uInit),
-                Attribute_Name => Name_Unrestricted_Access);
-         end if;
-
          --  Take a copy of Exp to ensure that later copies of this component
          --  declaration in derived types see the original tree, not a node
          --  rewritten during expansion of the init_proc. If the copy contains
          --  itypes, the scope of the new itypes is the init_proc being built.
 
-         Exp := New_Copy_Tree (Exp, New_Scope => Proc_Id);
+         declare
+            Map : Elist_Id := No_Elist;
+         begin
+            if Has_Late_Init_Comp then
+               --  Map the type to the _Init parameter in order to
+               --  handle "current instance" references.
+
+               Map := New_Elmt_List
+                        (Elmt1 => Rec_Type,
+                         Elmt2 => Defining_Identifier (First
+                                   (Parameter_Specifications
+                                      (Parent (Proc_Id)))));
+            end if;
+
+            Exp := New_Copy_Tree (Exp, New_Scope => Proc_Id, Map => Map);
+         end;
 
          Res := New_List (
            Make_Assignment_Statement (Loc,
@@ -2981,7 +2974,6 @@ package body Exp_Ch3 is
          Counter_Id         : Entity_Id        := Empty;
          Comp_Loc           : Source_Ptr;
          Decl               : Node_Id;
-         Has_Late_Init_Comp : Boolean;
          Id                 : Entity_Id;
          Parent_Stmts       : List_Id;
          Stmts              : List_Id;
@@ -3097,10 +3089,9 @@ package body Exp_Ch3 is
             function Find_Current_Instance
               (N : Node_Id) return Traverse_Result is
             begin
-               if Nkind (N) = N_Attribute_Reference
-                 and then Is_Access_Type (Etype (N))
-                 and then Is_Entity_Name (Prefix (N))
-                 and then Is_Type (Entity (Prefix (N)))
+               if Is_Entity_Name (N)
+                 and then Present (Entity (N))
+                 and then Is_Current_Instance (N)
                then
                   References_Current_Instance := True;
                   return Abandon;
@@ -3255,8 +3246,6 @@ package body Exp_Ch3 is
          --  step deals with regular components. The second step deals with
          --  components that require late initialization.
 
-         Has_Late_Init_Comp := False;
-
          --  First pass : regular components
 
          Decl := First_Non_Pragma (Component_Items (Comp_List));
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index ef575d0e9f7..7ea809bf5a6 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -15691,6 +15691,15 @@ package body Sem_Util is
            --  statement is aliased if its type is immutably limited.
 
            or else (Is_Return_Object (E)
+                     and then Is_Limited_View (Etype (E)))
+
+           --  The current instance of a limited type is aliased, so
+           --  we want to allow uses of T'Access in the init proc for
+           --  a limited type T. However, we don't want to mark the formal
+           --  parameter as being aliased since that could impact callers.
+
+           or else (Is_Formal (E)
+                     and then Chars (E) = Name_uInit
                      and then Is_Limited_View (Etype (E)));
 
       elsif Nkind (Obj) = N_Selected_Component then
@@ -18838,7 +18847,9 @@ package body Sem_Util is
       --  This is because the parser always checks that prefixes of attributes
       --  are named.
 
-      return not (Is_Entity_Name (Prefix) and then Is_Type (Entity (Prefix)));
+      return not (Is_Entity_Name (Prefix)
+                  and then Is_Type (Entity (Prefix))
+                  and then not Is_Current_Instance (Prefix));
    end Is_Object_Image;
 
    -------------------------