Patchwork [Fortran] PR fortran/44709: EXIT/CYCLE a named loop from within a BLOCK

login
register
mail settings
Submitter Daniel Kraft
Date July 23, 2010, 8:39 a.m.
Message ID <4C49553A.4030806@domob.eu>
Download mbox | patch
Permalink /patch/59741/
State New
Headers show

Comments

Daniel Kraft - July 23, 2010, 8:39 a.m.
Hi all,

the attached patch fixes a small problem (the still missing one of PR
44709) that rejected EXIT/CYCLE statements with loop-name when there was
a BLOCK inbetween the statement and the loop.

The problem is simply that EXIT/CYCLE matching looked for the label just
within the current namespace, but as BLOCK introduces a new one, needs
to search also in the parent namespaces -- however, of course only
within the current procedure.  Thus I added a new function
gfc_find_symtree_in_proc that does exactly this (look through namespaces
including parents as long as those are for constructs and not seperate
procedures) and use it in the matcher.

Regression testing at the moment at GNU/Linux-x86-32.  Ok for trunk if
no failure?

Still missing for this area of features is EXIT for any constructs, just
as a side-note.

Yours,
Daniel
Tobias Burnus - July 23, 2010, 8:46 a.m.
On 07/23/2010 10:39 AM, Daniel Kraft wrote:
> Regression testing at the moment at GNU/Linux-x86-32.  Ok for trunk if
> no failure?

OK. Thanks for the patch!

Tobias
Daniel Kraft - July 23, 2010, 9:59 a.m.
Tobias Burnus wrote:
> On 07/23/2010 10:39 AM, Daniel Kraft wrote:
>> Regression testing at the moment at GNU/Linux-x86-32.  Ok for trunk if
>> no failure?
> 
> OK. Thanks for the patch!

No failures, committed as rev. 162450.

Daniel

Patch

Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 162408)
+++ gcc/fortran/symbol.c	(working copy)
@@ -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.  */
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 162408)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -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 **);
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c	(revision 162408)
+++ gcc/fortran/match.c	(working copy)
@@ -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;
 	}
     }
Index: gcc/testsuite/gfortran.dg/exit_2.f08
===================================================================
--- gcc/testsuite/gfortran.dg/exit_2.f08	(revision 0)
+++ gcc/testsuite/gfortran.dg/exit_2.f08	(revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/exit_1.f08
===================================================================
--- gcc/testsuite/gfortran.dg/exit_1.f08	(revision 0)
+++ gcc/testsuite/gfortran.dg/exit_1.f08	(revision 0)
@@ -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