From 0c3f80cf30365b7ee5b616d609aa7bccf63a4255 Mon Sep 17 00:00:00 2001 From: domob Date: Fri, 3 Sep 2010 08:01:51 +0000 Subject: [PATCH] 2010-09-03 Daniel Kraft 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 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. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@163798 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 17 ++++++ gcc/fortran/gfortran.h | 4 +- gcc/fortran/match.c | 53 ++++++++++++++--- gcc/fortran/parse.c | 7 +++ gcc/fortran/parse.h | 1 + gcc/fortran/resolve.c | 5 +- gcc/fortran/trans-stmt.c | 107 +++++++++++++++++++++++++---------- gcc/testsuite/ChangeLog | 8 +++ gcc/testsuite/gfortran.dg/exit_2.f08 | 6 +- gcc/testsuite/gfortran.dg/exit_3.f08 | 88 ++++++++++++++++++++++++++++ gcc/testsuite/gfortran.dg/exit_4.f08 | 29 ++++++++++ gcc/testsuite/gfortran.dg/exit_5.f03 | 15 +++++ 12 files changed, 296 insertions(+), 44 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/exit_3.f08 create mode 100644 gcc/testsuite/gfortran.dg/exit_4.f08 create mode 100644 gcc/testsuite/gfortran.dg/exit_5.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 477c839..7c75e50 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,20 @@ +2010-09-03 Daniel Kraft + + 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 * trans-intrinsic.c (gfc_conv_intrinsic_aint): Fix whitespace. diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index b23c647..3c15521 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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; } diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 14f2417..ff0ef44 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -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; diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index cbb945a..4632a25 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -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; } diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h index 3fac1c7..b18056c 100644 --- a/gcc/fortran/parse.h +++ b/gcc/fortran/parse.h @@ -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; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 6b922a0..4b6ac1d 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -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) { diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 4c61362..29b3322 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -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; + + /* 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); } @@ -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)); + + /* 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); } @@ -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); } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 34cccd1..015ce4c 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2010-09-03 Daniel Kraft + + 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 * gfortran.dg/ishft_4.f90: New test. diff --git a/gcc/testsuite/gfortran.dg/exit_2.f08 b/gcc/testsuite/gfortran.dg/exit_2.f08 index 23e7009..9b383f0 100644 --- a/gcc/testsuite/gfortran.dg/exit_2.f08 +++ b/gcc/testsuite/gfortran.dg/exit_2.f08 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/exit_3.f08 b/gcc/testsuite/gfortran.dg/exit_3.f08 new file mode 100644 index 0000000..732497b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/exit_3.f08 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/exit_4.f08 b/gcc/testsuite/gfortran.dg/exit_4.f08 new file mode 100644 index 0000000..8033efc --- /dev/null +++ b/gcc/testsuite/gfortran.dg/exit_4.f08 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/exit_5.f03 b/gcc/testsuite/gfortran.dg/exit_5.f03 new file mode 100644 index 0000000..3129b47 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/exit_5.f03 @@ -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 -- 2.7.4