exp_attr.adb (Expand_N_Attribute_Reference): Case Access, Unchecked_Access, and…

exp_attr.adb (Expand_N_Attribute_Reference): Case Access, Unchecked_Access, and Unrestricted_Access.

2007-10-15  Javier Miranda  <miranda@adacore.com>

	* exp_attr.adb (Expand_N_Attribute_Reference): Case Access,
	Unchecked_Access, and Unrestricted_Access. Cleanup code that takes
	care of access to class-wide interface types plus removal of bizarre
	conversion of tagged object to access type (reported by Gary
	Dismukes). After this patch there is no need to perform any
	additional management on these nodes in Expand_Interface_Actuals.

	* exp_disp.adb (Expand_Interface_Actuals): Code cleanup. Remove code
	that handles use of 'Access and 'Unchecked_Access applied to
	actuals covering interface types. Such code is now
	centralized in Expand_N_Attribute_Reference.

From-SVN: r129322

gcc/ada/exp_attr.adb

@@ -606,10 +606,15 @@ package body Exp_Attr is
            Attribute_Unchecked_Access    |
            Attribute_Unrestricted_Access =>
 
+         Access_Cases : declare
+            Btyp_DDT   : constant Entity_Id := Directly_Designated_Type (Btyp);
+            Ref_Object : constant Node_Id := Get_Referenced_Object (Pref);
+
+         begin
             if Is_Access_Protected_Subprogram_Type (Btyp) then
                Expand_Access_To_Protected_Op (N, Pref, Typ);
 
-         --  If the prefix is a type name, this is a reference to the current
+            --  If prefix is a type name, this is a reference to the current
             --  instance of the type, within its initialization procedure.
 
             elsif Is_Entity_Name (Pref)
@@ -620,11 +625,12 @@ package body Exp_Attr is
                   Formal : Entity_Id;
 
                begin
-               --  If the current instance name denotes a task type, then the
-               --  access attribute is rewritten to be the name of the "_task"
-               --  parameter associated with the task type's task procedure.
-               --  An unchecked conversion is applied to ensure a type match in
-               --  cases of expander-generated calls (e.g., init procs).
+                  --  If the current instance name denotes a task type, then
+                  --  the access attribute is rewritten to be the name of the
+                  --  "_task" parameter associated with the task type's task
+                  --  procedure. An unchecked conversion is applied to ensure
+                  --  a type match in cases of expander-generated calls (e.g.
+                  --  init procs).
 
                   if Is_Task_Type (Entity (Pref)) then
                      Formal :=
@@ -641,9 +647,10 @@ package body Exp_Attr is
                          New_Occurrence_Of (Formal, Loc)));
                      Set_Etype (N, Typ);
 
-               --  The expression must appear in a default expression, (which
-               --  in the initialization procedure is the right-hand side of an
-               --  assignment), and not in a discriminant constraint.
+                     --  The expression must appear in a default expression,
+                     --  (which in the initialization procedure is the
+                     --  right-hand side of an assignment), and not in a
+                     --  discriminant constraint.
 
                   else
                      Par := Parent (N);
@@ -668,24 +675,6 @@ package body Exp_Attr is
                   end if;
                end;
 
