re PR fortran/38507 (Bogus Warning: Deleted feature: GOTO jumps to END of construct)

fortran/
PR fortran/38507
* gfortran.h (gfc_st_label): Fix comment.
(gfc_exec_op): Add statement code EXEC_END_BLOCK for end of block.
* parse.c (accept_statement): Use EXEC_END_BLOCK for END IF and
END SELECT with labels.
(check_do_closure): Fix formatting.
(parse_do_block): Fix typo in error message.
* resolve.c (code_stack): Remove tail member.  Update comment to
new use of reachable_labels.
(reachable_labels): Rename to ...
(find_reachable_labels): ... this.  Overhaul.  Update preceding
comment.
(resolve_branch): Fix comment preceding function.  Rewrite.
(resolve_code): Update call to find_reachable_labels.  Add code to
deal with EXEC_END_BLOCK.
* st.c (gfc_free_statement): Add code to deal with EXEC_END_BLOCK.
* trans.c (gfc_trans_code): Likewise.
testsuite/
* do_4.f: New.
* goto_2.f90: Correct expected warnings.
* goto_4.f90: Likewise.
* goto_5.f90: New.

From-SVN: r145245

gcc/fortran/ChangeLog

+2008-03-29  Tobias Schlter  <tobi@gcc.gnu.org>
+
+	PR fortran/38507
+	* gfortran.h (gfc_st_label): Fix comment.
+	(gfc_exec_op): Add statement code EXEC_END_BLOCK for end of block.
+	* parse.c (accept_statement): Use EXEC_END_BLOCK for END IF and
+	END SELECT with labels.
+	(check_do_closure): Fix formatting.
+	(parse_do_block): Fix typo in error message.
+	* resolve.c (code_stack): Remove tail member.  Update comment to
+	new use of reachable_labels.
+	(reachable_labels): Rename to ...
+	(find_reachable_labels): ... this.  Overhaul.  Update preceding
+	comment.
+	(resolve_branch): Fix comment preceding function.  Rewrite.
+	(resolve_code): Update call to find_reachable_labels.  Add code to
+	deal with EXEC_END_BLOCK.
+	* st.c (gfc_free_statement): Add code to deal with EXEC_END_BLOCK.
+	Add 2009 to copyright years.
+	* trans.c (gfc_trans_code): Likewise on both counts.
+
 2009-03-28  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/34656

gcc/fortran/gfortran.h

@@ -954,10 +954,9 @@ gfc_omp_clauses;
 #define gfc_get_omp_clauses() XCNEW (gfc_omp_clauses)
 
 
