[Fortran] RFC: Exit from non-loop constructs

Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 163637)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -2093,7 +2093,7 @@  typedef struct gfc_code
     gfc_wait *wait;
     gfc_dt *dt;
     gfc_forall_iterator *forall_iterator;
-    struct gfc_code *whichloop;
+    struct gfc_code *which_construct;
     int stop_code;
     gfc_entry_list *entry;
     gfc_omp_clauses *omp_clauses;
@@ -2103,7 +2103,7 @@  typedef struct gfc_code
   }
   ext;		/* Points to additional structures required by statement */
 
-  /* Cycle and break labels in do loops.  */
+  /* Cycle and break labels in constructs.  */
   tree cycle_label;
   tree exit_label;
 }
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c	(revision 163637)
+++ gcc/fortran/trans-stmt.c	(working copy)
@@ -745,10 +745,21 @@  gfc_trans_if_1 (gfc_code * code)
 tree
 gfc_trans_if (gfc_code * code)
 {
-  /* Ignore the top EXEC_IF, it only announces an IF construct. The
-     actual code we must translate is in code->block.  */
+  stmtblock_t body;
+  tree exit_label;
 
-  return gfc_trans_if_1 (code->block);
+  /* Create exit label so it is available for trans'ing the body code.  */
+  exit_label = gfc_build_label_decl (NULL_TREE);
+  code->exit_label = exit_label;
+
+  /* Translate the actual code in code->block.  */
+  gfc_init_block (&body);
+  gfc_add_expr_to_block (&body, gfc_trans_if_1 (code->block));
+
+  /* Add exit label.  */
+  gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label));
+
+  return gfc_finish_block (&body);
 }
 
 
@@ -850,22 +861,32 @@  gfc_trans_block_construct (gfc_code* cod
 {
   gfc_namespace* ns;
   gfc_symbol* sym;
-  gfc_wrapped_block body;
+  gfc_wrapped_block block;
+  tree exit_label;
+  stmtblock_t body;
 
   ns = code->ext.block.ns;
   gcc_assert (ns);
   sym = ns->proc_name;
   gcc_assert (sym);
 
+  /* Process local variables.  */
   gcc_assert (!sym->tlink);
   sym->tlink = sym;
-
   gfc_process_block_locals (ns, code->ext.block.assoc);
 
-  gfc_start_wrapped_block (&body, gfc_trans_code (ns->code));
-  gfc_trans_deferred_vars (sym, &body);
+  /* Generate code including exit-label.  */
+  gfc_init_block (&body);
+  exit_label = gfc_build_label_decl (NULL_TREE);
+  code->exit_label = exit_label;
+  gfc_add_expr_to_block (&body, gfc_trans_code (ns->code));
+  gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label));
+
+  /* Finish everything.  */
+  gfc_start_wrapped_block (&block, gfc_finish_block (&body));
+  gfc_trans_deferred_vars (sym, &block);
 
-  return gfc_finish_wrapped_block (&body);
+  return gfc_finish_wrapped_block (&block);
 }
 
 
