mirror of
git://gcc.gnu.org/git/gcc.git
synced 2025-03-19 06:40:31 +08:00
re PR fortran/37779 (Missing RECURSIVE not detected)
2008-11-30 Daniel Kraft <d@domob.eu> PR fortran/37779 * gfortran.h (struct gfc_entry_list): Fixed typo in comment. * resolve.c (is_illegal_recursion): New method. (resolve_procedure_expression): Use new is_illegal_recursion instead of direct check and handle function symbols correctly. (resolve_actual_arglist): Removed useless recursion check. (resolve_function): Use is_illegal_recursion instead of direct check. (resolve_call): Ditto. 2008-11-30 Daniel Kraft <d@domob.eu> PR fortran/37779 * gfortran.dg/recursive_check_1.f: Changed expected error message to the more general new one. * gfortran.dg/recursive_check_2.f90: Ditto. * gfortran.dg/entry_18.f90: Ditto. * gfortran.dg/recursive_check_4.f03: Do "the same" check also for FUNCTIONS, as this is different in details from SUBROUTINES. * gfortran.dg/recursive_check_6.f03: New test. From-SVN: r142299
This commit is contained in:
parent
72b415c586
commit
1933ba0f5d
@ -1,3 +1,14 @@
|
||||
2008-11-30 Daniel Kraft <d@domob.eu>
|
||||
|
||||
PR fortran/37779
|
||||
* gfortran.h (struct gfc_entry_list): Fixed typo in comment.
|
||||
* resolve.c (is_illegal_recursion): New method.
|
||||
(resolve_procedure_expression): Use new is_illegal_recursion instead of
|
||||
direct check and handle function symbols correctly.
|
||||
(resolve_actual_arglist): Removed useless recursion check.
|
||||
(resolve_function): Use is_illegal_recursion instead of direct check.
|
||||
(resolve_call): Ditto.
|
||||
|
||||
2008-11-29 Eric Botcazou <ebotcazou@adacore.com>
|
||||
|
||||
* trans-array.c (gfc_conv_array_parameter): Guard union access.
|
||||
|
@ -1157,7 +1157,7 @@ typedef struct gfc_entry_list
|
||||
int id;
|
||||
/* The LABEL_EXPR marking this entry point. */
|
||||
tree label;
|
||||
/* The nest item in the list. */
|
||||
/* The next item in the list. */
|
||||
struct gfc_entry_list *next;
|
||||
}
|
||||
gfc_entry_list;
|
||||
|
@ -1073,6 +1073,58 @@ count_specific_procs (gfc_expr *e)
|
||||
}
|
||||
|
||||
|
||||
/* See if a call to sym could possibly be a not allowed RECURSION because of
|
||||
a missing RECURIVE declaration. This means that either sym is the current
|
||||
context itself, or sym is the parent of a contained procedure calling its
|
||||
non-RECURSIVE containing procedure.
|
||||
This also works if sym is an ENTRY. */
|
||||
|
||||
static bool
|
||||
is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
|
||||
{
|
||||
gfc_symbol* proc_sym;
|
||||
gfc_symbol* context_proc;
|
||||
|
||||
gcc_assert (sym->attr.flavor == FL_PROCEDURE);
|
||||
|
||||
/* If we've got an ENTRY, find real procedure. */
|
||||
if (sym->attr.entry && sym->ns->entries)
|
||||
proc_sym = sym->ns->entries->sym;
|
||||
else
|
||||
proc_sym = sym;
|
||||
|
||||
/* If sym is RECURSIVE, all is well of course. */
|
||||
if (proc_sym->attr.recursive || gfc_option.flag_recursive)
|
||||
return false;
|
||||
|
||||
/* Find the context procdure's "real" symbol if it has entries. */
|
||||
context_proc = (context->entries ? context->entries->sym
|
||||
: context->proc_name);
|
||||
if (!context_proc)
|
||||
return true;
|
||||
|
||||
/* A call from sym's body to itself is recursion, of course. */
|
||||
if (context_proc == proc_sym)
|
||||
return true;
|
||||
|
||||
/* The same is true if context is a contained procedure and sym the
|
||||
containing one. */
|
||||
if (context_proc->attr.contained)
|
||||
{
|
||||
gfc_symbol* parent_proc;
|
||||
|
||||
gcc_assert (context->parent);
|
||||
parent_proc = (context->parent->entries ? context->parent->entries->sym
|
||||
: context->parent->proc_name);
|
||||
|
||||
if (parent_proc == proc_sym)
|
||||
return true;
|
||||
}
|
||||
|
||||
return false;
|
||||
}
|
||||
|
||||
|
||||
/* Resolve a procedure expression, like passing it to a called procedure or as
|
||||
RHS for a procedure pointer assignment. */
|
||||
|
||||
@ -1081,16 +1133,18 @@ resolve_procedure_expression (gfc_expr* expr)
|
||||
{
|
||||
gfc_symbol* sym;
|
||||
|
||||
if (expr->ts.type != BT_PROCEDURE || expr->expr_type != EXPR_VARIABLE)
|
||||
if (expr->expr_type != EXPR_VARIABLE)
|
||||
return SUCCESS;
|
||||
gcc_assert (expr->symtree);
|
||||
|
||||
sym = expr->symtree->n.sym;
|
||||
gcc_assert (sym->attr.flavor == FL_PROCEDURE);
|
||||
if (sym->attr.flavor != FL_PROCEDURE
|
||||
|| (sym->attr.function && sym->result == sym))
|
||||
return SUCCESS;
|
||||
|
||||
/* A non-RECURSIVE procedure that is used as procedure expression within its
|
||||
own body is in danger of being called recursively. */
|
||||
if (!sym->attr.recursive && sym == gfc_current_ns->proc_name
|
||||
&& !gfc_option.flag_recursive)
|
||||
if (is_illegal_recursion (sym, gfc_current_ns))
|
||||
gfc_warning ("Non-RECURSIVE procedure '%s' at %L is possibly calling"
|
||||
" itself recursively. Declare it RECURSIVE or use"
|
||||
" -frecursive", sym->name, &expr->where);
|
||||
@ -1203,15 +1257,6 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
|
||||
/* Just in case a specific was found for the expression. */
|
||||
sym = e->symtree->n.sym;
|
||||
|
||||
if (sym->attr.entry && sym->ns->entries
|
||||
&& sym->ns == gfc_current_ns
|
||||
&& !sym->ns->entries->sym->attr.recursive)
|
||||
{
|
||||
gfc_error ("Reference to ENTRY '%s' at %L is recursive, but"
|
||||
" procedure '%s' is not declared as RECURSIVE",
|
||||
sym->name, &e->where, sym->ns->entries->sym->name);
|
||||
}
|
||||
|
||||
/* If the symbol is the function that names the current (or
|
||||
parent) scope, then we really have a variable reference. */
|
||||
|
||||
@ -2455,22 +2500,19 @@ resolve_function (gfc_expr *expr)
|
||||
* call themselves. */
|
||||
if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
|
||||
{
|
||||
gfc_symbol *esym, *proc;
|
||||
gfc_symbol *esym;
|
||||
esym = expr->value.function.esym;
|
||||
proc = gfc_current_ns->proc_name;
|
||||
if (esym == proc)
|
||||
{
|
||||
gfc_error ("Function '%s' at %L cannot call itself, as it is not "
|
||||
"RECURSIVE", name, &expr->where);
|
||||
t = FAILURE;
|
||||
}
|
||||
|
||||
if (esym->attr.entry && esym->ns->entries && proc->ns->entries
|
||||
&& esym->ns->entries->sym == proc->ns->entries->sym)
|
||||
if (is_illegal_recursion (esym, gfc_current_ns))
|
||||
{
|
||||
gfc_error ("Call to ENTRY '%s' at %L is recursive, but function "
|
||||
"'%s' is not declared as RECURSIVE",
|
||||
esym->name, &expr->where, esym->ns->entries->sym->name);
|
||||
if (esym->attr.entry && esym->ns->entries)
|
||||
gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
|
||||
" function '%s' is not RECURSIVE",
|
||||
esym->name, &expr->where, esym->ns->entries->sym->name);
|
||||
else
|
||||
gfc_error ("Function '%s' at %L cannot be called recursively, as it"
|
||||
" is not RECURSIVE", esym->name, &expr->where);
|
||||
|
||||
t = FAILURE;
|
||||
}
|
||||
}
|
||||
@ -2920,25 +2962,17 @@ resolve_call (gfc_code *c)
|
||||
|
||||
/* Subroutines without the RECURSIVE attribution are not allowed to
|
||||
* call themselves. */
|
||||
if (csym && !csym->attr.recursive)
|
||||
if (csym && is_illegal_recursion (csym, gfc_current_ns))
|
||||
{
|
||||
gfc_symbol *proc;
|
||||
proc = gfc_current_ns->proc_name;
|
||||
if (csym == proc)
|
||||
{
|
||||
gfc_error ("SUBROUTINE '%s' at %L cannot call itself, as it is not "
|
||||
"RECURSIVE", csym->name, &c->loc);
|
||||
t = FAILURE;
|
||||
}
|
||||
|
||||
if (csym->attr.entry && csym->ns->entries && proc->ns->entries
|
||||
&& csym->ns->entries->sym == proc->ns->entries->sym)
|
||||
{
|
||||
gfc_error ("Call to ENTRY '%s' at %L is recursive, but subroutine "
|
||||
"'%s' is not declared as RECURSIVE",
|
||||
if (csym->attr.entry && csym->ns->entries)
|
||||
gfc_error ("ENTRY '%s' at %L cannot be called recursively, as"
|
||||
" subroutine '%s' is not RECURSIVE",
|
||||
csym->name, &c->loc, csym->ns->entries->sym->name);
|
||||
t = FAILURE;
|
||||
}
|
||||
else
|
||||
gfc_error ("SUBROUTINE '%s' at %L cannot be called recursively, as it"
|
||||
" is not RECURSIVE", csym->name, &c->loc);
|
||||
|
||||
t = FAILURE;
|
||||
}
|
||||
|
||||
/* Switch off assumed size checking and do this again for certain kinds
|
||||
|
@ -1,3 +1,14 @@
|
||||
2008-11-30 Daniel Kraft <d@domob.eu>
|
||||
|
||||
PR fortran/37779
|
||||
* gfortran.dg/recursive_check_1.f: Changed expected error message to
|
||||
the more general new one.
|
||||
* gfortran.dg/recursive_check_2.f90: Ditto.
|
||||
* gfortran.dg/entry_18.f90: Ditto.
|
||||
* gfortran.dg/recursive_check_4.f03: Do "the same" check also for
|
||||
FUNCTIONS, as this is different in details from SUBROUTINES.
|
||||
* gfortran.dg/recursive_check_6.f03: New test.
|
||||
|
||||
2008-11-30 Eric Botcazou <ebotcazou@adacore.com>
|
||||
|
||||
* g++.dg/opt/reload3.C: New test.
|
||||
|
@ -27,7 +27,7 @@ subroutine subb( g )
|
||||
end function
|
||||
end interface
|
||||
real :: x, y
|
||||
call mysub( glocalb ) ! { dg-error "is recursive" }
|
||||
call mysub( glocalb ) ! { dg-warning "Non-RECURSIVE" }
|
||||
return
|
||||
entry glocalb( x, y )
|
||||
y = x
|
||||
|
@ -1,17 +1,17 @@
|
||||
! { dg-do compile }
|
||||
! PR fortran/26551
|
||||
SUBROUTINE SUB()
|
||||
CALL SUB() ! { dg-error "cannot call itself, as it is not RECURSIVE" }
|
||||
CALL SUB() ! { dg-error "is not RECURSIVE" }
|
||||
END SUBROUTINE
|
||||
|
||||
FUNCTION FUNC() RESULT (FOO)
|
||||
INTEGER FOO
|
||||
FOO = FUNC() ! { dg-error "cannot call itself, as it is not RECURSIVE" }
|
||||
FOO = FUNC() ! { dg-error "is not RECURSIVE" }
|
||||
END FUNCTION
|
||||
|
||||
SUBROUTINE SUB2()
|
||||
ENTRY ENT2()
|
||||
CALL ENT2() ! { dg-error "is not declared as RECURSIVE" }
|
||||
CALL ENT2() ! { dg-error "is not RECURSIVE" }
|
||||
END SUBROUTINE
|
||||
|
||||
function func2()
|
||||
@ -19,7 +19,7 @@
|
||||
func2 = 42
|
||||
return
|
||||
entry c() result (foo)
|
||||
foo = b() ! { dg-error "is not declared as RECURSIVE" }
|
||||
foo = b() ! { dg-error "is not RECURSIVE" }
|
||||
return
|
||||
entry b() result (bar)
|
||||
bar = 12
|
||||
|
@ -12,6 +12,6 @@
|
||||
return
|
||||
contains
|
||||
function barbar ()
|
||||
barbar = b () ! { dg-error "is not declared as RECURSIVE" }
|
||||
barbar = b () ! { dg-error "is not RECURSIVE" }
|
||||
end function barbar
|
||||
end function
|
||||
|
@ -16,6 +16,16 @@ CONTAINS
|
||||
procptr => test ! { dg-warning "Non-RECURSIVE" }
|
||||
END SUBROUTINE test
|
||||
|
||||
INTEGER FUNCTION test2 () RESULT (x)
|
||||
IMPLICIT NONE
|
||||
PROCEDURE(test2), POINTER :: procptr
|
||||
|
||||
CALL bar (test2) ! { dg-warning "Non-RECURSIVE" }
|
||||
procptr => test2 ! { dg-warning "Non-RECURSIVE" }
|
||||
|
||||
x = 1812
|
||||
END FUNCTION test2
|
||||
|
||||
INTEGER FUNCTION func ()
|
||||
! Using a result variable is ok of course!
|
||||
func = 42 ! { dg-bogus "Non-RECURSIVE" }
|
||||
|
66
gcc/testsuite/gfortran.dg/recursive_check_6.f03
Normal file
66
gcc/testsuite/gfortran.dg/recursive_check_6.f03
Normal file
@ -0,0 +1,66 @@
|
||||
! { dg-do compile }
|
||||
|
||||
! PR fortran/37779
|
||||
! Check that a call to a procedure's containing procedure counts as recursive
|
||||
! and is rejected if the containing procedure is not RECURSIVE.
|
||||
|
||||
MODULE m
|
||||
IMPLICIT NONE
|
||||
|
||||
CONTAINS
|
||||
|
||||
SUBROUTINE test_sub ()
|
||||
CALL bar ()
|
||||
CONTAINS
|
||||
SUBROUTINE bar ()
|
||||
IMPLICIT NONE
|
||||
PROCEDURE(test_sub), POINTER :: procptr
|
||||
|
||||
CALL test_sub () ! { dg-error "not RECURSIVE" }
|
||||
procptr => test_sub ! { dg-warning "Non-RECURSIVE" }
|
||||
CALL foobar (test_sub) ! { dg-warning "Non-RECURSIVE" }
|
||||
END SUBROUTINE bar
|
||||
END SUBROUTINE test_sub
|
||||
|
||||
INTEGER FUNCTION test_func () RESULT (x)
|
||||
x = bar ()
|
||||
CONTAINS
|
||||
INTEGER FUNCTION bar ()
|
||||
IMPLICIT NONE
|
||||
PROCEDURE(test_func), POINTER :: procptr
|
||||
|
||||
bar = test_func () ! { dg-error "not RECURSIVE" }
|
||||
procptr => test_func ! { dg-warning "Non-RECURSIVE" }
|
||||
CALL foobar (test_func) ! { dg-warning "Non-RECURSIVE" }
|
||||
END FUNCTION bar
|
||||
END FUNCTION test_func
|
||||
|
||||
SUBROUTINE sub_entries ()
|
||||
ENTRY sub_entry_1 ()
|
||||
ENTRY sub_entry_2 ()
|
||||
CALL bar ()
|
||||
CONTAINS
|
||||
SUBROUTINE bar ()
|
||||
CALL sub_entry_1 () ! { dg-error "is not RECURSIVE" }
|
||||
END SUBROUTINE bar
|
||||
END SUBROUTINE sub_entries
|
||||
|
||||
INTEGER FUNCTION func_entries () RESULT (x)
|
||||
ENTRY func_entry_1 () RESULT (x)
|
||||
ENTRY func_entry_2 () RESULT (x)
|
||||
x = bar ()
|
||||
CONTAINS
|
||||
INTEGER FUNCTION bar ()
|
||||
bar = func_entry_1 () ! { dg-error "is not RECURSIVE" }
|
||||
END FUNCTION bar
|
||||
END FUNCTION func_entries
|
||||
|
||||
SUBROUTINE main ()
|
||||
CALL test_sub ()
|
||||
CALL sub_entries ()
|
||||
PRINT *, test_func (), func_entries ()
|
||||
END SUBROUTINE main
|
||||
|
||||
END MODULE m
|
||||
|
||||
! { dg-final { cleanup-modules "m" } }
|
Loading…
x
Reference in New Issue
Block a user