-/* The gfc_st_label structure is a doubly linked list attached to a
-   namespace that records the usage of statement labels within that
-   space.  */
-/* TODO: Make format/statement specifics a union.  */
+/* The gfc_st_label structure is a BBT attached to a namespace that
+   records the usage of statement labels within that space.  */
+
 typedef struct gfc_st_label
 {
   BBT_HEADER(gfc_st_label);
@@ -1861,7 +1860,8 @@ gfc_forall_iterator;
 /* Executable statements that fill gfc_code structures.  */
 typedef enum
 {
-  EXEC_NOP = 1, EXEC_ASSIGN, EXEC_LABEL_ASSIGN, EXEC_POINTER_ASSIGN,
+  EXEC_NOP = 1, EXEC_END_BLOCK, EXEC_ASSIGN, EXEC_LABEL_ASSIGN,
+  EXEC_POINTER_ASSIGN,
   EXEC_GOTO, EXEC_CALL, EXEC_COMPCALL, EXEC_ASSIGN_CALL, EXEC_RETURN,
   EXEC_ENTRY, EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE, EXEC_INIT_ASSIGN,
   EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_WHILE, EXEC_SELECT,

gcc/fortran/parse.c

@@ -1465,16 +1465,23 @@ accept_statement (gfc_statement st)
 
       /* If the statement is the end of a block, lay down a special code
 	 that allows a branch to the end of the block from within the
-	 construct.  */
+	 construct.  IF and SELECT are treated differently from DO
+	 (where EXEC_NOP is added inside the loop) for two
+	 reasons:
+         1. END DO has a meaning in the sense that after a GOTO to
+	    it, the loop counter must be increased.
+         2. IF blocks and SELECT blocks can consist of multiple
+	    parallel blocks (IF ... ELSE IF ... ELSE ... END IF).
+	    Putting the label before the END IF would make the jump
+	    from, say, the ELSE IF block to the END IF illegal.  */
 
     case ST_ENDIF:
     case ST_END_SELECT:
       if (gfc_statement_label != NULL)
 	{
-	  new_st.op = EXEC_NOP;
+	  new_st.op = EXEC_END_BLOCK;
 	  add_statement ();
 	}
-
       break;
 
       /* The end-of-program unit statements do not get the special
@@ -2817,7 +2824,6 @@ check_do_closure (void)
 
   if (p->ext.end_do_label == gfc_statement_label)
     {
-
       if (p == gfc_state_stack)
 	return 1;
 
@@ -2895,7 +2901,7 @@ loop:
 	name, but in that case we must have seen ST_ENDDO first).
 	We only complain about this in pedantic mode.  */
      if (gfc_current_block () != NULL)
-	gfc_error_now ("named block DO at %L requires matching ENDDO name",
+	gfc_error_now ("Named block DO at %L requires matching ENDDO name",
 		       &gfc_current_block()->declared_at);
 
       break;

gcc/fortran/resolve.c

@@ -43,11 +43,12 @@ seq_type;
 
 typedef struct code_stack
 {
-  struct gfc_code *head, *current, *tail;
+  struct gfc_code *head, *current;
   struct code_stack *prev;
 
   /* This bitmap keeps track of the targets valid for a branch from
-     inside this block.  */
+     inside this block except for END {IF|SELECT}s of enclosing
+     blocks.  */
   bitmap reachable_labels;
 }
 code_stack;
@@ -5978,11 +5979,10 @@ 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.  */
+   record the last statement in each block.  */
      
 static void
-reachable_labels (gfc_code *block)
+find_reachable_labels (gfc_code *block)
 {
   gfc_code *c;
 
@@ -5991,14 +5991,13 @@ reachable_labels (gfc_code *block)
 
   cs_base->reachable_labels = bitmap_obstack_alloc (&labels_obstack);
 
-  /* Collect labels in this block.  */
+  /* Collect labels in this block.  We don't keep those corresponding
+     to END {IF|SELECT}, these are checked in resolve_branch by going
+     up through the code_stack.  */
   for (c = block; c; c = c->next)
     {
-      if (c->here)
+      if (c->here && c->op != EXEC_END_BLOCK)
 	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.  */
@@ -6010,7 +6009,7 @@ reachable_labels (gfc_code *block)
     }
 }
 
-/* Given a branch to a label and a namespace, if the branch is conforming.
+/* Given a branch to a label, see if the branch is conforming.
    The code node describes where the branch is located.  */
 
 static void
@@ -6049,46 +6048,30 @@ resolve_branch (gfc_st_label *label, gfc_code *code)
      branching statement.  The hard work has been done by setting up
      the bitmap reachable_labels.  */
 
-  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.  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", &label->where,
-		      &code->loc);
-      return;
-    }
+  if (bitmap_bit_p (cs_base->reachable_labels, label->value))
+    return;
 
-  /* Step four: Make sure that the branching target is legal if
-     the statement is an END {SELECT,IF}.  */
+  /* Step four:  If we haven't found the label in the bitmap, it may
+    still be the label of the END of the enclosing block, in which
+    case we find it by going up the code_stack.  */
 
   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)
+  if (stack)
     {
-      gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: 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.  */
+      gcc_assert (stack->current->next->op == EXEC_END_BLOCK);
+      return;
     }
 
