diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index fe6b13997d3..3079268d386 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,14 @@ +2007-04-13 Tobias Schlüter + + PR fortran/18937 + * resolve.c: Include obstack.h and bitmap.h. New variable + labels_obstack. + (code_stack): Add tail and reachable_labels fields. + (reachable_labels): New function. + (resolve_branch): Rework to use new fields in code_stack. + (resolve_code): Call reachable_labels. + (resolve_codes): Allocate and free labels_obstack. + 2007-04-12 Tobias Schlüter PR fortran/31250 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 8c4b46ac27f..7ad4f55d9f8 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -24,6 +24,8 @@ Software Foundation, 51 Franklin Street, Fifth Floor,Boston, MA #include "system.h" #include "flags.h" #include "gfortran.h" +#include "obstack.h" +#include "bitmap.h" #include "arith.h" /* For gfc_compare_expr(). */ #include "dependency.h" @@ -35,13 +37,17 @@ typedef enum seq_type } seq_type; -/* Stack to push the current if we descend into a block during - resolution. See resolve_branch() and resolve_code(). */ +/* Stack to keep track of the nesting of blocks as we move through the + code. See resolve_branch() and resolve_code(). */ typedef struct code_stack { - struct gfc_code *head, *current; + struct gfc_code *head, *current, *tail; struct code_stack *prev; + + /* This bitmap keeps track of the targets valid for a branch from + inside this block. */ + bitmap reachable_labels; } code_stack; @@ -66,6 +72,9 @@ static int specification_expr = 0; /* The id of the last entry seen. */ static int current_entry_id; +/* We use bitmaps to determine if a branch target is valid. */ +static bitmap_obstack labels_obstack; + int gfc_is_formal_arg (void) { @@ -4395,33 +4404,63 @@ resolve_transfer (gfc_code *code) /*********** Toplevel code resolution subroutines ***********/ +/* Find the set of labels that are reachable from this block. We also + record the last statement in each block so that we don't have to do + a linear search to find the END DO statements of the blocks. */ + +static void +reachable_labels (gfc_code *block) +{ + gfc_code *c; + + if (!block) + return; + + cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack); + + /* Collect labels in this block. */ + for (c = block; c; c = c->next) + { + if (c->here) + bitmap_set_bit (cs_base->reachable_labels, c->here->value); + + if (!c->next && cs_base->prev) + cs_base->prev->tail = c; + } + + /* Merge with labels from parent block. */ + if (cs_base->prev) + { + gcc_assert (cs_base->prev->reachable_labels); + bitmap_ior_into (cs_base->reachable_labels, + cs_base->prev->reachable_labels); + } +} + /* Given a branch to a label and a namespace, if the branch is conforming. - The code node described where the branch is located. */ + The code node describes where the branch is located. */ static void resolve_branch (gfc_st_label *label, gfc_code *code) { - gfc_code *block, *found; code_stack *stack; - gfc_st_label *lp; if (label == NULL) return; - lp = label; /* Step one: is this a valid branching target? */ - if (lp->defined == ST_LABEL_UNKNOWN) + if (label->defined == ST_LABEL_UNKNOWN) { - gfc_error ("Label %d referenced at %L is never defined", lp->value, - &lp->where); + gfc_error ("Label %d referenced at %L is never defined", label->value, + &label->where); return; } - if (lp->defined != ST_LABEL_TARGET) + if (label->defined != ST_LABEL_TARGET) { gfc_error ("Statement at %L is not a valid branch target statement " - "for the branch statement at %L", &lp->where, &code->loc); + "for the branch statement at %L", &label->where, &code->loc); return; } @@ -4433,52 +4472,50 @@ resolve_branch (gfc_st_label *label, gfc_code *code) return; } - /* Step three: Try to find the label in the parse tree. To do this, - we traverse the tree block-by-block: first the block that - contains this GOTO, then the block that it is nested in, etc. We - can ignore other blocks because branching into another block is - not allowed. */ + /* Step three: See if the label is in the same block as the + branching statement. The hard work has been done by setting up + the bitmap reachable_labels. */ - found = NULL; - - for (stack = cs_base; stack; stack = stack->prev) - { - for (block = stack->head; block; block = block->next) - { - if (block->here == label) - { - found = block; - break; - } - } - - if (found) - break; - } - - if (found == NULL) + if (!bitmap_bit_p (cs_base->reachable_labels, label->value)) { /* The label is not in an enclosing block, so illegal. This was - allowed in Fortran 66, so we allow it as extension. We also - forego further checks if we run into this. */ + allowed in Fortran 66, so we allow it as extension. No + further checks are necessary in this case. */ gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block " - "as the GOTO statement at %L", &lp->where, &code->loc); + "as the GOTO statement at %L", &label->where, + &code->loc); return; } /* Step four: Make sure that the branching target is legal if - the statement is an END {SELECT,DO,IF}. */ + the statement is an END {SELECT,IF}. */ - if (found->op == EXEC_NOP) + for (stack = cs_base; stack; stack = stack->prev) + if (stack->current->next && stack->current->next->here == label) + break; + + if (stack && stack->current->next->op == EXEC_NOP) { - for (stack = cs_base; stack; stack = stack->prev) - if (stack->current->next == found) - break; - - if (stack == NULL) - gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: GOTO at %L jumps to END " - "of construct at %L", &code->loc, &found->loc); + gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: GOTO at %L jumps to " + "END of construct at %L", &code->loc, + &stack->current->next->loc); + return; /* We know this is not an END DO. */ } + + /* Step five: Make sure that we're not jumping to the end of a DO + loop from within the loop. */ + + for (stack = cs_base; stack; stack = stack->prev) + if ((stack->current->op == EXEC_DO + || stack->current->op == EXEC_DO_WHILE) + && stack->tail->here == label && stack->tail->op == EXEC_NOP) + { + gfc_notify_std (GFC_STD_F95_DEL, "Obsolete: GOTO at %L jumps " + "to END of construct at %L", &code->loc, + &stack->tail->loc); + return; + + } } @@ -5004,6 +5041,8 @@ resolve_code (gfc_code *code, gfc_namespace *ns) frame.head = code; cs_base = &frame; + reachable_labels (code); + for (; code; code = code->next) { frame.current = code; @@ -7338,7 +7377,10 @@ resolve_codes (gfc_namespace *ns) cs_base = NULL; /* Set to an out of range value. */ current_entry_id = -1; + + bitmap_obstack_initialize (&labels_obstack); resolve_code (ns->code, ns); + bitmap_obstack_release (&labels_obstack); } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 215518516cc..a22295a355f 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2007-04-13 Tobias Schlüter + + PR fortran/18937 + * gfortran.dg/goto_2.f90: New. + * gfortran.dg/goto_3.f90: New. + * gfortran.dg/pr17708.f90: Rename to ... + * gfortran.dg/goto_4.f90: ... this, add comment pointing to PR. + 2007-04-13 Tobias Burnus PR fortran/31562 diff --git a/gcc/testsuite/gfortran.dg/goto_2.f90 b/gcc/testsuite/gfortran.dg/goto_2.f90 new file mode 100644 index 00000000000..acff590a9cd --- /dev/null +++ b/gcc/testsuite/gfortran.dg/goto_2.f90 @@ -0,0 +1,59 @@ +! { dg-do run } +! Checks for corrects warnings if branching to then end of a +! construct at various nesting levels + subroutine check_if(i) + goto 10 + if (i > 0) goto 40 + if (i < 0) then + goto 40 +10 end if + if (i == 0) then + i = i+1 + goto 20 ! { dg-warning "jumps to END of construct" } + goto 40 +20 end if ! { dg-warning "jumps to END of construct" } + if (i == 1) then + i = i+1 + if (i == 2) then + goto 30 ! { dg-warning "jumps to END of construct" } + end if + goto 40 +30 end if ! { dg-warning "jumps to END of construct" } + return +40 i = -1 + end subroutine check_if + + subroutine check_select(i) + goto 10 + select case (i) + case default + goto 999 +10 end select + select case (i) + case (2) + i = 1 + goto 20 ! { dg-warning "jumps to END of construct" } + goto 999 + case default + goto 999 +20 end select ! { dg-warning "jumps to END of construct" } + j = i + select case (j) + case default + select case (i) + case (1) + i = 2 + goto 30 ! { dg-warning "jumps to END of construct" } + end select + goto 999 +30 end select ! { dg-warning "jumps to END of construct" } + return +999 i = -1 + end subroutine check_select + + i = 0 + call check_if (i) + if (i /= 2) call abort () + call check_select (i) + if (i /= 2) call abort () +end diff --git a/gcc/testsuite/gfortran.dg/goto_3.f90 b/gcc/testsuite/gfortran.dg/goto_3.f90 new file mode 100644 index 00000000000..918443abbd9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/goto_3.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! Verify that various cases of invalid branches are rejected + dimension a(10) + if (i>0) then + goto 10 ! { dg-error "not a valid branch target statement" } +10 else ! { dg-error "not a valid branch target statement" } + i = -i + end if + + goto 20 ! { dg-error "not a valid branch target statement" } + forall (i=1:10) + a(i) = 2*i +20 end forall ! { dg-error "not a valid branch target statement" } + + goto 30 ! { dg-error "not a valid branch target statement" } + goto 40 ! { dg-error "not a valid branch target statement" } + where (a>0) + a = 2*a +30 elsewhere ! { dg-error "not a valid branch target statement" } + a = a/2 +40 end where ! { dg-error "not a valid branch target statement" } + end + diff --git a/gcc/testsuite/gfortran.dg/pr17708.f90 b/gcc/testsuite/gfortran.dg/goto_4.f90 similarity index 78% rename from gcc/testsuite/gfortran.dg/pr17708.f90 rename to gcc/testsuite/gfortran.dg/goto_4.f90 index b696b0c2757..d48af7240fe 100644 --- a/gcc/testsuite/gfortran.dg/pr17708.f90 +++ b/gcc/testsuite/gfortran.dg/goto_4.f90 @@ -1,4 +1,5 @@ ! { dg-do run } +! PR 17708: Jumping to END DO statements didn't do the right thing program test j = 0 do 10 i=1,3