einfo.ads (Extra_Accessibility_Of_Result): New function...

2011-09-06  Steve Baird  <baird@adacore.com>

	* einfo.ads (Extra_Accessibility_Of_Result): New function; in the
	(Ada2012) cases described in AI05-0234 where the accessibility
	level of a function result is "determined by the point of
	call", an implicit parameter representing that accessibility
	level is passed in. Extra_Accessibilty_Of_Result yields this
	additional formal parameter. Extra_Accessibility_Of_Result
	is analogous to the existing Extra_Accessibility
	function used in the implementation of access parameters.
	(Set_Extra_Accessibility_Of_Result): New procedure; sets
	Extra_Accessibility_Of_Result attribute.
	* einfo.adb (Extra_Accessibility_Of_Result): New function.
	(Set_Extra_Accessibility_Of_Result): New procedure.
	(Write_Field19_Name): Display Extra_Accessibilty_Of_Result attribute.
	* sem_util.adb (Dynamic_Accessibility_Level): Set Etype of
	an accessibility level literal to Natural; introduce a nested
	function, Make_Level_Literal, to do this.
	* exp_ch6.ads (Needs_Result_Accessibility_Level): New function;
	determines whether a given function (or access-to-function
	type) needs to have an implicitly-declared accessibility-level
	parameter added to its profile.
	(Add_Extra_Actual_To_Call): Export an existing procedure which was
	previously declared in the body of Exp_Ch6.
	* exp_ch6.adb (Add_Extra_Actual_To_Call): Export declaration by moving
	it to exp_ch6.ads.
	(Has_Unconstrained_Access_Discriminants): New Function; a
	predicate on subtype entities which returns True if the given
	subtype is unconstrained and has one or more access discriminants.
	(Expand_Call): When expanding a call to a function which takes an
	Extra_Accessibility_Of_Result parameter, pass in the appropriate
	actual parameter value. In the case of a function call which is
	used to initialize an allocator, this may not be possible because
	the Etype of the allocator may not have been set yet. In this
	case, we defer passing in the parameter and handle it later in
	Expand_Allocator_Expression.
	(Expand_Simple_Function_Return): When returning from a function which
	returns an unconstrained subtype having at least one access
	discriminant, generate the accessibility check needed to ensure that
	the function result will not outlive any objects designated by its
	discriminants.
	(Needs_Result_Accessibility_Level): New function; see exp_ch6.ads
	description.
	* exp_ch4.adb (Expand_Allocator_Expression): When a function call
	is used to initialize an allocator, we may need to pass in "the
	accessibility level determined by the point of call" (AI05-0234)
	to the function. Expand_Call, where such actual parameters are
	usually generated, is too early in this case because the Etype of
	the allocator (which is used in determining the level to be passed
	in) may not have been set yet when Expand_Call executes. Instead,
	we generate code to pass in the appropriate actual parameter
	in Expand_Allocator_Expression.
	* sem_ch6.adb (Create_Extra_Formals): Create
	the new Extra_Accessibility_Of_Result formal if
	Needs_Result_Accessibility_Level returns True. This includes the
	introduction of a nested procedure, Check_Against_Result_Level.

From-SVN: r178567

gcc/ada/ChangeLog

