From 10dfac72b18e12e0879c9d4f83af3526e2ab3b8a Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 7 Jan 2015 11:26:56 +0100 Subject: [PATCH] [multiple changes] 2015-01-07 Ed Schonberg * 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 * 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 * 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. From-SVN: r219293 --- gcc/ada/ChangeLog | 26 +++++++++ gcc/ada/exp_ch5.adb | 119 ++++++++++++++++++++++++++++++------------ gcc/ada/gnat_ugn.texi | 17 ++++++ gcc/ada/opt.ads | 7 +++ gcc/ada/sem_ch12.adb | 19 ++++--- gcc/ada/sem_elab.adb | 33 +++++++++--- gcc/ada/warnsw.adb | 6 +++ 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 + + * 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 + + * 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 + + * 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 * 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; -- 2.30.2