From patchwork Mon Aug 30 18:31:03 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Daniel Kraft X-Patchwork-Id: 63121 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 10FBDB6EFF for ; Tue, 31 Aug 2010 04:25:59 +1000 (EST) Received: (qmail 7949 invoked by alias); 30 Aug 2010 18:25:53 -0000 Received: (qmail 7906 invoked by uid 22791); 30 Aug 2010 18:25:50 -0000 X-SWARE-Spam-Status: No, hits=-1.7 required=5.0 tests=AWL, BAYES_20, RCVD_IN_DNSWL_LOW, SPF_HELO_PASS, TW_TM X-Spam-Check-By: sourceware.org Received: from tatiana.utanet.at (HELO tatiana.utanet.at) (213.90.36.46) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Mon, 30 Aug 2010 18:25:42 +0000 Received: from patricia.xoc.tele2net.at ([213.90.36.9]) by tatiana.utanet.at with esmtp (Exim 4.71) (envelope-from ) id 1Oq935-0005bX-6O; Mon, 30 Aug 2010 20:25:39 +0200 Received: from d91-128-23-45.cust.tele2.at ([91.128.23.45] helo=[192.168.1.18]) by patricia.xoc.tele2net.at with esmtpa (Exim 4.71) (envelope-from ) id 1Oq934-0000wA-Ld; Mon, 30 Aug 2010 20:25:39 +0200 Message-ID: <4C7BF8E7.608@domob.eu> Date: Mon, 30 Aug 2010 20:31:03 +0200 From: Daniel Kraft User-Agent: Thunderbird 2.0.0.0 (X11/20070425) MIME-Version: 1.0 To: Fortran List CC: gcc-patches Subject: [Patch, Fortran] RFC: Exit from non-loop constructs Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org 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 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