+2011-09-06  Steve Baird  <baird@adacore.com>
+
+	* einfo.ads (Extra_Accessibility_Of_Result): New function; in the
+	(Ada2012) cases described in AI05-0234 where the accessibility
+	level of a function result is "determined by the point of
+	call", an implicit parameter representing that accessibility
+	level is passed in. Extra_Accessibilty_Of_Result yields this
+	additional formal parameter. Extra_Accessibility_Of_Result
+	is analogous to the existing Extra_Accessibility
+	function used in the implementation of access parameters.
+	(Set_Extra_Accessibility_Of_Result): New procedure; sets
+	Extra_Accessibility_Of_Result attribute.
+	* einfo.adb (Extra_Accessibility_Of_Result): New function.
+	(Set_Extra_Accessibility_Of_Result): New procedure.
+	(Write_Field19_Name): Display Extra_Accessibilty_Of_Result attribute.
+	* sem_util.adb (Dynamic_Accessibility_Level): Set Etype of
+	an accessibility level literal to Natural; introduce a nested
+	function, Make_Level_Literal, to do this.
+	* exp_ch6.ads (Needs_Result_Accessibility_Level): New function;
+	determines whether a given function (or access-to-function
+	type) needs to have an implicitly-declared accessibility-level
+	parameter added to its profile.
+	(Add_Extra_Actual_To_Call): Export an existing procedure which was
+	previously declared in the body of Exp_Ch6.
+	* exp_ch6.adb (Add_Extra_Actual_To_Call): Export declaration by moving
+	it to exp_ch6.ads.
+	(Has_Unconstrained_Access_Discriminants): New Function; a
+	predicate on subtype entities which returns True if the given
+	subtype is unconstrained and has one or more access discriminants.
+	(Expand_Call): When expanding a call to a function which takes an
+	Extra_Accessibility_Of_Result parameter, pass in the appropriate
+	actual parameter value. In the case of a function call which is
+	used to initialize an allocator, this may not be possible because
+	the Etype of the allocator may not have been set yet. In this
+	case, we defer passing in the parameter and handle it later in
+	Expand_Allocator_Expression.
+	(Expand_Simple_Function_Return): When returning from a function which
+	returns an unconstrained subtype having at least one access
+	discriminant, generate the accessibility check needed to ensure that
+	the function result will not outlive any objects designated by its
+	discriminants.
+	(Needs_Result_Accessibility_Level): New function; see exp_ch6.ads
+	description.
+	* exp_ch4.adb (Expand_Allocator_Expression): When a function call
+	is used to initialize an allocator, we may need to pass in "the
+	accessibility level determined by the point of call" (AI05-0234)
+	to the function. Expand_Call, where such actual parameters are
+	usually generated, is too early in this case because the Etype of
+	the allocator (which is used in determining the level to be passed
+	in) may not have been set yet when Expand_Call executes. Instead,
+	we generate code to pass in the appropriate actual parameter
+	in Expand_Allocator_Expression.
+	* sem_ch6.adb (Create_Extra_Formals): Create
+	the new Extra_Accessibility_Of_Result formal if
+	Needs_Result_Accessibility_Level returns True. This includes the
+	introduction of a nested procedure, Check_Against_Result_Level.
+
 2011-09-06  Arnaud Charlet  <charlet@adacore.com>
 
 	* gcc-interface/Makefile.in (X86_TARGET_PAIRS): Remove duplicate

gcc/ada/einfo.adb

@@ -161,6 +161,7 @@ package body Einfo is
 
    --    Body_Entity                     Node19
    --    Corresponding_Discriminant      Node19
+   --    Extra_Accessibility_Of_Result   Node19
    --    Parent_Subtype                  Node19
    --    Related_Array_Object            Node19
    --    Size_Check_Code                 Node19
@@ -1043,6 +1044,12 @@ package body Einfo is
       return Node13 (Id);
    end Extra_Accessibility;
 
+   function Extra_Accessibility_Of_Result (Id : E) return E is
+   begin
+      pragma Assert (Ekind_In (Id, E_Function, E_Operator, E_Subprogram_Type));
+      return Node19 (Id);
+   end Extra_Accessibility_Of_Result;
+
    function Extra_Constrained (Id : E) return E is
    begin
       pragma Assert (Is_Formal (Id) or else Ekind (Id) = E_Variable);
@@ -3519,6 +3526,12 @@ package body Einfo is
       Set_Node13 (Id, V);
    end Set_Extra_Accessibility;
 
+   procedure Set_Extra_Accessibility_Of_Result (Id : E; V : E) is
+   begin
+      pragma Assert (Ekind_In (Id, E_Function, E_Operator, E_Subprogram_Type));
+      Set_Node19 (Id, V);
+   end Set_Extra_Accessibility_Of_Result;
+
    procedure Set_Extra_Constrained (Id : E; V : E) is
    begin
       pragma Assert (Is_Formal (Id) or else Ekind (Id) = E_Variable);
@@ -8312,6 +8325,9 @@ package body Einfo is
          when Private_Kind                                 =>
             Write_Str ("Underlying_Full_View");
 
+         when E_Function | E_Operator | E_Subprogram_Type =>
+            Write_Str ("Extra_Accessibility_Of_Result");
+
          when others                                       =>
             Write_Str ("Field19??");
       end case;

gcc/ada/einfo.ads

@@ -1131,6 +1131,15 @@ package Einfo is
 --       must be retrieved through the entity designed by this field instead of
 --       being computed.
 
+--    Extra_Accessibility_Of_Result (Node19)
+--       Present in (non-generic) Function, Operator, and Subprogram_Type
+--       entities if expansion is active. Normally Empty, but if a function is
+--       one for which "the accessibility level of the result ... determined
+--       by the point of call" (AI05-0234) is needed, then an extra formal of
+--       subtype Natural is created (see description of field Extra_Formal),
+--       and the Extra_Accessibility_Of_Result field of the function points to
+--       the entity for this extra formal.
+
 --    Extra_Constrained (Node23)
 --       Present in formal parameters in the non-generic case if expansion is
 --       active. Normally Empty, but if a parameter is one for which a dynamic
