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

gcc/fortran/ChangeLog

+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

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.  */
-
-  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;
-    }
+  /* 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.  */
 
-  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 == found)
-	  break;
+  for (stack = cs_base; stack; stack = stack->prev)
+    if (stack->current->next && stack->current->next->here == label)
+      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);
+  if (stack && stack->current->next->op == EXEC_NOP)
+    {
+      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);
 }
 
 

gcc/testsuite/ChangeLog

+2007-04-13  Tobias Schlter  <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

gcc/testsuite/gfortran.dg/goto_2.f90

+! { 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

gcc/testsuite/gfortran.dg/goto_3.f90

+! { 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
+ 

gcc/testsuite/gfortran.dg/pr17708.f90 → gcc/testsuite/gfortran.dg/goto_4.f90

 ! { 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