procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR fortran/44602 ([F2008] EXIT: Jump to end of construct)

Browse source 
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  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.

From-SVN: r163798
This commit is contained in:
Daniel Kraft 2010-09-03 10:01:51 +02:00 • committed by Daniel Kraft
parent e97e08bc2e
commit e5ca969363
12 changed files with 296 additions and 44 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

17
gcc/fortran/ChangeLog
View file

@ -1,3 +1,20 @@
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.

4
gcc/fortran/gfortran.h
View file

@ -2096,7 +2096,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;
@ -2106,7 +2106,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;
}

53
gcc/fortran/match.c
View file

@ -2034,7 +2034,7 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op)
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_exec_op op)
/* 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_exec_op op)
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_exec_op op)
}
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;

7
gcc/fortran/parse.c
View file

@ -989,6 +989,13 @@ push_state (gfc_state_data *p, gfc_compile_state new_state, gfc_symbol *sym)
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;
}

1
gcc/fortran/parse.h
View file

@ -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;

5
gcc/fortran/resolve.c
View file

@ -7688,7 +7688,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)
{

107
gcc/fortran/trans-stmt.c
View file

@ -750,10 +750,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);
}
@ -860,22 +871,32 @@ gfc_trans_block_construct (gfc_code* code)
{
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));
return gfc_finish_wrapped_block (&body);
/* Finish everything. */
gfc_start_wrapped_block (&block, gfc_finish_block (&body));
gfc_trans_deferred_vars (sym, &block);
return gfc_finish_wrapped_block (&block);
}
@ -938,8 +959,8 @@ gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
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);
@ -1121,6 +1142,10 @@ gfc_trans_do (gfc_code * code, tree exit_cond)
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);
@ -1222,11 +1247,6 @@ gfc_trans_do (gfc_code * code, tree exit_cond)
/* 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);
@ -1332,8 +1352,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);
@ -1973,22 +1993,47 @@ gfc_trans_character_select (gfc_code *code)
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);
}
@ -4271,7 +4316,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);
}
@ -4286,7 +4333,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);
}

8
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,11 @@
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.

6
gcc/testsuite/gfortran.dg/exit_2.f08
View file

@ -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

88
gcc/testsuite/gfortran.dg/exit_3.f08 Normal file
View file

@ -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

29
gcc/testsuite/gfortran.dg/exit_4.f08 Normal file
View file

@ -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

15
gcc/testsuite/gfortran.dg/exit_5.f03 Normal file
View file

@ -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