===================================================================
@@ -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;
}
===================================================================
@@ -734,7 +734,8 @@ gfc_trans_if_1 (gfc_code * code)
elsestmt = build_empty_stmt (input_location);
/* Build the condition expression and add it to the condition block. */
- stmt = fold_build3 (COND_EXPR, void_type_node, if_se.expr, stmt, elsestmt);
+ stmt = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ if_se.expr, stmt, elsestmt);
gfc_add_expr_to_block (&if_se.pre, stmt);
@@ -745,10 +746,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 +862,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 +950,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 +1128,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 +1223,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 +1325,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 +1964,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 +4271,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 +4288,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);
}
===================================================================
@@ -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)
{
===================================================================
@@ -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,55 @@ 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_CYCLE)
+ {
+ gfc_error ("CYCLE statement at %C is not applicable to non-loop"
+ " construct '%s'", sym->name);
+ return MATCH_ERROR;
+ }
+ gcc_assert (op == EXEC_EXIT);
+ if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: EXIT statement with no"
+ " do-construct-name at %C") == FAILURE)
+ return MATCH_ERROR;
+ break;
+
+ default:
+ 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 +2130,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;
===================================================================
@@ -989,6 +989,13 @@ 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. */
+ gcc_assert (gfc_state_stack);
+ p->construct = gfc_state_stack->tail;
+
gfc_state_stack = p;
}
===================================================================
@@ -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;
===================================================================
@@ -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
===================================================================
@@ -0,0 +1,29 @@
+! { 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
+ INTEGER :: bar(2)
+
+ ! 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 non-loop construct 'myblock'" }
+ END BLOCK myblock
+
+ ! Invalid construct.
+ ! Thanks to Mikael Morin, mikael.morin@sfr.fr.
+ baz: WHERE ([ .true., .true. ])
+ bar = 0
+ EXIT baz ! { dg-error "is not applicable to construct 'baz'" }
+ END WHERE baz
+END PROGRAM main
===================================================================
@@ -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
===================================================================
@@ -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