Skip to content

R
riscv-gcc-1
Commit 26570b21 by Robert Dewar Committed by Arnaud Charlet
Options

sem_res.adb (Check_Infinite_Recursion): Diagnose definite infinite recursion and raise SE directly. 

2008-03-26  Robert Dewar  <dewar@adacore.com>

	* sem_res.adb (Check_Infinite_Recursion): Diagnose definite infinite
	recursion and raise SE directly.
	(Resolve_Actuals): Reset Never_Set_In_Source if warnings off is
	set for formal type for IN mode parameter.

From-SVN: r133579
parent 7d823354
Showing with 60 additions and 13 deletions
gcc/ada/sem_res.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -720,8 +720,34 @@ package body Sem_Res is
-- Start of processing for Check_Infinite_Recursion
begin
-- Loop moving up tree, quitting if something tells us we are
-- definitely not in an infinite recursion situation.
-- Special case, if this is a procedure call and is a call to the
-- current procedure with the same argument list, then this is for
-- sure an infinite recursion and we insert a call to raise SE.
if Is_List_Member (N)
and then List_Length (List_Containing (N)) = 1
and then Same_Argument_List
then
declare
P : constant Node_Id := Parent (N);
begin
if Nkind (P) = N_Handled_Sequence_Of_Statements
and then Nkind (Parent (P)) = N_Subprogram_Body
and then Is_Empty_List (Declarations (Parent (P)))
then
Error_Msg_N ("!?infinite recursion", N);
Error_Msg_N ("\!?Storage_Error will be raised at run time", N);
Insert_Action (N,
Make_Raise_Storage_Error (Sloc (N),
Reason => SE_Infinite_Recursion));
return True;
end if;
end;
end if;
-- If not that special case, search up tree, quitting if we reach a
-- construct (e.g. a conditional) that tells us that this is not a
-- case for an infinite recursion warning.
C := N;
loop
......@@ -738,10 +764,10 @@ package body Sem_Res is
elsif Nkind (P) = N_Handled_Sequence_Of_Statements
and then C /= First (Statements (P))
then
-- If the call is the expression of a return statement and
-- the actuals are identical to the formals, it's worth a
-- warning. However, we skip this if there is an immediately
-- preceding raise statement, since the call is never executed.
-- If the call is the expression of a return statement and the
-- actuals are identical to the formals, it's worth a warning.
-- However, we skip this if there is an immediately preceding
-- raise statement, since the call is never executed.
-- Furthermore, this corresponds to a common idiom:
......@@ -3045,6 +3071,21 @@ package body Sem_Res is
A_Typ := Etype (A);
F_Typ := Etype (F);
-- For mode IN, if actual is an entity, and the type of the formal
-- has warnings suppressed, then we reset Never_Set_In_Source for
-- the calling entity. The reason for this is to catch cases like
-- GNAT.Spitbol.Patterns.Vstring_Var where the called subprogram
-- uses trickery to modify an IN parameter.
if Ekind (F) = E_In_Parameter
and then Is_Entity_Name (A)
and then Present (Entity (A))
and then Ekind (Entity (A)) = E_Variable
and then Has_Warnings_Off (F_Typ)
then
Set_Never_Set_In_Source (Entity (A), False);
end if;
-- Perform error checks for IN and IN OUT parameters
if Ekind (F) /= E_Out_Parameter then
......@@ -4625,17 +4666,23 @@ package body Sem_Res is
if Comes_From_Source (N) then
Scop := Current_Scope;
-- Issue warning for possible infinite recursion in the absence
-- of the No_Recursion restriction.
if Nam = Scop
and then not Restriction_Active (No_Recursion)
and then Check_Infinite_Recursion (N)
then
-- Here we detected and flagged an infinite recursion, so we do
-- not need to test the case below for further warnings.
-- not need to test the case below for further warnings. Also if
-- we now have a raise SE node, we are all done.
null;
if Nkind (N) = N_Raise_Storage_Error then
return;
end if;
-- If call is to immediately containing subprogram, then check for
-- the case of a possible run-time detectable infinite recursion.
-- If call is to immediately containing subprogram, then check for
-- the case of a possible run-time detectable infinite recursion.
else
Scope_Loop : while Scop /= Standard_Standard loop
......@@ -4761,7 +4808,7 @@ package body Sem_Res is
if Is_Inlined (Nam)
and then Present (First_Rep_Item (Nam))
and then Nkind (First_Rep_Item (Nam)) = N_Pragma
and then Chars (First_Rep_Item (Nam)) = Name_Inline_Always
and then Pragma_Name (First_Rep_Item (Nam)) = Name_Inline_Always
then
null;
......@@ -7196,7 +7243,7 @@ package body Sem_Res is
Orig : constant Node_Id := Original_Node (Parent (N));
begin
if Nkind (Orig) = N_Pragma
and then Chars (Orig) = Name_Assert
and then Pragma_Name (Orig) = Name_Assert
then
-- Don't want to warn if original condition is explicit False
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment