re PR fortran/44709 (BLOCK and GOTO/EXIT/CYCLE)

2010-07-23  Daniel Kraft  <d@domob.eu>

	PR fortran/44709
	* gfortran.h (gfc_find_symtree_in_proc): New method.
	* symbol.c (gfc_find_symtree_in_proc): New method.
	* match.c (match_exit_cycle): Look for loop name also in parent
	namespaces within current procedure.

2010-07-23  Daniel Kraft  <d@domob.eu>

	PR fortran/44709
	* gfortran.dg/exit_1.f08: New test.
	* gfortran.dg/exit_2.f08: New test.

From-SVN: r162450

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index de6e55f6377a7204303e35f626a3569704d8ee89..80b48764948c223c16b8c67a407abfbf1b79d78c 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+2010-07-23  Daniel Kraft  <d@domob.eu>
+
+       PR fortran/44709
+       * gfortran.h (gfc_find_symtree_in_proc): New method.
+       * symbol.c (gfc_find_symtree_in_proc): New method.
+       * match.c (match_exit_cycle): Look for loop name also in parent
+       namespaces within current procedure.
+
 2010-07-22  Tobias Burnus  <burnus@net-b.de>
 
        PR fortran/45019

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 11ff594f59ba1c20bf00d821091973854e505a87..401e501c41ddcad7993a99246938206c7ffd1af8 100644 (file)
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2512,6 +2512,7 @@ gfc_user_op *gfc_get_uop (const char *);
 gfc_user_op *gfc_find_uop (const char *, gfc_namespace *);
 void gfc_free_symbol (gfc_symbol *);
 gfc_symbol *gfc_new_symbol (const char *, gfc_namespace *);
+gfc_symtree* gfc_find_symtree_in_proc (const char *, gfc_namespace *);
 int gfc_find_symbol (const char *, gfc_namespace *, int, gfc_symbol **);
 int gfc_find_sym_tree (const char *, gfc_namespace *, int, gfc_symtree **);
 int gfc_get_symbol (const char *, gfc_namespace *, gfc_symbol **);

diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 56e9d1d515dd9085be3d98d5579a0ddc1e40623f..92580e359dbdf5e758ece2f9b990b6e9ea1f5b6a 100644 (file)
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -2006,7 +2006,10 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op)
     sym = NULL;
   else
     {
-      m = gfc_match ("% %s%t", &sym);
+      char name[GFC_MAX_SYMBOL_LEN + 1];
+      gfc_symtree* stree;
+
+      m = gfc_match ("% %n%t", name);
       if (m == MATCH_ERROR)
        return MATCH_ERROR;
       if (m == MATCH_NO)
@@ -2015,10 +2018,22 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op)
          return MATCH_ERROR;
        }
 
+      /* Find the corresponding symbol.  If there's a BLOCK statement
+        between here and the label, it is not in gfc_current_ns but a parent
+        namespace!  */
+      stree = gfc_find_symtree_in_proc (name, gfc_current_ns);
+      if (!stree)
+       {
+         gfc_error ("Name '%s' in %s statement at %C is unknown",
+                    name, gfc_ascii_statement (st));
+         return MATCH_ERROR;
+       }
+
+      sym = stree->n.sym;
       if (sym->attr.flavor != FL_LABEL)
        {
          gfc_error ("Name '%s' in %s statement at %C is not a loop name",
-                    sym->name, gfc_ascii_statement (st));
+                    name, gfc_ascii_statement (st));
          return MATCH_ERROR;
        }
     }

diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index c12ea23a05e9b76f80e66fc54c905072618e66cd..18f7b253a28843713f2b01c073fe19bd6b9a7411 100644 (file)
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -2565,6 +2565,27 @@ select_type_insert_tmp (gfc_symtree **st)
 }
 
 
