[multiple changes]

2014-07-29  Robert Dewar  <dewar@adacore.com>

	* sem_util.adb, sem_util.ads, sem_res.adb, exp_ch6.adb: Invert
	predicate No_Predicate_Test_On_Arguments, new name is
	Predicate_Tests_On_Arguments (with the opposite sense).

2014-07-29  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_attr.adb (Resolve_Attribute): Clean up the code for
	attribute 'Access. Do not generate an elaboration flag for a
	stand alone expression function. The expression of an expression
	function is now frozen when the expression function appears as
	the prefix of attribute 'Access.
	* sem_ch6.adb (Analyze_Expression_Function): Remove local
	variable New_Decl and update all references to it after the
	rewriting has taken place. Establish the linkages between the
	generated spec and body.

From-SVN: r213212

7 files changed, 140 insertions, 81 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 6a55099..ed9c608 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,5 +1,23 @@
 2014-07-29  Robert Dewar  <dewar@adacore.com>
 
+	* sem_util.adb, sem_util.ads, sem_res.adb, exp_ch6.adb: Invert
+	predicate No_Predicate_Test_On_Arguments, new name is
+	Predicate_Tests_On_Arguments (with the opposite sense).
+
+2014-07-29  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* sem_attr.adb (Resolve_Attribute): Clean up the code for
+	attribute 'Access. Do not generate an elaboration flag for a
+	stand alone expression function. The expression of an expression
+	function is now frozen when the expression function appears as
+	the prefix of attribute 'Access.
+	* sem_ch6.adb (Analyze_Expression_Function): Remove local
+	variable New_Decl and update all references to it after the
+	rewriting has taken place. Establish the linkages between the
+	generated spec and body.
+
+2014-07-29  Robert Dewar  <dewar@adacore.com>
+
 	* sem_prag.adb (ip, rv): Prevent from being optimized away.
 	* gnatls.adb (gnatls): Set E_Fatal exit status if ali file not found.
 	* s-imgllb.adb, s-imgllw.adb, s-imgwiu.adb, s-imgbiu.adb: Minor
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 610aa17..0688a3c 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -1754,7 +1754,7 @@ package body Exp_Ch6 is
 
                  --  Skip predicate checks for special cases
 
-                 and then not No_Predicate_Test_On_Arguments (Subp)
+                 and then Predicate_Tests_On_Arguments (Subp)
                then
                   Append_To (Post_Call,
                     Make_Predicate_Check (Atyp, Actual));
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index bc75fed..20395b4 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -86,7 +86,9 @@ package body Sem_Attr is
    --  used so that we can abandon the processing so we don't run into
    --  trouble with cascaded errors.
 
-   --  The following array is the list of attributes defined in the Ada 83 RM:
+   --  The following array is the list of attributes defined in the Ada 83 RM.
+   --  In Ada 83 mode, these are the only recognized attributes. In other Ada
+   --  modes all these attributes are recognized, even if removed in Ada 95.
 
    Attribute_83 : constant Attribute_Class_Array := Attribute_Class_Array'(
       Attribute_Address                      |
@@ -10565,11 +10567,18 @@ package body Sem_Attr is
                Set_Address_Taken (Entity (P));
             end if;
 
-            if Is_Entity_Name (P) then
+            --  Deal with possible elaboration check
+
+            if Is_Entity_Name (P) and then Is_Subprogram (Entity (P)) then
                declare
-                  E    : constant Entity_Id := Entity (P);
-                  Decl : Node_Id;
-                  Flag : Entity_Id;
+                  Subp_Id   : constant Entity_Id := Entity (P);
+                  Scop      : constant Entity_Id := Scope (Subp_Id);
+                  Subp_Decl : constant Node_Id   :=
+                                Unit_Declaration_Node (Subp_Id);
+
+                  Flag_Id : Entity_Id;
+                  HSS     : Node_Id;
+                  Stmt    : Node_Id;
 
                --  If the access has been taken and the body of the subprogram
                --  has not been see yet, indirect calls must be protected with
@@ -10578,40 +10587,67 @@ package body Sem_Attr is
                --  a subprogram the body will appear in the same declarative
                --  part, and we must insert a check in the eventual body itself
                --  using the elaboration flag that we generate now. The check
-               --  is then inserted when the body is expanded.
+               --  is then inserted when the body is expanded. This processing
+               --  is not needed for a stand alone expression function because
+               --  the internally generated spec and body are always inserted
+               --  as a pair in the same declarative list.
 
                begin
-                  if Is_Subprogram (E)
-                    and then Expander_Active
-                    and then Comes_From_Source (E)
+                  if Expander_Active
+                    and then Comes_From_Source (Subp_Id)
                     and then Comes_From_Source (N)