-  /* 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, "Deleted feature: GOTO at %L jumps "
-			"to END of construct at %L", &code->loc,
-			&stack->tail->loc);
-	return;
-
-      }
+  /* The label is not in an enclosing block, so illegal.  This was
+     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", &label->where,
+		  &code->loc);
+  return;
 }
 
 
@@ -6669,7 +6652,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
   frame.head = code;
   cs_base = &frame;
 
-  reachable_labels (code);
+  find_reachable_labels (code);
 
   for (; code; code = code->next)
     {
@@ -6727,6 +6710,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
       switch (code->op)
 	{
 	case EXEC_NOP:
+	case EXEC_END_BLOCK:
 	case EXEC_CYCLE:
 	case EXEC_PAUSE:
 	case EXEC_STOP:

gcc/fortran/st.c

 /* Build executable statement trees.
-   Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008
+   Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009
    Free Software Foundation, Inc.
    Contributed by Andy Vaught
 
@@ -88,6 +88,7 @@ gfc_free_statement (gfc_code *p)
   switch (p->op)
     {
     case EXEC_NOP:
+    case EXEC_END_BLOCK:
     case EXEC_ASSIGN:
     case EXEC_INIT_ASSIGN:
     case EXEC_GOTO:

gcc/fortran/trans.c

 /* Code translation -- generate GCC trees from gfc_code.
-   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software
-   Foundation, Inc.
+   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free
+   Software Foundation, Inc.
    Contributed by Paul Brook
 
 This file is part of GCC.
@@ -1055,6 +1055,7 @@ gfc_trans_code (gfc_code * code)
       switch (code->op)
 	{
 	case EXEC_NOP:
+	case EXEC_END_BLOCK:
 	  res = NULL_TREE;
 	  break;
 

gcc/testsuite/ChangeLog

+2008-03-29  Tobias Schlter  <tobi@gcc.gnu.org>
+
+	PR fortran/38507
+	* gfortran.dg/do_4.f: New.
+	* gfortran.dg/goto_2.f90: Correct expected warnings.
+	* gfortran.dg/goto_4.f90: Likewise.
+	* gfortran.dg/goto_5.f90: New.
+
 2009-03-29  H.J. Lu  <hongjiu.lu@intel.com>
 
 	PR target/39545

gcc/testsuite/gfortran.dg/do_4.f

+! { dg-do compile }
+! Verify that the loop not terminated on an action-stmt is correctly rejected
+       do10i=1,20
+       if(i.eq.5)then
+          goto 10
+ 10    endif           ! { dg-error "is within another block" }
+       end
+! { dg-excess-errors "" }
+

gcc/testsuite/gfortran.dg/goto_2.f90

@@ -2,51 +2,51 @@
 ! Checks for corrects warnings if branching to then end of a
 ! construct at various nesting levels
   subroutine check_if(i)
-    goto 10
+    goto 10  ! { dg-warning "Label at ... is not in the same block" }
     if (i > 0) goto 40
     if (i < 0) then
        goto 40
-10  end if
+10  end if    ! { dg-warning "Label at ... is not in the same block" }
     if (i == 0) then
        i = i+1
-       goto 20  ! { dg-warning "jumps to END of construct" }
+       goto 20
        goto 40
-20  end if   ! { dg-warning "jumps to END of construct" }
+20  end if
     if (i == 1) then
        i = i+1
        if (i == 2) then
-          goto 30 ! { dg-warning "jumps to END of construct" }
+          goto 30
        end if
        goto 40
-30  end if    ! { dg-warning "jumps to END of construct" }
+30  end if
     return
 40  i = -1
   end subroutine check_if
   
   subroutine check_select(i)
-    goto 10
+    goto 10  ! { dg-warning "Label at ... is not in the same block" }
     select case (i)
     case default
        goto 999
-10  end select
+10  end select  ! { dg-warning "Label at ... is not in the same block" }
     select case (i)
     case (2)
        i = 1
-       goto 20  ! { dg-warning "jumps to END of construct" }
+       goto 20
        goto 999
     case default
        goto 999
-20  end select   ! { dg-warning "jumps to END of construct" }
+20  end select
     j = i
     select case (j)
     case default
        select case (i)
        case (1)
           i = 2
-          goto 30  ! { dg-warning "jumps to END of construct" }
+          goto 30
        end select
        goto 999
-30  end select    ! { dg-warning "jumps to END of construct" }
+30  end select
     return    
 999 i = -1
   end subroutine check_select

gcc/testsuite/gfortran.dg/goto_4.f90

 ! { dg-do run }
 ! PR 17708: Jumping to END DO statements didn't do the right thing
+! PR 38507: The warning we used to give was wrong
       program test
         j = 0
         do 10 i=1,3
-           if(i == 2) goto 10 ! { dg-warning "jumps to END" }
+           if(i == 2) goto 10
            j = j+1
-10      enddo                 ! { dg-warning "jumps to END" }
+10      enddo
         if (j/=2) call abort
       end

gcc/testsuite/gfortran.dg/goto_5.f90

+! { dg-do compile }
+! PR 38507
+! Verify that we correctly flag invalid gotos, while not flagging valid gotos.
+integer i,j
+
+do i=1,10
+   goto 20
+20 end do   ! { dg-warning "is not in the same block" }
+
+goto 20   ! { dg-warning "is not in the same block" }
+goto 25   ! { dg-warning "is not in the same block" }
+goto 40   ! { dg-warning "is not in the same block" }
+goto 50   ! { dg-warning "is not in the same block" }
+
+goto 222
+goto 333
+goto 444
+
+222 if (i < 0) then
+25 end if      ! { dg-warning "is not in the same block" }
+
+333 if (i > 0) then
+   do j = 1,20
+      goto 30
+   end do
+else if (i == 0) then
+   goto 30
+else
+   goto 30
+30 end if
+
+444 select case(i)
+case(0)
+   goto 50
+   goto 60  ! { dg-warning "is not in the same block" }
+case(1)
+   goto 40
+   goto 50
+   40 continue  ! { dg-warning "is not in the same block" }
+   60 continue    ! { dg-warning "is not in the same block" }
+50 end select   ! { dg-warning "is not in the same block" }
+continue 
+
+end