exp_attr.adb (Enclosing_Object): New function local to handling of access attributes...

2008-07-31  Gary Dismukes  <dismukes@adacore.com>

	* exp_attr.adb (Enclosing_Object): New function local to handling of
	access attributes,
	for retrieving the innermost enclosing object prefix of a compound name.
	(Expand_N_Attribute_Reference, N_Attribute_Access): In the case where an
	Access attribute has a prefix that is a dereference of an access
	parameter (or the prefix is a subcomponent selected from such a
	dereference), apply an accessibility check to the access parameter.
	Replaces code that rewrote the prefix as a type conversion (and that
	didn't handle subcomponent cases).
	Also, this is now only applied in the case of 'Access.

	* exp_ch6.adb (Expand_Call): Add handling for the case of an access
	discriminant passed as an actual to an access formal, passing the
	Object_Access_Level of the object containing the access discriminant.

From-SVN: r138388

diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 006b8f8..6ad5568 100644 (file)
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -651,6 +651,37 @@ package body Exp_Attr is
             Btyp_DDT   : constant Entity_Id := Directly_Designated_Type (Btyp);
             Ref_Object : constant Node_Id := Get_Referenced_Object (Pref);
 
+            function Enclosing_Object (N : Node_Id) return Node_Id;
+            --  If N denotes a compound name (selected component, indexed
+            --  component, or slice), returns the name of the outermost
+            --  such enclosing object. Otherwise returns N. If the object
+            --  is a renaming, then the renamed object is returned.
+
+            ----------------------
+            -- Enclosing_Object --
+            ----------------------
+
+            function Enclosing_Object (N : Node_Id) return Node_Id is
+               Obj_Name : Node_Id;
+
+            begin
+               Obj_Name := N;
+               while Nkind_In (Obj_Name, N_Selected_Component,
+                                         N_Indexed_Component,
+                                         N_Slice)
+               loop
+                  Obj_Name := Prefix (Obj_Name);
+               end loop;
+
+               return Get_Referenced_Object (Obj_Name);
+            end Enclosing_Object;
+
+            --  Local declarations
+
+            Enc_Object : constant Node_Id := Enclosing_Object (Ref_Object);
+
+         --  Start of processing for Access_Cases
+
          begin
             --  In order to improve the text of error messages, the designated
             --  type of access-to-subprogram itypes is set by the semantics as
@@ -800,35 +831,28 @@ package body Exp_Attr is
                end;
 
             --  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
-            --  access type), then rewrite the attribute as a conversion of
-            --  the access parameter to the context access type. This will
-            --  result in an accessibility check being performed, if needed.
-
-            --    (X.all'Access => Acc_Type (X))
-
-            --  Note: Limit the expansion of an attribute applied to a
-            --  dereference of an access parameter so that it's only done
-            --  for 'Access. This fixes a problem with 'Unrestricted_Access
-            --  that leads to errors in the case where the attribute type
-            --  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.
-
-            elsif Nkind (Ref_Object) = N_Explicit_Dereference
-              and then Is_Entity_Name (Prefix (Ref_Object))
+            --  access parameter (or a renaming of such a dereference, or a
+            --  subcomponent of such a dereference) and the context is a
+            --  general access type (but not an anonymous access type), then
+            --  apply an accessibility check to the access parameter. We used
+            --  to rewrite the access parameter as a type conversion, but that
+            --  could only be done if the immediate prefix of the Access
+            --  attribute was the dereference, and didn't handle cases where
+            --  the attribute is applied to a subcomponent of the dereference,
+            --  since there's generally no available, appropriate access type
+            --  to convert to in that case.
+
+            elsif Id = Attribute_Access
+              and then Nkind (Enc_Object) = N_Explicit_Dereference
+              and then Is_Entity_Name (Prefix (Enc_Object))
               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))))
+              and then Ekind (Entity (Prefix (Enc_Object))) in Formal_Kind
+              and then Ekind (Etype (Entity (Prefix (Enc_Object))))
                          = E_Anonymous_Access_Type
               and then Present (Extra_Accessibility
-                                (Entity (Prefix (Ref_Object))))
+                                (Entity (Prefix (Enc_Object))))
             then
-               Rewrite (N,
-                 Convert_To (Typ, New_Copy_Tree (Prefix (Ref_Object))));
-               Analyze_And_Resolve (N, Typ);
+               Apply_Accessibility_Check (Prefix (Enc_Object), Typ);
 
             --  Ada 2005 (AI-251): If the designated type is an interface we
             --  add an implicit conversion to force the displacement of the

diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 3e3c10d..d1d43cf 100644 (file)
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -1,4 +1,4 @@
------------------------------------------------------------------------------
+------------------------------------------------------------------------------
 --                                                                          --
 --                         GNAT COMPILER COMPONENTS                         --
 --                                                                          --
