+2010-09-03 Daniel Kraft <d@domob.eu>
+
+ PR fortran/44602
+ * gfortran.h (struct gfc_code): Renamed `whichloop' to
+ `which_construct' as this is no longer restricted to loops.
+ * parse.h (struct gfc_state_data): New field `construct'.
+ * match.c (match_exit_cycle): Handle EXIT from non-loops.
+ * parse.c (push_state): Set `construct' field.
+ * resolve.c (resolve_select_type): Extend comment.
+ * trans-stmt.c (gfc_trans_if): Add exit label.
+ (gfc_trans_block_construct), (gfc_trans_select): Ditto.
+ (gfc_trans_simple_do): Store exit/cycle labels on the gfc_code itself.
+ (gfc_trans_do), (gfc_trans_do_while): Ditto.
+ (gfc_trans_exit): Use new name `which_construct' instead of `whichloop'.
+ (gfc_trans_cycle): Ditto.
+ (gfc_trans_if_1): Use fold_build3_loc instead of fold_build3.
+
2010-09-03 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
* trans-intrinsic.c (gfc_conv_intrinsic_aint): Fix whitespace.
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;
}
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;
}
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;
}
/* 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)
{
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",
}
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;
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;
}
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;
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)
{
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;
+
+ /* 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_trans_if_1 (code->block);
+ return gfc_finish_block (&body);
}
{
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);
}
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);
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);
/* 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);
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);
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);
}
{
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);
}
{
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);
}
+2010-09-03 Daniel Kraft <d@domob.eu>
+
+ PR fortran/44602
+ * gfortran.dg/exit_2.f08; Adapt error messages.
+ * gfortran.dg/exit_3.f08: New test.
+ * gfortran.dg/exit_4.f08: New test.
+ * gfortran.dg/exit_5.f03: New test.
+
2010-09-03 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
* gfortran.dg/ishft_4.f90: New test.
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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
projects / platform / upstream / linaro-gcc.git / commitdiff