2015-01-07 Ed Schonberg <schonberg@adacore.com>

	* exp_ch5.adb (Expand_Predicated_Loop): Handle properly loops
	over static predicates when the loop parameter specification
	carries a Reverse indicator.

2015-01-07  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch12.adb (Instantiate_Object): If formal has a default,
	actual is missing and formal has an anonymous access type, copy
	access definition in full so that tree for instance is properly
	formatted for ASIS use.

2015-01-07  Bob Duff  <duff@adacore.com>

	* sem_elab.adb (Check_Internal_Call_Continue): Give a warning
	for P'Access, where P is a subprogram in the same package as
	the P'Access, and the P'Access is evaluated at elaboration
	time, and occurs before the body of P. For example, "X : T :=
	P'Access;" would allow a subsequent call to X.all to be an
	access-before-elaboration error; hence the warning. This warning
	is enabled by the -gnatw.f switch.
	* opt.ads (Warn_On_Elab_Access): New flag for warning switch.
	* warnsw.adb (Set_Dot_Warning_Switch): Set Warn_On_Elab_Access.
	* gnat_ugn.texi: Document the new warning.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@219293 138bc75d-0d04-0410-961f-82ee72b054a4

7 files changed, 178 insertions, 49 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 526bf38027b..82a7b793b7c 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,29 @@
+2015-01-07  Ed Schonberg  <schonberg@adacore.com>
+
+	* exp_ch5.adb (Expand_Predicated_Loop): Handle properly loops
+	over static predicates when the loop parameter specification
+	carries a Reverse indicator.
+
+2015-01-07  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch12.adb (Instantiate_Object): If formal has a default,
+	actual is missing and formal has an anonymous access type, copy
+	access definition in full so that tree for instance is properly
+	formatted for ASIS use.
+
+2015-01-07  Bob Duff  <duff@adacore.com>
+
+	* sem_elab.adb (Check_Internal_Call_Continue): Give a warning
+	for P'Access, where P is a subprogram in the same package as
+	the P'Access, and the P'Access is evaluated at elaboration
+	time, and occurs before the body of P. For example, "X : T :=
+	P'Access;" would allow a subsequent call to X.all to be an
+	access-before-elaboration error; hence the warning. This warning
+	is enabled by the -gnatw.f switch.
+	* opt.ads (Warn_On_Elab_Access): New flag for warning switch.
+	* warnsw.adb (Set_Dot_Warning_Switch): Set Warn_On_Elab_Access.
+	* gnat_ugn.texi: Document the new warning.
+
 2015-01-07  Johannes Kanig  <kanig@adacore.com>
 
 	* lib-xref-spark_specific.adb (Collect_SPARK_Xrefs): Skip unneeded
diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb
index fc6141a53ad..5e7f79e1569 100644
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -4120,11 +4120,14 @@ package body Exp_Ch5 is
       --        end loop;
       --     end;
 
+      --  with min-val replaced by max-val and Succ replaced by Pred if the
+      --  loop parameter specification carries a Reverse indicator.
+
       --  To make this a little clearer, let's take a specific example:
 
       --        type Int is range 1 .. 10;
