re PR fortran/18937 (quadratic behaviour with many label "spaghetti" code)
PR fortran/18937 fortran/ * 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. testsuite/ * 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. From-SVN: r123789
This commit is contained in:
Tobias Schlüter
parent
d1138d8e5e
commit
0615f92345
|
|
@ -1,3 +1,14 @@
|
|||
2007-04-13 Tobias Schlüter <tobi@gcc.gnu.org>
|
||||
|
||||
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 <tobi@gcc.gnu.org>
|
||||
|
||||
PR fortran/31250
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,3 +1,11 @@
|
|||
2007-04-13 Tobias Schlüter <tobi@gcc.gnu.org>
|
||||
|
||||
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 <burnus@net-b.de>
|
||||
|
||||
PR fortran/31562
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
||||
|
|
@ -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
|
||||
Loading…
Reference in New Issue