-                    and then In_Open_Scopes (Scope (E))
-                    and then
-                      Ekind_In (Scope (E), E_Block, E_Procedure, E_Function)
-                    and then not Has_Completion (E)
-                    and then No (Elaboration_Entity (E))
-                    and then Nkind (Unit_Declaration_Node (E)) =
-                                                  N_Subprogram_Declaration
+                    and then In_Open_Scopes (Scop)
+                    and then Ekind_In (Scop, E_Block, E_Procedure, E_Function)
+                    and then not Has_Completion (Subp_Id)
+                    and then No (Elaboration_Entity (Subp_Id))
+                    and then Nkind (Subp_Decl) = N_Subprogram_Declaration
+                    and then Nkind (Original_Node (Subp_Decl)) /=
+                                                       N_Expression_Function
                   then
                      --  Create elaboration variable for it
 
-                     Flag := Make_Temporary (Loc, 'E');
-                     Decl :=
+                     Flag_Id := Make_Temporary (Loc, 'E');
+                     Set_Elaboration_Entity (Subp_Id, Flag_Id);
+                     Set_Is_Frozen (Flag_Id);
+
+                     --  Insert declaration for flag after subprogram
+                     --  declaration. Note that attribute reference may
+                     --  appear within a nested scope.
+
+                     Insert_After_And_Analyze (Subp_Decl,
                        Make_Object_Declaration (Loc,
-                         Defining_Identifier => Flag,
+                         Defining_Identifier => Flag_Id,
                          Object_Definition   =>
                            New_Occurrence_Of (Standard_Short_Integer, Loc),
                          Expression          =>
-                           Make_Integer_Literal (Loc, Uint_0));
-                     Set_Elaboration_Entity (E, Flag);
-                     Set_Is_Frozen (Flag);
+                           Make_Integer_Literal (Loc, Uint_0)));
+                  end if;
 
-                     --  Insert declaration for flag after subprogram
-                     --  declaration. Note that attribute reference may
-                     --  appear within a nested scope.
+                  --  Taking the 'Access of an expression function freezes its
+                  --  expression (RM 13.14 10.3/3). This does not apply to an
+                  --  expression function that acts as a completion because the
+                  --  generated body is immediately analyzed and the expression
+                  --  is automatically frozen.
+
+                  if Ekind (Subp_Id) = E_Function
+                    and then Nkind (Subp_Decl) = N_Subprogram_Declaration
+                    and then Nkind (Original_Node (Subp_Decl)) =
+                                                        N_Expression_Function
+                    and then Present (Corresponding_Body (Subp_Decl))
+                    and then not Analyzed (Corresponding_Body (Subp_Decl))
+                  then
+                     HSS :=
+                       Handled_Statement_Sequence
+                         (Unit_Declaration_Node
+                            (Corresponding_Body (Subp_Decl)));
+
+                     if Present (HSS) then
+                        Stmt := First (Statements (HSS));
 
-                     Insert_After (Unit_Declaration_Node (E), Decl);
-                     Analyze (Decl);
+                        if Nkind (Stmt) = N_Simple_Return_Statement then
+                           Freeze_Expression (Expression (Stmt));
+                        end if;
+                     end if;
                   end if;
                end;
             end if;
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 727a3be..5a99a2c 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -266,7 +266,6 @@ package body Sem_Ch6 is
       --  declaration is completed. Def_Id is needed to analyze the spec.
 
       New_Body : Node_Id;
-      New_Decl : Node_Id;
       New_Spec : Node_Id;
       Ret      : Node_Id;
 
@@ -434,10 +433,7 @@ package body Sem_Ch6 is
               ("an expression function is not a legal protected operation", N);
          end if;
 
-         New_Decl :=
-           Make_Subprogram_Declaration (Loc, Specification => Spec);
-
-         Rewrite (N, New_Decl);
+         Rewrite (N, Make_Subprogram_Declaration (Loc, Specification => Spec));
 
          --  Correct the parent pointer of the aspect specification list to
          --  reference the rewritten node.
@@ -447,7 +443,15 @@ package body Sem_Ch6 is
          end if;
 
          Analyze (N);
-         Set_Is_Inlined (Defining_Entity (New_Decl));
+         Set_Is_Inlined (Defining_Entity (N));
+
+         --  Establish the linkages between the spec and the body. These are
+         --  used when the expression function acts as the prefix of attribute
+         --  'Access in order to freeze the original expression which has been
+         --  moved to the generated body.
+
+         Set_Corresponding_Body (N, Defining_Entity (New_Body));
+         Set_Corresponding_Spec (New_Body, Defining_Entity (N));
 
          --  To prevent premature freeze action, insert the new body at the end
          --  of the current declarations, or at the end of the package spec.
@@ -461,7 +465,7 @@ package body Sem_Ch6 is
          declare
             Decls : List_Id            := List_Containing (N);
             Par   : constant Node_Id   := Parent (Decls);
-            Id    : constant Entity_Id := Defining_Entity (New_Decl);
+            Id    : constant Entity_Id := Defining_Entity (N);
 
          begin
             if Nkind (Par) = N_Package_Specification
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index f559ec3..dab6c8f 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -1974,7 +1974,7 @@ package body Sem_Res is
                   if Nkind (Decl) = N_Subprogram_Body then
                      Spec := Corresponding_Spec (Decl);
 
