===================================================================
@@ -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. */
===================================================================
@@ -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 **);
===================================================================
@@ -2006,7 +2006,10 @@ match_exit_cycle (gfc_statement st, gfc_
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_
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;
}
}
===================================================================
@@ -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
===================================================================
@@ -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