@@ -5235,6 +5244,7 @@ package Einfo is
    --    First_Entity                        (Node17)
    --    Alias                               (Node18)   (non-generic case only)
    --    Renamed_Entity                      (Node18)   (generic case only)
+   --    Extra_Accessibility_Of_Result       (Node19)   (non-generic case only)
    --    Last_Entity                         (Node20)
    --    Interface_Name                      (Node21)
    --    Scope_Depth_Value                   (Uint22)
@@ -5389,6 +5399,7 @@ package Einfo is
    --  E_Operator
    --    First_Entity                        (Node17)
    --    Alias                               (Node18)
+   --    Extra_Accessibility_Of_Result       (Node19)
    --    Last_Entity                         (Node20)
    --    Overridden_Operation                (Node26)
    --    Subprograms_For_Type                (Node29)
@@ -5680,6 +5691,7 @@ package Einfo is
    --    Scope_Depth                         (synth)
 
    --  E_Subprogram_Type
+   --    Extra_Accessibility_Of_Result       (Node19)
    --    Directly_Designated_Type            (Node20)
    --    Extra_Formals                       (Node28)
    --    First_Formal                        (synth)
@@ -6068,6 +6080,7 @@ package Einfo is
    function Esize                               (Id : E) return U;
    function Exception_Code                      (Id : E) return U;
    function Extra_Accessibility                 (Id : E) return E;
+   function Extra_Accessibility_Of_Result       (Id : E) return E;
    function Extra_Constrained                   (Id : E) return E;
    function Extra_Formal                        (Id : E) return E;
    function Extra_Formals                       (Id : E) return E;
@@ -6656,6 +6669,7 @@ package Einfo is
    procedure Set_Esize                           (Id : E; V : U);
    procedure Set_Exception_Code                  (Id : E; V : U);
    procedure Set_Extra_Accessibility             (Id : E; V : E);
+   procedure Set_Extra_Accessibility_Of_Result   (Id : E; V : E);
    procedure Set_Extra_Constrained               (Id : E; V : E);
    procedure Set_Extra_Formal                    (Id : E; V : E);
    procedure Set_Extra_Formals                   (Id : E; V : E);

gcc/ada/exp_ch4.adb

@@ -765,11 +765,38 @@ package body Exp_Ch4 is
    --  Start of processing for Expand_Allocator_Expression
 
    begin
-      --  WOuld be nice to comment the branches of this very long if ???
+      --  Messy???
 
-      if Is_Tagged_Type (T)
-        or else Needs_Finalization (T)
-      then
+      --  In the case of an Ada2012 allocator whose initial value comes from a
+      --  function call, pass "the accessibility level determined by the point
+      --  of call" (AI05-0234) to the function. Conceptually, this belongs in
+      --  Expand_Call but it couldn't be done there (because the Etype of the
+      --  allocator wasn't set then) so we generate the parameter here. See
+      --  the Boolean variable Defer in (a block within) Expand_Call.
+
+      if Ada_Version >= Ada_2012 and then Nkind (Exp) = N_Function_Call then
+         declare
+            Subp : Entity_Id;
+
+         begin
+            if Nkind (Name (Exp)) = N_Explicit_Dereference then
+               Subp := Designated_Type (Etype (Prefix (Name (Exp))));
+            else
+               Subp := Entity (Name (Exp));
+            end if;
+
+            if Present (Extra_Accessibility_Of_Result (Subp)) then
+               Add_Extra_Actual_To_Call
+                 (Subprogram_Call => Exp,
+                  Extra_Formal    => Extra_Accessibility_Of_Result (Subp),
+                  Extra_Actual    => Dynamic_Accessibility_Level (PtrT));
+            end if;
+         end;
+      end if;
+
+      --  Would be nice to comment the branches of this very long if ???
+
+      if Is_Tagged_Type (T) or else Needs_Finalization (T) then
          if Is_CPP_Constructor_Call (Exp) then
 
             --  Generate:
@@ -811,10 +838,10 @@ package body Exp_Ch4 is
 
                Insert_List_After_And_Analyze (P,
                  Build_Initialization_Call (Loc,
-                   Id_Ref =>
+                   Id_Ref          =>
                      Make_Explicit_Dereference (Loc,
                        Prefix => New_Reference_To (Temp, Loc)),
-                   Typ => Etype (Exp),
+                   Typ             => Etype (Exp),
                    Constructor_Ref => Exp));
             end;
 