-                     if not No (Spec) then
+                     if Present (Spec) then
                         Decl := Unit_Declaration_Node (Spec);
                      end if;
                   end if;
@@ -4051,9 +4051,9 @@ package body Sem_Res is
                --  Apply predicate tests except in certain special cases. Note
                --  that it might be more consistent to apply these only when
                --  expansion is active (in Exp_Ch6.Expand_Actuals), as we do
-               --  for the outbound predicate tests.
+               --  for the outbound predicate tests ???
 
-               if not No_Predicate_Test_On_Arguments (Nam) then
+               if Predicate_Tests_On_Arguments (Nam) then
                   Apply_Predicate_Check (A, F_Typ);
                end if;
 
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index e8131cb..4434d5b 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -13785,44 +13785,6 @@ package body Sem_Util is
       Actual_Id := Next_Actual (Actual_Id);
    end Next_Actual;
 
-   ------------------------------------
-   -- No_Predicate_Test_On_Arguments --
-   ------------------------------------
-
-   function No_Predicate_Test_On_Arguments (Subp : Entity_Id) return Boolean is
-   begin
-      --  Do not test predicates on call to generated default Finalize, since
-      --  we are not interested in whether something we are finalizing (and
-      --  typically destroying) satisfies its predicates.
-
-      if Chars (Subp) = Name_Finalize
-        and then not Comes_From_Source (Subp)
-      then
-         return True;
-
-      --  Do not test predicates on call to Init_Proc, since if needed the
-      --  predicate test will occur at some other point.
-
-      elsif Is_Init_Proc (Subp) then
-         return True;
-
-      --  Do not test predicates on call to predicate function, since this
-      --  would cause infinite recursion.
-
-      elsif Ekind (Subp) = E_Function
-        and then (Is_Predicate_Function (Subp)
-                    or else
-                  Is_Predicate_Function_M (Subp))
-      then
-         return True;
-
-      --  For now, no other cases
-
-      else
-         return False;
-      end if;
-   end No_Predicate_Test_On_Arguments;
-
    ---------------------
    -- No_Scalar_Parts --
    ---------------------
@@ -14755,6 +14717,44 @@ package body Sem_Util is
       end if;
    end Original_Corresponding_Operation;
 
+   ----------------------------------
+   -- Predicate_Tests_On_Arguments --
+   ----------------------------------
+
+   function Predicate_Tests_On_Arguments (Subp : Entity_Id) return Boolean is
+   begin
+      --  Do not test predicates on call to generated default Finalize, since
+      --  we are not interested in whether something we are finalizing (and
+      --  typically destroying) satisfies its predicates.
+
+      if Chars (Subp) = Name_Finalize
+        and then not Comes_From_Source (Subp)
+      then
+         return False;
+
+         --  Do not test predicates on call to Init_Proc, since if needed the
+         --  predicate test will occur at some other point.
+
+      elsif Is_Init_Proc (Subp) then
+         return False;
+
+         --  Do not test predicates on call to predicate function, since this
+         --  would cause infinite recursion.
+
+      elsif Ekind (Subp) = E_Function
+        and then (Is_Predicate_Function (Subp)
+                  or else
+                  Is_Predicate_Function_M (Subp))
+      then
+         return False;
+
+         --  For now, no other exceptions
+
+      else
+         return True;
+      end if;
+   end Predicate_Tests_On_Arguments;
+
    -----------------------
    -- Private_Component --
    -----------------------
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 62d995e..970b2ba 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -1582,11 +1582,6 @@ package Sem_Util is
    --  Note that the result produced is always an expression, not a parameter
    --  association node, even if named notation was used.
 
-   function No_Predicate_Test_On_Arguments (Subp : Entity_Id) return Boolean;
-   --  Subp is the entity for a subprogram call. This function returns True to
-   --  eliminate predicate tests on the input or output arguments in a call to
-   --  this subprogram. See body for exact cases currently covered.
-
    function No_Scalar_Parts (T : Entity_Id) return Boolean;
    --  Tests if type T can be determined at compile time to have no scalar
    --  parts in the sense of the Valid_Scalars attribute. Returns True if
@@ -1634,6 +1629,12 @@ package Sem_Util is
    --  Name_uPre, Name_uPost, Name_uInvariant, or Name_uType_Invariant being
    --  returned to represent the corresponding aspects with x'Class names.
 
+   function Predicate_Tests_On_Arguments (Subp : Entity_Id) return Boolean;
+   --  Subp is the entity for a subprogram call. This function returns True if
+   --  predicate tests are required for the arguments in this call (this is the
+   --  normal case). It returns False for special cases where these predicate
+   --  tests should be skipped (see body for details).
+
    function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean;
    --  Returns True if the names of both entities correspond with matching
    --  primitives. This routine includes support for the case in which one