-      --        subtype L is Int with
-      --          predicate => L in 3 | 10 | 5 .. 7;
+      --        subtype StaticP is Int with
+      --          predicate => StaticP in 3 | 10 | 5 .. 7;
       --          ...
       --        for L in StaticP loop
       --           Put_Line ("static:" & J'Img);
@@ -4210,38 +4213,91 @@ package body Exp_Ch5 is
             --  Loop to create branches of case statement
 
             Alts := New_List;
-            P := First (Stat);
-            while Present (P) loop
-               if No (Next (P)) then
-                  S := Make_Exit_Statement (Loc);
-               else
-                  S :=
-                    Make_Assignment_Statement (Loc,
-                      Name       => New_Occurrence_Of (Loop_Id, Loc),
-                      Expression => Lo_Val (Next (P)));
-                  Set_Suppress_Assignment_Checks (S);
-               end if;
 
-               Append_To (Alts,
-                 Make_Case_Statement_Alternative (Loc,
-                   Statements       => New_List (S),
-                   Discrete_Choices => New_List (Hi_Val (P))));
+            if Reverse_Present (LPS) then
 
-               Next (P);
-            end loop;
+               --  Initial value is largest value in predicate.
+
+               D :=
+                 Make_Object_Declaration (Loc,
+                   Defining_Identifier => Loop_Id,
+                   Object_Definition   => New_Occurrence_Of (Ltype, Loc),
+                   Expression          => Hi_Val (Last (Stat)));
+
+               P := Last (Stat);
+               while Present (P) loop
+                  if No (Prev (P)) then
+                     S := Make_Exit_Statement (Loc);
+                  else
+                     S :=
+                       Make_Assignment_Statement (Loc,
+                         Name       => New_Occurrence_Of (Loop_Id, Loc),
+                         Expression => Hi_Val (Prev (P)));
+                     Set_Suppress_Assignment_Checks (S);
+                  end if;
+
+                  Append_To (Alts,
+                    Make_Case_Statement_Alternative (Loc,
+                      Statements       => New_List (S),
+                      Discrete_Choices => New_List (Lo_Val (P))));
+
+                  Prev (P);
+               end loop;
+
+            else
+
+               --  Initial value is smallest value in predicate.
+
+               D :=
+                 Make_Object_Declaration (Loc,
+                   Defining_Identifier => Loop_Id,
+                   Object_Definition   => New_Occurrence_Of (Ltype, Loc),
+                   Expression          => Lo_Val (First (Stat)));
+
+               P := First (Stat);
+               while Present (P) loop
+                  if No (Next (P)) then
+                     S := Make_Exit_Statement (Loc);
+                  else
+                     S :=
+                       Make_Assignment_Statement (Loc,
+                         Name       => New_Occurrence_Of (Loop_Id, Loc),
+                         Expression => Lo_Val (Next (P)));
+                     Set_Suppress_Assignment_Checks (S);
+                  end if;
+
+                  Append_To (Alts,
+                    Make_Case_Statement_Alternative (Loc,
+                      Statements       => New_List (S),
+                      Discrete_Choices => New_List (Hi_Val (P))));
+
+                  Next (P);
+               end loop;
+            end if;
 
             --  Add others choice
 
-            S :=
-               Make_Assignment_Statement (Loc,
-                 Name       => New_Occurrence_Of (Loop_Id, Loc),
-                 Expression =>
-                   Make_Attribute_Reference (Loc,
-                     Prefix => New_Occurrence_Of (Ltype, Loc),
-                     Attribute_Name => Name_Succ,
-                     Expressions    => New_List (
-                       New_Occurrence_Of (Loop_Id, Loc))));
-            Set_Suppress_Assignment_Checks (S);
+            declare
+               Name_Next : Name_Id;
+
+            begin
+               if Reverse_Present (LPS) then
+                  Name_Next := Name_Pred;
+               else
+                  Name_Next := Name_Succ;
+               end if;
+
+               S :=
+                  Make_Assignment_Statement (Loc,
+                    Name       => New_Occurrence_Of (Loop_Id, Loc),
+                    Expression =>
+                      Make_Attribute_Reference (Loc,
+                        Prefix => New_Occurrence_Of (Ltype, Loc),
+                        Attribute_Name => Name_Next,
+                        Expressions    => New_List (
+                          New_Occurrence_Of (Loop_Id, Loc))));
+               Set_Suppress_Assignment_Checks (S);
+            end;
 
             Append_To (Alts,
               Make_Case_Statement_Alternative (Loc,
@@ -4258,11 +4314,6 @@ package body Exp_Ch5 is
 
             --  Rewrite the loop
 
-            D :=
-              Make_Object_Declaration (Loc,
-                Defining_Identifier => Loop_Id,
-                Object_Definition   => New_Occurrence_Of (Ltype, Loc),
-                Expression          => Lo_Val (First (Stat)));
             Set_Suppress_Assignment_Checks (D);
 
             Rewrite (N,
diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi
index ba1a8f2a9a4..17f2414ea49 100644
--- a/gcc/ada/gnat_ugn.texi
+++ b/gcc/ada/gnat_ugn.texi
@@ -5048,6 +5048,23 @@ combination @option{-gnatwu} followed by @option{-gnatwF} has the
 effect of warning on unreferenced entities other than subprogram
 formals.
 
+@item -gnatw.f
+@emph{Activate warnings on suspicious subprogram 'Access.}
+@cindex @option{-gnatw.f} (@command{gcc})
+This switch causes a warning to be generated if @code{P'Access} occurs
+in the same package where subprogram P is declared, and the
+@code{P'Access} is evaluated at elaboration time, and occurs before
+the body of P has been elaborated. For example, if we have
+@code{X : T := P'Access;}, then if X.all is subsequently called before
+the body of P is elaborated, it could cause
+access-before-elaboration. The default is that these warnings are not
+generated.
+
+@item -gnatw.F
+@emph{Suppress warnings on suspicious subprogram 'Access.}
+@cindex @option{-gnatw.F} (@command{gcc})
+This switch suppresses warnings for suspicious subprogram 'Access.
+
 @item -gnatwg
 @emph{Activate warnings on unrecognized pragmas.}
 @cindex @option{-gnatwg} (@command{gcc})
diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads
index a1ce246bb81..e30af5c9cc4 100644
--- a/gcc/ada/opt.ads
+++ b/gcc/ada/opt.ads
@@ -1669,6 +1669,13 @@ package Opt is
    --  Set to True to generate warnings for suspicious use of export or
    --  import pragmas. Modified by use of -gnatwx/X.
 
+   Warn_On_Elab_Access : Boolean := False;
+   --  GNAT
+   --  Set to True to generate warnings for P'Access in the case where
+   --  subprogram P is in the same package as the P'Access, and the P'Access is
+   --  evaluated at package elaboration time, and occurs before the body of P
+   --  has been elaborated.
+
    Warn_On_Hiding : Boolean := False;
    --  GNAT
    --  Set to True to generate warnings if a declared entity hides another
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index 4b88e1d607a..e65b9095c96 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -9884,6 +9884,8 @@ package body Sem_Ch12 is
       Subt_Mark   : Node_Id             := Empty;
 
    begin
+      --  Formal may be an anonymous access
+
       if Present (Subtype_Mark (Formal)) then
          Subt_Mark := Subtype_Mark (Formal);
       else
@@ -10140,9 +10142,14 @@ package body Sem_Ch12 is
             --  Use default to construct declaration
 
             if Present (Subt_Mark) then
-               Def := Subt_Mark;
+               Def := New_Copy (Subt_Mark);
+
             else pragma Assert (Present (Acc_Def));
-               Def := Acc_Def;
+
+               --  If formal is an anonymous access, copy access definition of
+               --  formal for object declaration.
+
+               Def := New_Copy_Tree (Acc_Def);
             end if;
 
             Decl_Node :=
@@ -10150,7 +10157,7 @@ package body Sem_Ch12 is
                 Defining_Identifier    => New_Copy (Gen_Obj),
                 Constant_Present       => True,
                 Null_Exclusion_Present => Null_Exclusion_Present (Formal),
-                Object_Definition      => New_Copy (Def),
+                Object_Definition      => Def,
                 Expression             => New_Copy_Tree
                                             (Default_Expression (Formal)));
 
@@ -10158,11 +10165,9 @@ package body Sem_Ch12 is
             Set_Analyzed (Expression (Decl_Node), False);
 
          else
-            Error_Msg_NE
-              ("missing actual&",
-                Instantiation_Node, Gen_Obj);
+            Error_Msg_NE ("missing actual&", Instantiation_Node, Gen_Obj);
             Error_Msg_NE ("\in instantiation of & declared#",
-              Instantiation_Node, Scope (A_Gen_Obj));
+                          Instantiation_Node, Scope (A_Gen_Obj));
 
             if Is_Scalar_Type (Etype (A_Gen_Obj)) then
 
diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb
index 940f90f1bda..227469a1c27 100644
--- a/gcc/ada/sem_elab.adb
+++ b/gcc/ada/sem_elab.adb
@@ -1990,10 +1990,21 @@ package body Sem_Elab is
       Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation;
 
    begin
-      --  If not function or procedure call or instantiation, then ignore
-      --  call (this happens in some error cases and rewriting cases).
+      --  For P'Access, we want to warn if the -gnatw.f switch is set, and the
+      --  node comes from source.
 
-      if not Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement)
+      if Nkind (N) = N_Attribute_Reference and then
+        (not Warn_On_Elab_Access or else not Comes_From_Source (N))
+      then
+         return;
+
+      --  If not function or procedure call, instantiation, or 'Access, then
+      --  ignore call (this happens in some error cases and rewriting cases).
+
+      elsif not Nkind_In
+               (N, N_Function_Call,
+                   N_Procedure_Call_Statement,
+                   N_Attribute_Reference)
         and then not Inst_Case
       then
          return;
@@ -2001,7 +2012,7 @@ package body Sem_Elab is
       --  Nothing to do if this is a call or instantiation that has already
       --  been found to be a sure ABE.
 
-      elsif ABE_Is_Certain (N) then
+      elsif Nkind (N) /= N_Attribute_Reference and then ABE_Is_Certain (N) then
          return;
 
       --  Nothing to do if errors already detected (avoid cascaded errors)
@@ -2323,7 +2334,7 @@ package body Sem_Elab is
       --  Not that special case, warning and dynamic check is required
 
       --  If we have nothing in the call stack, then this is at the outer
-      --  level, and the ABE is bound to occur.
+      --  level, and the ABE is bound to occur, unless it's a 'Access.
 
       if Elab_Call.Last = 0 then
          Error_Msg_Warn := SPARK_Mode /= On;
@@ -2331,13 +2342,19 @@ package body Sem_Elab is
          if Inst_Case then
             Error_Msg_NE
               ("cannot instantiate& before body seen<<", N, Orig_Ent);
-         else
+         elsif Nkind (N) /= N_Attribute_Reference then
             Error_Msg_NE
               ("cannot call& before body seen<<", N, Orig_Ent);
+         else
+            Error_Msg_NE
+              ("Access attribute of & before body seen<<", N, Orig_Ent);
+            Error_Msg_N ("\possible Program_Error on later references<", N);
          end if;
 
-         Error_Msg_N ("\Program_Error [<<", N);
-         Insert_Elab_Check (N);
+         if Nkind (N) /= N_Attribute_Reference then
+            Error_Msg_N ("\Program_Error [<<", N);
+            Insert_Elab_Check (N);
+         end if;
 
       --  Call is not at outer level
 
diff --git a/gcc/ada/warnsw.adb b/gcc/ada/warnsw.adb
index 10b60a8f779..38f7d39b1e4 100644
--- a/gcc/ada/warnsw.adb
+++ b/gcc/ada/warnsw.adb
@@ -326,6 +326,12 @@ package body Warnsw is
          when 'e' =>
             All_Warnings (True);
 
+         when 'f' =>
+            Warn_On_Elab_Access                 := True;
+
+         when 'F' =>
+            Warn_On_Elab_Access                 := False;
+
          when 'g' =>
             Set_GNAT_Mode_Warnings;