+/* Look for a symtree in the current procedure -- that is, go up to
+   parent namespaces but only if inside a BLOCK.  Returns NULL if not found.  */
+
+gfc_symtree*
+gfc_find_symtree_in_proc (const char* name, gfc_namespace* ns)
+{
+  while (ns)
+    {
+      gfc_symtree* st = gfc_find_symtree (ns->sym_root, name);
+      if (st)
+       return st;
+
+      if (!ns->construct_entities)
+       break;
+      ns = ns->parent;
+    }
+
+  return NULL;
+}
+
+
 /* Search for a symtree starting in the current namespace, resorting to
    any parent namespaces if requested by a nonzero parent_flag.
    Returns nonzero if the name is ambiguous.  */

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index dfcd727337dbee95698f7760c5b6fb8932734ce0..550b4b1bba78a2bb0f7d2c857df54c6fa56a2430 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2010-07-23  Daniel Kraft  <d@domob.eu>
+
+       PR fortran/44709
+       * gfortran.dg/exit_1.f08: New test.
+       * gfortran.dg/exit_2.f08: New test.
+
 2010-07-22  Sandra Loosemore  <sandra@codesourcery.com>
 
        PR tree-optimization/39839

diff --git a/gcc/testsuite/gfortran.dg/exit_1.f08 b/gcc/testsuite/gfortran.dg/exit_1.f08
new file mode 100644 (file)
index 0000000..9ebc2ec
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/exit_1.f08
@@ -0,0 +1,50 @@
+! { dg-do run }
+! { dg-options "-std=f2008 -fall-intrinsics" }
+
+! PR fortran/44709
+! Check that exit and cycle from within a BLOCK works for loops as expected.
+
+! Contributed by Daniel Kraft, d@domob.eu.
+
+PROGRAM main
+  IMPLICIT NONE
+  INTEGER :: i
+  
+  ! Simple exit without loop name.
+  DO
+    BLOCK
+      EXIT
+    END BLOCK
+    CALL abort ()
+  END DO
+
+  ! Cycle without loop name.
+  DO i = 1, 1
+    BLOCK
+      CYCLE
+    END BLOCK
+    CALL abort ()
+  END DO
+
+  ! Exit loop by name from within a BLOCK.
+  loop1: DO
+    DO
+      BLOCK
+        EXIT loop1
+      END BLOCK
+      CALL abort ()
+    END DO
+    CALL abort ()
+  END DO loop1
+
+  ! Cycle loop by name from within a BLOCK.
+  loop2: DO i = 1, 1
+    loop3: DO
+      BLOCK
+        CYCLE loop2
+      END BLOCK
+      CALL abort ()
+    END DO loop3
+    CALL abort ()
+  END DO loop2
+END PROGRAM main

diff --git a/gcc/testsuite/gfortran.dg/exit_2.f08 b/gcc/testsuite/gfortran.dg/exit_2.f08
new file mode 100644 (file)
index 0000000..23e7009
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/exit_2.f08
@@ -0,0 +1,31 @@
+! { dg-do compile }
+! { dg-options "-std=f2008" }
+
+! PR fortran/44709
+! Check that the resolving of loop names in parent namespaces introduced to
+! handle intermediate BLOCK's does not go too far and other sanity checks.
+
+! Contributed by Daniel Kraft, d@domob.eu.
+
+PROGRAM main
+  IMPLICIT NONE
+  
+  EXIT ! { dg-error "is not within a loop" }
+  EXIT foobar ! { dg-error "is unknown" }
+  EXIT main ! { dg-error "is not a loop name" }
+
+  mainLoop: DO
+    CALL test ()
+  END DO mainLoop
+
+  otherLoop: DO
+    EXIT mainLoop ! { dg-error "is not within loop 'mainloop'" }
+  END DO otherLoop
+
+CONTAINS
+
+  SUBROUTINE test ()
+    EXIT mainLoop ! { dg-error "is unknown" }
+  END SUBROUTINE test
+
+END PROGRAM main