From: Daniel Kraft Date: Sun, 30 Nov 2008 20:36:10 +0000 (+0100) Subject: re PR fortran/37779 (Missing RECURSIVE not detected) X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=1933ba0f5dc728f554beb675093126aaef7fbb5a;p=platform%2Fupstream%2Fgcc.git re PR fortran/37779 (Missing RECURSIVE not detected) 2008-11-30 Daniel Kraft 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 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 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 020f11d..d000a1a 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,14 @@ +2008-11-30 Daniel Kraft + + 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 * trans-array.c (gfc_conv_array_parameter): Guard union access. diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index d5d28f2..1370124 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 59e9e54..6ccbe12 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -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 diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index cd0d6c4..f6ee64b 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,14 @@ +2008-11-30 Daniel Kraft + + 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 * g++.dg/opt/reload3.C: New test. diff --git a/gcc/testsuite/gfortran.dg/entry_18.f90 b/gcc/testsuite/gfortran.dg/entry_18.f90 index e00aea7..0cfe842 100644 --- a/gcc/testsuite/gfortran.dg/entry_18.f90 +++ b/gcc/testsuite/gfortran.dg/entry_18.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/recursive_check_1.f b/gcc/testsuite/gfortran.dg/recursive_check_1.f index b264f25..7c292af 100644 --- a/gcc/testsuite/gfortran.dg/recursive_check_1.f +++ b/gcc/testsuite/gfortran.dg/recursive_check_1.f @@ -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 diff --git a/gcc/testsuite/gfortran.dg/recursive_check_2.f90 b/gcc/testsuite/gfortran.dg/recursive_check_2.f90 index 42273f9..15608ee 100644 --- a/gcc/testsuite/gfortran.dg/recursive_check_2.f90 +++ b/gcc/testsuite/gfortran.dg/recursive_check_2.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/recursive_check_4.f03 b/gcc/testsuite/gfortran.dg/recursive_check_4.f03 index 2a95554..d33e535 100644 --- a/gcc/testsuite/gfortran.dg/recursive_check_4.f03 +++ b/gcc/testsuite/gfortran.dg/recursive_check_4.f03 @@ -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" } diff --git a/gcc/testsuite/gfortran.dg/recursive_check_6.f03 b/gcc/testsuite/gfortran.dg/recursive_check_6.f03 new file mode 100644 index 0000000..478539e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/recursive_check_6.f03 @@ -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" } }