-         --  The following handles cases involving interfaces and when the
-         --  prefix of an access attribute is an explicit dereference. In the
-         --  case where the access attribute is specifically Attribute_Access,
-         --  we only do this when the context type is E_General_Access_Type,
-         --  and not for anonymous access types. It seems that this code should
-         --  be used for anonymous contexts as well, but that causes various
-         --  regressions, such as on prefix-notation calls to dispatching
-         --  operations and back-end errors on access type conversions. ???
-
-         elsif Id /= Attribute_Access
-           or else Ekind (Btyp) = E_General_Access_Type
-         then
-            declare
-               Ref_Object : constant Node_Id := Get_Referenced_Object (Pref);
-               Parm_Ent   : Entity_Id;
-               Conversion : Node_Id;
-
-            begin
             --  If the prefix of an Access attribute is a dereference of an
             --  access parameter (or a renaming of such a dereference) and
             --  the context is a general access type (but not an anonymous
@@ -702,59 +691,70 @@ package body Exp_Attr is
             --  is access-to-variable and the access parameter is
             --  access-to-constant. The conversion is only done to get
             --  accessibility checks, so it makes sense to limit it to
-               --  'Access (and consistent with existing comment).
+            --  'Access.
 
-               if Nkind (Ref_Object) = N_Explicit_Dereference
+            elsif Nkind (Ref_Object) = N_Explicit_Dereference
               and then Is_Entity_Name (Prefix (Ref_Object))
-                 and then Id = Attribute_Access
-               then
-                  Parm_Ent := Entity (Prefix (Ref_Object));
-
-                  if Ekind (Parm_Ent) in Formal_Kind
-                    and then Ekind (Etype (Parm_Ent)) = E_Anonymous_Access_Type
-                    and then Present (Extra_Accessibility (Parm_Ent))
+              and then Ekind (Btyp) = E_General_Access_Type
+              and then Ekind (Entity (Prefix (Ref_Object))) in Formal_Kind
+              and then Ekind (Etype (Entity (Prefix (Ref_Object))))
+                         = E_Anonymous_Access_Type
+              and then Present (Extra_Accessibility
+                                (Entity (Prefix (Ref_Object))))
             then
-                     Conversion :=
-                       Convert_To (Typ, New_Copy_Tree (Prefix (Ref_Object)));
-
-                     Rewrite (N, Conversion);
+               Rewrite (N,
+                 Convert_To (Typ, New_Copy_Tree (Prefix (Ref_Object))));
                Analyze_And_Resolve (N, Typ);
 
-                     return;
-                  end if;
-               end if;
+            --  Ada 2005 (AI-251): If the designated type is an interface we
+            --  add an implicit conversion to force the displacement of the
+            --  pointer to reference the secondary dispatch table.
 
-               --  Ada 2005 (AI-251): If the designated type is an interface,
-               --  then rewrite the referenced object as a conversion, to force
-               --  the displacement of the pointer to the secondary dispatch
-               --  table.
+            elsif Is_Interface (Btyp_DDT)
+              and then (Comes_From_Source (N)
+                         or else Comes_From_Source (Ref_Object)
+                         or else (Nkind (Ref_Object) in N_Has_Chars
+                                   and then Chars (Ref_Object) = Name_uInit))
+            then
+               if Nkind (Ref_Object) /= N_Explicit_Dereference then
 
-               if Is_Interface (Directly_Designated_Type (Btyp)) then
+                  --  No implicit conversion required if types match
 
-                  --  When the object is an explicit dereference, just convert
-                  --  the dereference's prefix.
+                  if Btyp_DDT /= Etype (Ref_Object) then
+                     Rewrite (Prefix (N),
+                       Convert_To (Directly_Designated_Type (Typ),
+                         New_Copy_Tree (Prefix (N))));
 
-                  if Nkind (Ref_Object) = N_Explicit_Dereference then
-                     Conversion :=
-                       Convert_To (Typ, New_Copy_Tree (Prefix (Ref_Object)));
+                     Analyze_And_Resolve (Prefix (N),
+                                          Directly_Designated_Type (Typ));
+                  end if;
 
-                  --  It seems rather bizarre that we generate a conversion of
-                  --  a tagged object to an access type, since such conversions
-                  --  are not normally permitted, but Expand_N_Type_Conversion
-                  --  (actually Expand_Interface_Conversion) is designed to
-                  --  handle them in the interface case. Do we really want to
-                  --  create such odd conversions???
+               --  When the object is an explicit dereference, convert the
+               --  dereference's prefix.
 
                else
-                     Conversion :=
-                       Convert_To (Typ, New_Copy_Tree (Ref_Object));
-                  end if;
+                  declare
+                     Obj_DDT : constant Entity_Id :=
+                                 Base_Type
+                                   (Directly_Designated_Type
+                                     (Etype (Prefix (Ref_Object))));
+                  begin
+                     --  No implicit conversion required if designated types
+                     --  match.
 
-                  Rewrite (N, Conversion);
+                     if Obj_DDT /= Btyp_DDT
+                       and then not (Is_Class_Wide_Type (Obj_DDT)
+                                       and then Etype (Obj_DDT) = Btyp_DDT)
+                     then
+                        Rewrite (N,
+                          Convert_To (Typ,
+                            New_Copy_Tree (Prefix (Ref_Object))));
                         Analyze_And_Resolve (N, Typ);
                      end if;
                   end;
                end if;
+            end if;
+         end Access_Cases;
 
       --------------
       -- Adjacent --

gcc/ada/exp_disp.adb

@@ -1011,7 +1011,6 @@ package body Exp_Disp is
    ------------------------------
 
    procedure Expand_Interface_Actuals (Call_Node : Node_Id) is
-      Loc        : constant Source_Ptr := Sloc (Call_Node);
       Actual     : Node_Id;
       Actual_Dup : Node_Id;
       Actual_Typ : Entity_Id;
@@ -1020,7 +1019,6 @@ package body Exp_Disp is
       Formal     : Entity_Id;
       Formal_Typ : Entity_Id;
       Subp       : Entity_Id;
-      Nam        : Name_Id;
       Formal_DDT : Entity_Id;
       Actual_DDT : Entity_Id;
 
@@ -1106,18 +1104,13 @@ package body Exp_Disp is
                (Attribute_Name (Actual) = Name_Access
                  or else Attribute_Name (Actual) = Name_Unchecked_Access)
             then
-               Nam := Attribute_Name (Actual);
-
-               Conversion := Convert_To (Formal_DDT, Prefix (Actual));
-               Rewrite (Actual, Conversion);
-               Analyze_And_Resolve (Actual, Formal_DDT);
+               --  This case must have been handled by the analysis and
+               --  expansion of 'Access. The only exception is when types
+               --  match and no further expansion is required.
 
-               Rewrite (Actual,
-                 Unchecked_Convert_To (Formal_Typ,
-                   Make_Attribute_Reference (Loc,
-                     Prefix => Relocate_Node (Actual),
-                     Attribute_Name => Nam)));
-               Analyze_And_Resolve (Actual, Formal_Typ);
+               pragma Assert (Base_Type (Etype (Prefix (Actual)))
+                               = Base_Type (Formal_DDT));
+               null;
 
             --  No need to displace the pointer if the type of the actual
             --  coincides with the type of the formal.