@@ -928,8 +949,8 @@  gfc_trans_simple_do (gfc_code * code, st
   exit_label = gfc_build_label_decl (NULL_TREE);
 
   /* Put the labels where they can be found later. See gfc_trans_do().  */
-  code->block->cycle_label = cycle_label;
-  code->block->exit_label = exit_label;
+  code->cycle_label = cycle_label;
+  code->exit_label = exit_label;
 
   /* Loop body.  */
   gfc_start_block (&body);
@@ -1106,6 +1127,10 @@  gfc_trans_do (gfc_code * code, tree exit
   exit_label = gfc_build_label_decl (NULL_TREE);
   TREE_USED (exit_label) = 1;
 
+  /* Put these labels where they can be found later.  */
+  code->cycle_label = cycle_label;
+  code->exit_label = exit_label;
+
   /* Initialize the DO variable: dovar = from.  */
   gfc_add_modify (&block, dovar, from);
 
@@ -1197,11 +1222,6 @@  gfc_trans_do (gfc_code * code, tree exit
   /* Loop body.  */
   gfc_start_block (&body);
 
-  /* Put these labels where they can be found later.  */
-
-  code->block->cycle_label = cycle_label;
-  code->block->exit_label = exit_label;
-
   /* Main loop body.  */
   tmp = gfc_trans_code_cond (code->block->next, exit_cond);
   gfc_add_expr_to_block (&body, tmp);
@@ -1304,8 +1324,8 @@  gfc_trans_do_while (gfc_code * code)
   exit_label = gfc_build_label_decl (NULL_TREE);
 
   /* Put the labels where they can be found later. See gfc_trans_do().  */
-  code->block->cycle_label = cycle_label;
-  code->block->exit_label = exit_label;
+  code->cycle_label = cycle_label;
+  code->exit_label = exit_label;
 
   /* Create a GIMPLE version of the exit condition.  */
   gfc_init_se (&cond, NULL);
@@ -1943,22 +1963,47 @@  gfc_trans_character_select (gfc_code *co
 tree
 gfc_trans_select (gfc_code * code)
 {
+  stmtblock_t block;
+  tree body;
+  tree exit_label;
+
   gcc_assert (code && code->expr1);
+  gfc_init_block (&block);
+
+  /* Build the exit label and hang it in.  */
+  exit_label = gfc_build_label_decl (NULL_TREE);
+  code->exit_label = exit_label;
 
   /* Empty SELECT constructs are legal.  */
   if (code->block == NULL)
-    return build_empty_stmt (input_location);
+    body = build_empty_stmt (input_location);
 
   /* Select the correct translation function.  */
-  switch (code->expr1->ts.type)
-    {
-    case BT_LOGICAL:	return gfc_trans_logical_select (code);
-    case BT_INTEGER:	return gfc_trans_integer_select (code);
-    case BT_CHARACTER:	return gfc_trans_character_select (code);
-    default:
-      gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
-      /* Not reached */
-    }
+  else
+    switch (code->expr1->ts.type)
+      {
+      case BT_LOGICAL:
+	body = gfc_trans_logical_select (code);
+	break;
+
+      case BT_INTEGER:
+	body = gfc_trans_integer_select (code);
+	break;
+
+      case BT_CHARACTER:
+	body = gfc_trans_character_select (code);
+	break;
+
+      default:
+	gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
+	/* Not reached */
+      }
+
+  /* Build everything together.  */
+  gfc_add_expr_to_block (&block, body);
+  gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label));
+
+  return gfc_finish_block (&block);
 }
 
 
@@ -4225,7 +4270,9 @@  gfc_trans_cycle (gfc_code * code)
 {
   tree cycle_label;
 
-  cycle_label = code->ext.whichloop->cycle_label;
+  cycle_label = code->ext.which_construct->cycle_label;
+  gcc_assert (cycle_label);
+
   TREE_USED (cycle_label) = 1;
   return build1_v (GOTO_EXPR, cycle_label);
 }
@@ -4240,7 +4287,9 @@  gfc_trans_exit (gfc_code * code)
 {
   tree exit_label;
 
-  exit_label = code->ext.whichloop->exit_label;
+  exit_label = code->ext.which_construct->exit_label;
+  gcc_assert (exit_label);
+
   TREE_USED (exit_label) = 1;
   return build1_v (GOTO_EXPR, exit_label);
 }
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 163637)
+++ gcc/fortran/resolve.c	(working copy)
@@ -7718,7 +7718,10 @@  resolve_select_type (gfc_code *code)
     return;
 
   /* Transform SELECT TYPE statement to BLOCK and associate selector to
-     target if present.  */
+     target if present.  If there are any EXIT statements referring to the
+     SELECT TYPE construct, this is no problem because the gfc_code
+     reference stays the same and EXIT is equally possible from the BLOCK
+     it is changed to.  */
   code->op = EXEC_BLOCK;
   if (code->expr2)
     {
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c	(revision 163637)
+++ gcc/fortran/match.c	(working copy)
@@ -2034,7 +2034,7 @@  match_exit_cycle (gfc_statement st, gfc_
       sym = stree->n.sym;
       if (sym->attr.flavor != FL_LABEL)
 	{
-	  gfc_error ("Name '%s' in %s statement at %C is not a loop name",
+	  gfc_error ("Name '%s' in %s statement at %C is not a construct name",
 		     name, gfc_ascii_statement (st));
 	  return MATCH_ERROR;
 	}
@@ -2042,9 +2042,7 @@  match_exit_cycle (gfc_statement st, gfc_
 
   /* Find the loop specified by the label (or lack of a label).  */
   for (o = NULL, p = gfc_state_stack; p; p = p->previous)
-    if (p->state == COMP_DO && (sym == NULL || sym == p->sym))
-      break;
-    else if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
+    if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
       o = p;
     else if (p->state == COMP_CRITICAL)
       {
@@ -2052,19 +2050,57 @@  match_exit_cycle (gfc_statement st, gfc_
 		  gfc_ascii_statement (st));
 	return MATCH_ERROR;
       }
+    else if ((sym && sym == p->sym) || (!sym && p->state == COMP_DO))
+      break;
 
   if (p == NULL)
     {
       if (sym == NULL)
-	gfc_error ("%s statement at %C is not within a loop",
+	gfc_error ("%s statement at %C is not within a construct",
 		   gfc_ascii_statement (st));
       else
-	gfc_error ("%s statement at %C is not within loop '%s'",
+	gfc_error ("%s statement at %C is not within construct '%s'",
 		   gfc_ascii_statement (st), sym->name);
 
       return MATCH_ERROR;
     }
 
+  /* Special checks for EXIT from non-loop constructs.  */
+  switch (p->state)
+    {
+    case COMP_DO:
+      break;
+
+    case COMP_CRITICAL:
+      /* This is already handled above.  */
+      gcc_unreachable ();
+
+    case COMP_ASSOCIATE:
+    case COMP_BLOCK:
+    case COMP_IF:
+    case COMP_SELECT:
+    case COMP_SELECT_TYPE:
+      gcc_assert (sym);
+      if (op != EXEC_EXIT)
+	{
+	  gfc_error ("%s statement at %C is not applicable to construct '%s'",
+		     gfc_ascii_statement (st), sym->name);
+	  return MATCH_ERROR;
+	}
+      if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: EXIT with no"
+			  " do-construct-name at %C") == FAILURE)
+	return MATCH_ERROR;
+      break;
+      
+    default:
+      /* XXX: Could this be any other construct at all?  Can we
+	 gcc_unreachable() here?  If not, which construct to use
+	 in the test-case to verify this error?  */
+      gfc_error ("%s statement at %C is not applicable to construct '%s'",
+		 gfc_ascii_statement (st), sym->name);
+      return MATCH_ERROR;
+    }
+
   if (o != NULL)
     {
       gfc_error ("%s statement at %C leaving OpenMP structured block",
@@ -2096,13 +2132,14 @@  match_exit_cycle (gfc_statement st, gfc_
 	}
       if (st == ST_CYCLE && cnt < collapse)
 	{
-	  gfc_error ("CYCLE statement at %C to non-innermost collapsed !$OMP DO loop");
+	  gfc_error ("CYCLE statement at %C to non-innermost collapsed"
+		     " !$OMP DO loop");
 	  return MATCH_ERROR;
 	}
     }
 
-  /* Save the first statement in the loop - needed by the backend.  */
-  new_st.ext.whichloop = p->head;
+  /* Save the first statement in the construct - needed by the backend.  */
+  new_st.ext.which_construct = p->construct;
 
   new_st.op = op;
 
Index: gcc/fortran/parse.c
===================================================================
--- gcc/fortran/parse.c	(revision 163637)
+++ gcc/fortran/parse.c	(working copy)
@@ -989,6 +989,16 @@  push_state (gfc_state_data *p, gfc_compi
   p->sym = sym;
   p->head = p->tail = NULL;
   p->do_variable = NULL;
+
+  /* If this the state of a construct like BLOCK, DO or IF, the corresponding
+     construct statement was accepted right before pushing the state.  Thus,
+     the construct's gfc_code is available as tail of the parent state.  */
+  /* XXX: Is there never a NULL previous state?  I.e., should this be rather
+     put in if(gfc_state_stack)... instead of the assertion?  But it seems
+     to regtest fine.  */
+  gcc_assert (gfc_state_stack);
+  p->construct = gfc_state_stack->tail;
+
   gfc_state_stack = p;
 }
 
Index: gcc/fortran/parse.h
===================================================================
--- gcc/fortran/parse.h	(revision 163637)
+++ gcc/fortran/parse.h	(working copy)
@@ -42,6 +42,7 @@  typedef struct gfc_state_data
   gfc_symbol *sym;              /* Block name associated with this level */
   gfc_symtree *do_variable;     /* For DO blocks the iterator variable.  */
 
+  struct gfc_code *construct;
   struct gfc_code *head, *tail;
   struct gfc_state_data *previous;
 
Index: gcc/testsuite/gfortran.dg/exit_2.f08
===================================================================
--- gcc/testsuite/gfortran.dg/exit_2.f08	(revision 163637)
+++ gcc/testsuite/gfortran.dg/exit_2.f08	(working copy)
@@ -10,16 +10,16 @@ 
 PROGRAM main
   IMPLICIT NONE
   
-  EXIT ! { dg-error "is not within a loop" }
+  EXIT ! { dg-error "is not within a construct" }
   EXIT foobar ! { dg-error "is unknown" }
-  EXIT main ! { dg-error "is not a loop name" }
+  EXIT main ! { dg-error "is not a construct name" }
 
   mainLoop: DO
     CALL test ()
   END DO mainLoop
 
   otherLoop: DO
-    EXIT mainLoop ! { dg-error "is not within loop 'mainloop'" }
+    EXIT mainLoop ! { dg-error "is not within construct 'mainloop'" }
   END DO otherLoop
 
 CONTAINS
Index: gcc/testsuite/gfortran.dg/exit_4.f08
===================================================================
--- gcc/testsuite/gfortran.dg/exit_4.f08	(revision 0)
+++ gcc/testsuite/gfortran.dg/exit_4.f08	(revision 0)
@@ -0,0 +1,21 @@ 
+! { dg-do compile }
+! { dg-options "-std=f2008 -fcoarray=single" }
+
+! PR fortran/44602
+! Check for compile-time errors with non-loop EXITs.
+
+! Contributed by Daniel Kraft, d@domob.eu.
+
+PROGRAM main
+  IMPLICIT NONE
+
+  ! Must not exit CRITICAL.
+  mycrit: CRITICAL
+    EXIT mycrit ! { dg-error "leaves CRITICAL" }
+  END CRITICAL mycrit
+
+  ! CYCLE is only allowed for loops!
+  myblock: BLOCK
+    CYCLE myblock ! { dg-error "is not applicable to construct 'myblock'" }
+  END BLOCK myblock
+END PROGRAM main
Index: gcc/testsuite/gfortran.dg/exit_3.f08
===================================================================
--- gcc/testsuite/gfortran.dg/exit_3.f08	(revision 0)
+++ gcc/testsuite/gfortran.dg/exit_3.f08	(revision 0)
@@ -0,0 +1,88 @@ 
+! { dg-do run }
+! { dg-options "-std=f2008 -fall-intrinsics" }
+
+! PR fortran/44602
+! Check for correct behaviour of EXIT / CYCLE combined with non-loop
+! constructs at run-time.
+
+! Contributed by Daniel Kraft, d@domob.eu.
+
+PROGRAM main
+  IMPLICIT NONE
+
+  TYPE :: t
+  END TYPE t
+
+  INTEGER :: i
+  CLASS(t), ALLOCATABLE :: var
+
+  ! EXIT and CYCLE without names always refer to innermost *loop*.  This
+  ! however is checked at run-time already in exit_1.f08.
+
+  ! Basic EXITs from different non-loop constructs.
+
+  i = 2
+  myif: IF (i == 1) THEN
+    CALL abort ()
+    EXIT myif
+  ELSE IF (i == 2) THEN
+    EXIT myif
+    CALL abort ()
+  ELSE
+    CALL abort ()
+    EXIT myif
+  END IF myif
+
+  mysel: SELECT CASE (i)
+    CASE (1)
+      CALL abort ()
+      EXIT mysel
+    CASE (2)
+      EXIT mysel
+      CALL abort ()
+    CASE DEFAULT
+      CALL abort ()
+      EXIT mysel
+  END SELECT mysel
+
+  mycharsel: SELECT CASE ("foobar")
+    CASE ("abc")
+      CALL abort ()
+      EXIT mycharsel
+    CASE ("xyz")
+      CALL abort ()
+      EXIT mycharsel
+    CASE DEFAULT
+      EXIT mycharsel
+      CALL abort ()
+  END SELECT mycharsel
+
+  myblock: BLOCK
+    EXIT myblock
+    CALL abort ()
+  END BLOCK myblock
+
+  myassoc: ASSOCIATE (x => 5 + 2)
+    EXIT myassoc
+    CALL abort ()
+  END ASSOCIATE myassoc
+
+  ALLOCATE (t :: var)
+  mytypesel: SELECT TYPE (var)
+    TYPE IS (t)
+      EXIT mytypesel
+      CALL abort ()
+    CLASS DEFAULT
+      CALL abort ()
+      EXIT mytypesel
+  END SELECT mytypesel
+
+  ! Check EXIT with nested constructs.
+  outer: BLOCK
+    inner: IF (.TRUE.) THEN
+      EXIT outer
+      CALL abort ()
+    END IF inner
+    CALL abort ()
+  END BLOCK outer
+END PROGRAM main
Index: gcc/testsuite/gfortran.dg/exit_5.f03
===================================================================
--- gcc/testsuite/gfortran.dg/exit_5.f03	(revision 0)
+++ gcc/testsuite/gfortran.dg/exit_5.f03	(revision 0)
@@ -0,0 +1,15 @@ 
+! { dg-do compile }
+! { dg-options "-std=f2003" }
+
+! PR fortran/44602
+! Check for F2008 rejection of non-loop EXIT.
+
+! Contributed by Daniel Kraft, d@domob.eu.
+
+PROGRAM main
+  IMPLICIT NONE
+
+  myname: IF (.TRUE.) THEN
+    EXIT myname ! { dg-error "Fortran 2008" }
+  END IF myname
+END PROGRAM main