@@ -2070,16 +2070,16 @@ package body Exp_Ch6 is
             if Ekind (Etype (Prev)) in Private_Kind
               and then not Has_Discriminants (Base_Type (Etype (Prev)))
             then
-               Add_Extra_Actual (
-                 New_Occurrence_Of (Standard_False, Loc),
-                 Extra_Constrained (Formal));
+               Add_Extra_Actual
+                 (New_Occurrence_Of (Standard_False, Loc),
+                  Extra_Constrained (Formal));
 
             elsif Is_Constrained (Etype (Formal))
               or else not Has_Discriminants (Etype (Prev))
             then
-               Add_Extra_Actual (
-                 New_Occurrence_Of (Standard_True, Loc),
-                 Extra_Constrained (Formal));
+               Add_Extra_Actual
+                 (New_Occurrence_Of (Standard_True, Loc),
+                  Extra_Constrained (Formal));
 
             --  Do not produce extra actuals for Unchecked_Union parameters.
             --  Jump directly to the end of the loop.
@@ -2220,7 +2220,7 @@ package body Exp_Ch6 is
                      else
                         Add_Extra_Actual
                           (Make_Integer_Literal (Loc,
-                           Intval => Scope_Depth (Standard_Standard)),
+                             Intval => Scope_Depth (Standard_Standard)),
                            Extra_Accessibility (Formal));
                      end if;
                   end;
@@ -2231,11 +2231,25 @@ package body Exp_Ch6 is
                else
                   Add_Extra_Actual
                     (Make_Integer_Literal (Loc,
-                     Intval => Type_Access_Level (Etype (Prev_Orig))),
+                       Intval => Type_Access_Level (Etype (Prev_Orig))),
                      Extra_Accessibility (Formal));
                end if;
 
-            --  All cases other than thunks
+            --  If the actual is an access discriminant, then pass the level
+            --  of the enclosing object (RM05-3.10.2(12.4/2)).
+
+            elsif Nkind (Prev_Orig) = N_Selected_Component
+              and then Ekind (Entity (Selector_Name (Prev_Orig))) =
+                                                       E_Discriminant
+              and then Ekind (Etype (Entity (Selector_Name (Prev_Orig)))) =
+                                                       E_Anonymous_Access_Type
+            then
+               Add_Extra_Actual
+                 (Make_Integer_Literal (Loc,
+                    Intval => Object_Access_Level (Prefix (Prev_Orig))),
+                  Extra_Accessibility (Formal));
+
+            --  All other cases
 
             else
                case Nkind (Prev_Orig) is
@@ -2246,20 +2260,20 @@ package body Exp_Ch6 is
                         --  For X'Access, pass on the level of the prefix X
 
                         when Attribute_Access =>
-                           Add_Extra_Actual (
-                             Make_Integer_Literal (Loc,
-                               Intval =>
-                                 Object_Access_Level (Prefix (Prev_Orig))),
-                             Extra_Accessibility (Formal));
+                           Add_Extra_Actual
+                             (Make_Integer_Literal (Loc,
+                                Intval =>
+                                  Object_Access_Level (Prefix (Prev_Orig))),
+                              Extra_Accessibility (Formal));
 
                         --  Treat the unchecked attributes as library-level
 
                         when Attribute_Unchecked_Access |
                            Attribute_Unrestricted_Access =>
-                           Add_Extra_Actual (
-                             Make_Integer_Literal (Loc,
-                               Intval => Scope_Depth (Standard_Standard)),
-                             Extra_Accessibility (Formal));
+                           Add_Extra_Actual
+                             (Make_Integer_Literal (Loc,
+                                Intval => Scope_Depth (Standard_Standard)),
+                              Extra_Accessibility (Formal));
 
                         --  No other cases of attributes returning access
                         --  values that can be passed to access parameters
@@ -2274,19 +2288,19 @@ package body Exp_Ch6 is
                   --  current scope level.
 
                   when N_Allocator =>
-                     Add_Extra_Actual (
-                       Make_Integer_Literal (Loc,
-                        Scope_Depth (Current_Scope) + 1),
-                       Extra_Accessibility (Formal));
+                     Add_Extra_Actual
+                       (Make_Integer_Literal (Loc,
+                          Intval => Scope_Depth (Current_Scope) + 1),
+                        Extra_Accessibility (Formal));
 
                   --  For other cases we simply pass the level of the
                   --  actual's access type.
 
                   when others =>
-                     Add_Extra_Actual (
-                       Make_Integer_Literal (Loc,
-                         Intval => Type_Access_Level (Etype (Prev_Orig))),
-                       Extra_Accessibility (Formal));
+                     Add_Extra_Actual
+                       (Make_Integer_Literal (Loc,
+                          Intval => Type_Access_Level (Etype (Prev_Orig))),
+                        Extra_Accessibility (Formal));
 
                end case;
             end if;