gcc/ada/exp_ch6.ads

@@ -205,4 +205,17 @@ package Exp_Ch6 is
    --  Ada 2005 (AI-318-02): Return True if the function needs an implicit
    --  BIP_Alloc_Form parameter (see type BIP_Formal_Kind).
 
+   function Needs_Result_Accessibility_Level
+     (Func_Id : Entity_Id) return Boolean;
+   --  Ada 2012 (AI05-0234): Return True if the function needs an implicit
+   --  parameter to identify the accessibility level of the function result
+   --  "determined by the point of call".
+
+   procedure Add_Extra_Actual_To_Call
+     (Subprogram_Call : Node_Id;
+      Extra_Formal    : Entity_Id;
+      Extra_Actual    : Node_Id);
+   --  Adds Extra_Actual as a named parameter association for the formal
+   --  Extra_Formal in Subprogram_Call.
+
 end Exp_Ch6;

gcc/ada/sem_ch6.adb

@@ -6296,7 +6296,7 @@ package body Sem_Ch6 is
       --  build-in-place formals are needed in some cases (limited 'Input).
 
       if Is_Predefined_Internal_Operation (E) then
-         goto Test_For_BIP_Extras;
+         goto Test_For_Func_Result_Extras;
       end if;
 
       Formal := First_Formal (E);
@@ -6395,7 +6395,15 @@ package body Sem_Ch6 is
          Next_Formal (Formal);
       end loop;
 
-      <<Test_For_BIP_Extras>>
+      <<Test_For_Func_Result_Extras>>
+
+      --  Ada 2012 (AI05-234): "the accessibility level of the result of a
+      --  function call is ... determined by the point of call ...".
+
+      if Needs_Result_Accessibility_Level (E) then
+         Set_Extra_Accessibility_Of_Result
+           (E, Add_Extra_Formal (E, Standard_Natural, E, "L"));
+      end if;
 
       --  Ada 2005 (AI-318-02): In the case of build-in-place functions, add
       --  appropriate extra formals. See type Exp_Ch6.BIP_Formal_Kind.

gcc/ada/sem_util.adb

@@ -2878,6 +2878,22 @@ package body Sem_Util is
    function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id is
       E : Entity_Id;
       Loc : constant Source_Ptr := Sloc (Expr);
+
+      function Make_Level_Literal (Level : Uint) return Node_Id;
+      --  Construct an integer literal representing an accessibility level.
+
+      ---------------------------------
+      -- function Make_Level_Literal --
+      ---------------------------------
+
+      function Make_Level_Literal (Level : Uint) return Node_Id is
+         Result : constant Node_Id :=
+                    Make_Integer_Literal (Loc, Level);
+      begin
+         Set_Etype (Result, Standard_Natural);
+         return Result;
+      end Make_Level_Literal;
+
    begin
       if Is_Entity_Name (Expr) then
          E := Entity (Expr);
@@ -2903,7 +2919,7 @@ package body Sem_Util is
               and then Ekind (Etype (Entity (Selector_Name (Expr)))) =
               E_Anonymous_Access_Type then
 
-               return Make_Integer_Literal (Loc, Object_Access_Level (Expr));
+               return Make_Level_Literal (Object_Access_Level (Expr));
             end if;
 
          when N_Attribute_Reference =>
@@ -2912,15 +2928,14 @@ package body Sem_Util is
                --  For X'Access, the level of the prefix X
 
                when Attribute_Access =>
-                  return Make_Integer_Literal (Loc,
-                    Object_Access_Level (Prefix (Expr)));
+                  return Make_Level_Literal
+                           (Object_Access_Level (Prefix (Expr)));
 
                --  Treat the unchecked attributes as library-level
 
                when Attribute_Unchecked_Access |
                  Attribute_Unrestricted_Access =>
-                  return Make_Integer_Literal (Loc,
-                    Scope_Depth (Standard_Standard));
+                  return Make_Level_Literal (Scope_Depth (Standard_Standard));
 
                --  No other access-valued attributes
 
@@ -2947,7 +2962,7 @@ package body Sem_Util is
             null;
       end case;
 
-      return Make_Integer_Literal (Loc, Type_Access_Level (Etype (Expr)));
+      return Make_Level_Literal (Type_Access_Level (Etype (Expr)));
    end Dynamic_Accessibility_Level;
 
    -----------------------------------