Patchwork [Fortran] RFC: Exit from non-loop constructs

login
register
mail settings
Submitter Daniel Kraft
Date Aug. 30, 2010, 6:31 p.m.
Message ID <4C7BF8E7.608@domob.eu>
Download mbox | patch
Permalink /patch/63121/
State New
Headers show

Comments

Daniel Kraft - Aug. 30, 2010, 6:31 p.m.
Hi,

the attached patch implements the Fortran 2008 feature of EXITs from 
non-loop named constructs (like IF or BLOCK).  It seems to work 
basically, but I'd like to get some input.

In particular, the two things marked XXX in the patch -- what do you 
think about those?  (Both things are basically "boolean":  I see two 
possible approaches, and just need to find out which one is the "correct".)

This patch regtests nearly fine on GNU/Linux-x86-32, but float128_1.f90 
fails ("Kind 16 not supported.") -- I've no idea what's going wrong 
there on my system, but it is probably not related.

However, I also see a failure for gfortran.dg/gomp/pr41344.f:  It seems 
to be that the error that is expected on line 10 appears on line 7 
instead.  This is probably caused by my patch, although I have no idea 
what the problem could be...  Any ideas?  As this seems to be a 
middle-end error, I'm particular at a loss.  Maybe I can work this out 
tomorrow myself, but I'd appreciate any thoughts.

I'm not asking for review yet, but will resubmit a new patch when the 
issues mentioned above are cleared.

Yours,
Daniel
Mikael Morin - Aug. 31, 2010, 12:42 p.m.
Le 30.08.2010 20:31, Daniel Kraft a écrit :
> Hi,
>
> the attached patch implements the Fortran 2008 feature of EXITs from
> non-loop named constructs (like IF or BLOCK). It seems to work
> basically, but I'd like to get some input.
>
> In particular, the two things marked XXX in the patch -- what do you
> think about those? (Both things are basically "boolean": I see two
> possible approaches, and just need to find out which one is the "correct".)
See below
>
> This patch regtests nearly fine on GNU/Linux-x86-32, but float128_1.f90
> fails ("Kind 16 not supported.") -- I've no idea what's going wrong
> there on my system, but it is probably not related.
Same here
>
> However, I also see a failure for gfortran.dg/gomp/pr41344.f: It seems
> to be that the error that is expected on line 10 appears on line 7
> instead. This is probably caused by my patch, although I have no idea
> what the problem could be... Any ideas? As this seems to be a middle-end
> error, I'm particular at a loss. Maybe I can work this out tomorrow
> myself, but I'd appreciate any thoughts.
I've looked at it and can't make any sense of it either.
The if clause has the wrong location at the gimple level, but setting 
the input_location to code->loc at trans stage doesn't help.

>
> I'm not asking for review yet, but will resubmit a new patch when the
> issues mentioned above are cleared.
>
> Yours,
> Daniel
>

> 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);
This is for cycle statement, right ?
I would explicitly assert op == EXEC_CYCLE and explain why it is not 
applicable (construct is not a loop).
Something like:
... not applicable to non-loop construct '%s'
> +	  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?  */
I think this is unreachable, but I can't tell for sure.
Anyway let's keep an error as it is safer.

       program main

           implicit none

           integer :: foo
           integer :: bar(2)

           baz: where ([ .true., .true. ])
             bar = 0
             exit baz
           end where baz

       end program

I can trigger the error with the program above, so it is not unreachable 
after all.
Even without this error, the offending line is rejected later anyway.


> +      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.  */
gfc_parse_file has at the very beginning :
   gfc_state_stack = &top;

So I think that it is indeed guaranteed to be non-null.
> +  gcc_assert (gfc_state_stack);
> +  p->construct = gfc_state_stack->tail;
> +
>    gfc_state_stack = p;
>  }
>

Patch

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