diff options
author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2007-12-13 10:26:56 +0000 |
---|---|---|
committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2007-12-13 10:26:56 +0000 |
commit | 87027bccd47eaa00b241cb14371aa786336b4625 (patch) | |
tree | 6fafce247886d6e5a58f5c2bc6f8f0bd92df7c43 /gcc/ada/sem_res.adb | |
parent | 97ca3f7631d847bf60fc2df43db30b0c2bf721d2 (diff) | |
download | gcc-87027bccd47eaa00b241cb14371aa786336b4625.tar.gz |
2007-12-06 Robert Dewar <dewar@adacore.com>
Ed Schonberg <schonberg@adacore.com>
* exp_prag.adb (Expand_Pragma_Assert): Recognize new warning flag for
assert fail
* ug_words: Add entries for -gnatw.a -gnatw.A
* sem_res.adb (Set_String_Literal_Subtype): If the context of the
literal is a subtype with non-static constraints, use the base type of
the context as the base of the string subtype, to prevent type
mismatches in gigi.
(Resolve_Actuals): If the actual is an entity name, generate a
reference before the actual is resolved and expanded, to prevent
spurious warnings on formals of enclosing protected operations.
(Analyze_Overloaded_Selected_Component): If type of prefix if
class-wide, use visible components of base type.
(Resolve_Selected_Component): Ditto.
(Resolve_Short_Circuit): Detect case of pragma Assert argument
evaluating to False, and issue warning message.
* usage.adb: Add lines for -gnatw.a and -gnatw.A
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@130838 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada/sem_res.adb')
-rw-r--r-- | gcc/ada/sem_res.adb | 147 |
1 files changed, 117 insertions, 30 deletions
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 258064aa20d..523a883ae45 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -2846,6 +2846,30 @@ package body Sem_Res is -- Case where actual is present + -- If the actual is an entity, generate a reference to it now. We + -- do this before the actual is resolved, because a formal of some + -- protected subprogram, or a task discriminant, will be rewritten + -- during expansion, and the reference to the source entity may + -- be lost. + + if Present (A) + and then Is_Entity_Name (A) + and then Comes_From_Source (N) + then + Orig_A := Entity (A); + + if Present (Orig_A) then + if Is_Formal (Orig_A) + and then Ekind (F) /= E_In_Parameter + then + Generate_Reference (Orig_A, A, 'm'); + + elsif not Is_Overloaded (A) then + Generate_Reference (Orig_A, A); + end if; + end if; + end if; + if Present (A) and then (Nkind (Parent (A)) /= N_Parameter_Association or else @@ -3043,43 +3067,38 @@ package body Sem_Res is end if; end if; - -- For IN parameter, this is where we generate a reference after - -- resolution is complete. - - if Ekind (F) = E_In_Parameter then - Orig_A := Original_Node (A); - - if Is_Entity_Name (Orig_A) - and then Present (Entity (Orig_A)) - then - Generate_Reference (Entity (Orig_A), Orig_A); - end if; - -- Case of OUT or IN OUT parameter - else - -- Validate the form of the actual. Note that the call to - -- Is_OK_Variable_For_Out_Formal generates the required - -- reference in this case. - - if not Is_OK_Variable_For_Out_Formal (A) then - Error_Msg_NE ("actual for& must be a variable", A, F); - end if; + if Ekind (F) /= E_In_Parameter then -- For an Out parameter, check for useless assignment. Note -- that we can't set Last_Assignment this early, because we -- may kill current values in Resolve_Call, and that call -- would clobber the Last_Assignment field. + -- Note: call Warn_On_Useless_Assignment before doing the + -- check below for Is_OK_Variable_For_Out_Formal so that the + -- setting of Referenced_As_LHS/Referenced_As_Out_Formal + -- properly reflects the last assignment, not this one! + if Ekind (F) = E_Out_Parameter then - if Warn_On_Out_Parameter_Unread + if Warn_On_Modified_As_Out_Parameter (F) and then Is_Entity_Name (A) and then Present (Entity (A)) + and then Comes_From_Source (N) then - Warn_On_Useless_Assignment (Entity (A), Sloc (A)); + Warn_On_Useless_Assignment (Entity (A), A); end if; end if; + -- Validate the form of the actual. Note that the call to + -- Is_OK_Variable_For_Out_Formal generates the required + -- reference in this case. + + if not Is_OK_Variable_For_Out_Formal (A) then + Error_Msg_NE ("actual for& must be a variable", A, F); + end if; + -- What's the following about??? if Is_Entity_Name (A) then @@ -4718,7 +4737,7 @@ package body Sem_Res is -- for it, precisely because we will not do it within the init proc -- itself. - -- If the subprogram is marked Inlined_Always, then even if it returns + -- If the subprogram is marked Inline_Always, then even if it returns -- an unconstrained type the call does not require use of the secondary -- stack. @@ -4809,12 +4828,12 @@ package body Sem_Res is Kill_Current_Values; end if; - -- If we are warning about unread out parameters, this is the place to - -- set Last_Assignment for out parameters. We have to do this after the - -- above call to Kill_Current_Values (since that call clears the - -- Last_Assignment field of all local variables). + -- If we are warning about unread OUT parameters, this is the place to + -- set Last_Assignment for OUT and IN OUT parameters. We have to do this + -- after the above call to Kill_Current_Values (since that call clears + -- the Last_Assignment field of all local variables). - if Warn_On_Out_Parameter_Unread + if (Warn_On_Modified_Unread or Warn_On_All_Unread_Out_Parameters) and then Comes_From_Source (N) and then In_Extended_Main_Source_Unit (N) then @@ -4826,9 +4845,12 @@ package body Sem_Res is F := First_Formal (Nam); A := First_Actual (N); while Present (F) and then Present (A) loop - if Ekind (F) = E_Out_Parameter + if (Ekind (F) = E_Out_Parameter + or else Ekind (F) = E_In_Out_Parameter) + and then Warn_On_Modified_As_Out_Parameter (F) and then Is_Entity_Name (A) and then Present (Entity (A)) + and then Comes_From_Source (N) and then Safe_To_Capture_Value (N, Entity (A)) then Set_Last_Assignment (Entity (A), A); @@ -6930,6 +6952,14 @@ package body Sem_Res is end if; if Is_Record_Type (T) then + + -- The visible components of a class-wide type are those of + -- the root type. + + if Is_Class_Wide_Type (T) then + T := Etype (T); + end if; + Comp := First_Entity (T); while Present (Comp) loop if Chars (Comp) = Chars (S) @@ -7090,6 +7120,58 @@ package body Sem_Res is Resolve (L, B_Typ); Resolve (R, B_Typ); + -- Check for issuing warning for always False assert, this happens + -- when assertions are turned off, in which case the pragma Assert + -- was transformed into: + + -- if False and then <condition> then ... + + -- and we detect this pattern + + if Warn_On_Assertion_Failure + and then Is_Entity_Name (R) + and then Entity (R) = Standard_False + and then Nkind (Parent (N)) = N_If_Statement + and then Nkind (N) = N_And_Then + and then Is_Entity_Name (L) + and then Entity (L) = Standard_False + then + declare + Orig : constant Node_Id := Original_Node (Parent (N)); + begin + if Nkind (Orig) = N_Pragma + and then Chars (Orig) = Name_Assert + then + -- Don't want to warn if original condition is explicit False + + declare + Expr : constant Node_Id := + Original_Node + (Expression + (First (Pragma_Argument_Associations (Orig)))); + begin + if Is_Entity_Name (Expr) + and then Entity (Expr) = Standard_False + then + null; + else + -- Issue warning. Note that we don't want to make this + -- an unconditional warning, because if the assert is + -- within deleted code we do not want the warning. But + -- we do not want the deletion of the IF/AND-THEN to + -- take this message with it. We achieve this by making + -- sure that the expanded code points to the Sloc of + -- the expression, not the original pragma. + + Error_Msg_N ("?assertion would fail at run-time", Orig); + end if; + end; + end if; + end; + end if; + + -- Continue with processing of short circuit + Check_Unset_Reference (L); Check_Unset_Reference (R); @@ -8232,7 +8314,12 @@ package body Sem_Res is Set_Parent (Drange, N); Analyze_And_Resolve (Drange, Index_Type); - Set_Etype (Index_Subtype, Index_Type); + -- In the context, the Index_Type may already have a constraint, + -- so use common base type on string subtype. The base type may + -- be used when generating attributes of the string, for example + -- in the context of a slice assignment. + + Set_Etype (Index_Subtype, Base_Type (Index_Type)); Set_Size_Info (Index_Subtype, Index_Type); Set_RM_Size (Index_Subtype, RM_Size (Index_Type)); |