From patchwork Fri Sep 24 21:06:15 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Daniel Kraft X-Patchwork-Id: 65691 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 45CCDB710B for ; Sat, 25 Sep 2010 07:00:52 +1000 (EST) Received: (qmail 15473 invoked by alias); 24 Sep 2010 21:00:50 -0000 Received: (qmail 15454 invoked by uid 22791); 24 Sep 2010 21:00:45 -0000 X-SWARE-Spam-Status: No, hits=-2.5 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_LOW, SPF_HELO_PASS 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; Fri, 24 Sep 2010 21:00:37 +0000 Received: from plenty.xoc.tele2net.at ([213.90.36.8]) by tatiana.utanet.at with esmtp (Exim 4.71) (envelope-from ) id 1OzFNi-0006zQ-FA; Fri, 24 Sep 2010 23:00:34 +0200 Received: from d86-33-93-69.cust.tele2.at ([86.33.93.69] helo=[10.0.0.18]) by plenty.xoc.tele2net.at with esmtpa (Exim 4.71) (envelope-from ) id 1OzFNi-0006Fi-5A; Fri, 24 Sep 2010 23:00:34 +0200 Message-ID: <4C9D12C7.40500@domob.eu> Date: Fri, 24 Sep 2010 23:06:15 +0200 From: Daniel Kraft User-Agent: Thunderbird 2.0.0.0 (X11/20070425) MIME-Version: 1.0 To: Fortran List , gcc-patches Subject: Re: [Patch, Fortran] PR fortran/45776: More variable definition checks References: <4C9CD37E.2020602@domob.eu> In-Reply-To: <4C9CD37E.2020602@domob.eu> 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 Here's an updated patch with the suggestions and IRC discussion incorporated -- earlier than I expected, but anyways ;) What do you think about the new solution? I will run a fresh regtest tomorrow, but at least the io_*, write_*, read_* and namelist_* tests seem to pass. Ok? Yours, Daniel Daniel Kraft wrote: > Hi, > > the attached patch implements the missing IO related variable definition > checks (which is now PR 45776). Except the LOCK/UNLOCK cases which can > not yet be implemented because locks are not yet in gfortran, the full > list of variable definition contexts of F2008, 16.6.7 should be > implemented with that. > > It fixes some accepts-invalid cases that my last patch created, but also > adds some checks that were missing before it. As a bonus, it adds a > F2008 check when using NEWUNIT (which was missing before). > > As I'm not really familiar with the IO related data-structures, I left > two XXX comments in the patch asking for possible better solutions (when > they exist), please take a look at them. > > Regression testing on GNU/Linux-x86-32. Ok for trunk if no failures? Index: gcc/fortran/gfortran.h =================================================================== --- gcc/fortran/gfortran.h (revision 164550) +++ gcc/fortran/gfortran.h (working copy) @@ -1999,7 +1999,7 @@ typedef struct { gfc_expr *io_unit, *format_expr, *rec, *advance, *iostat, *size, *iomsg, *id, *pos, *asynchronous, *blank, *decimal, *delim, *pad, *round, - *sign, *extra_comma; + *sign, *extra_comma, *dt_io_kind; gfc_symbol *namelist; /* A format_label of `format_asterisk' indicates the "*" format */ Index: gcc/fortran/io.c =================================================================== --- gcc/fortran/io.c (revision 164549) +++ gcc/fortran/io.c (working copy) @@ -1505,13 +1505,31 @@ resolve_tag (const io_tag *tag, gfc_expr return FAILURE; } + if (tag == &tag_newunit) + { + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: NEWUNIT specifier" + " at %L", &e->where) == FAILURE) + return FAILURE; + } + + /* NEWUNIT, IOSTAT, SIZE and IOMSG are variable definition contexts. */ + if (tag == &tag_newunit || tag == &tag_iostat + || tag == &tag_size || tag == &tag_iomsg) + { + char context[64]; + + sprintf (context, _("%s tag"), tag->name); + if (gfc_check_vardef_context (e, false, context) == FAILURE) + return FAILURE; + } + if (tag == &tag_convert) { if (gfc_notify_std (GFC_STD_GNU, "Extension: CONVERT tag at %L", &e->where) == FAILURE) return FAILURE; } - + return SUCCESS; } @@ -2707,8 +2725,9 @@ gfc_free_dt (gfc_dt *dt) gfc_free_expr (dt->round); gfc_free_expr (dt->blank); gfc_free_expr (dt->decimal); - gfc_free_expr (dt->extra_comma); gfc_free_expr (dt->pos); + gfc_free_expr (dt->dt_io_kind); + /* dt->extra_comma is a link to dt_io_kind if it is set. */ gfc_free (dt); } @@ -2719,6 +2738,11 @@ gfc_try gfc_resolve_dt (gfc_dt *dt, locus *loc) { gfc_expr *e; + io_kind k; + + /* This is set in any case. */ + gcc_assert (dt->dt_io_kind); + k = dt->dt_io_kind->value.iokind; RESOLVE_TAG (&tag_format, dt->format_expr); RESOLVE_TAG (&tag_rec, dt->rec); @@ -2761,16 +2785,13 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc) type character, we assume its really the "format" form of the I/O statement. We set the io_unit to the default unit and format to the character expression. See F95 Standard section 9.4. */ - io_kind k; - k = dt->extra_comma->value.iokind; if (e->ts.type == BT_CHARACTER && (k == M_READ || k == M_PRINT)) { dt->format_expr = dt->io_unit; dt->io_unit = default_unit (k); - /* Free this pointer now so that a warning/error is not triggered - below for the "Extension". */ - gfc_free_expr (dt->extra_comma); + /* Nullify this pointer now so that a warning/error is not + triggered below for the "Extension". */ dt->extra_comma = NULL; } @@ -2790,6 +2811,13 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc) gfc_error ("Internal unit with vector subscript at %L", &e->where); return FAILURE; } + + /* If we are writing, make sure the internal unit can be changed. */ + gcc_assert (k != M_PRINT); + if (k == M_WRITE + && gfc_check_vardef_context (e, false, _("internal unit in WRITE")) + == FAILURE) + return FAILURE; } if (e->rank && e->ts.type != BT_CHARACTER) @@ -2801,10 +2829,36 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc) if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_INTEGER && mpz_sgn (e->value.integer) < 0) { - gfc_error ("UNIT number in statement at %L must be non-negative", &e->where); + gfc_error ("UNIT number in statement at %L must be non-negative", + &e->where); return FAILURE; } + /* If we are reading and have a namelist, check that all namelist symbols + can appear in a variable definition context. */ + if (k == M_READ && dt->namelist) + { + gfc_namelist* n; + for (n = dt->namelist->namelist; n; n = n->next) + { + gfc_expr* e; + gfc_try t; + + e = gfc_get_variable_expr (gfc_find_sym_in_symtree (n->sym)); + t = gfc_check_vardef_context (e, false, NULL); + gfc_free_expr (e); + + if (t == FAILURE) + { + gfc_error ("NAMELIST '%s' in READ statement at %L contains" + " the symbol '%s' which may not appear in a" + " variable definition context", + dt->namelist->name, loc, n->sym->name); + return FAILURE; + } + } + } + if (dt->extra_comma && gfc_notify_std (GFC_STD_GNU, "Extension: Comma before i/o " "item list at %L", &dt->extra_comma->where) == FAILURE) @@ -2854,6 +2908,7 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc) &dt->format_label->where); return FAILURE; } + return SUCCESS; } @@ -3012,50 +3067,8 @@ match_io_element (io_kind k, gfc_code ** io_kind_name (k)); } - if (m == MATCH_YES) - switch (k) - { - case M_READ: - if (expr->symtree->n.sym->attr.intent == INTENT_IN) - { - gfc_error ("Variable '%s' in input list at %C cannot be " - "INTENT(IN)", expr->symtree->n.sym->name); - m = MATCH_ERROR; - } - - if (gfc_pure (NULL) - && gfc_impure_variable (expr->symtree->n.sym) - && current_dt->io_unit - && current_dt->io_unit->ts.type == BT_CHARACTER) - { - gfc_error ("Cannot read to variable '%s' in PURE procedure at %C", - expr->symtree->n.sym->name); - m = MATCH_ERROR; - } - - if (gfc_check_do_variable (expr->symtree)) - m = MATCH_ERROR; - - break; - - case M_WRITE: - if (current_dt->io_unit - && current_dt->io_unit->ts.type == BT_CHARACTER - && gfc_pure (NULL) - && current_dt->io_unit->expr_type == EXPR_VARIABLE - && gfc_impure_variable (current_dt->io_unit->symtree->n.sym)) - { - gfc_error ("Cannot write to internal file unit '%s' at %C " - "inside a PURE procedure", - current_dt->io_unit->symtree->n.sym->name); - m = MATCH_ERROR; - } - - break; - - default: - break; - } + if (m == MATCH_YES && k == M_READ && gfc_check_do_variable (expr->symtree)) + m = MATCH_ERROR; if (m != MATCH_YES) { @@ -3066,6 +3079,7 @@ match_io_element (io_kind k, gfc_code ** cp = gfc_get_code (); cp->op = EXEC_TRANSFER; cp->expr1 = expr; + cp->ext.dt = current_dt; *cpp = cp; return MATCH_YES; @@ -3657,14 +3671,14 @@ get_io_list: /* Used in check_io_constraints, where no locus is available. */ spec_end = gfc_current_locus; + /* Save the IO kind for later use. */ + dt->dt_io_kind = gfc_get_iokind_expr (&gfc_current_locus, k); + /* Optional leading comma (non-standard). We use a gfc_expr structure here to save the locus. This is used later when resolving transfer statements that might have a format expression without unit number. */ if (!comma_flag && gfc_match_char (',') == MATCH_YES) - { - /* Save the iokind and locus for later use in resolution. */ - dt->extra_comma = gfc_get_iokind_expr (&gfc_current_locus, k); - } + dt->extra_comma = dt->dt_io_kind; io_code = NULL; if (gfc_match_eos () != MATCH_YES) @@ -3973,41 +3987,54 @@ gfc_resolve_inquire (gfc_inquire *inquir { RESOLVE_TAG (&tag_unit, inquire->unit); RESOLVE_TAG (&tag_file, inquire->file); - RESOLVE_TAG (&tag_iomsg, inquire->iomsg); - RESOLVE_TAG (&tag_iostat, inquire->iostat); - RESOLVE_TAG (&tag_exist, inquire->exist); - RESOLVE_TAG (&tag_opened, inquire->opened); - RESOLVE_TAG (&tag_number, inquire->number); - RESOLVE_TAG (&tag_named, inquire->named); - RESOLVE_TAG (&tag_name, inquire->name); - RESOLVE_TAG (&tag_s_access, inquire->access); - RESOLVE_TAG (&tag_sequential, inquire->sequential); - RESOLVE_TAG (&tag_direct, inquire->direct); - RESOLVE_TAG (&tag_s_form, inquire->form); - RESOLVE_TAG (&tag_formatted, inquire->formatted); - RESOLVE_TAG (&tag_unformatted, inquire->unformatted); - RESOLVE_TAG (&tag_s_recl, inquire->recl); - RESOLVE_TAG (&tag_nextrec, inquire->nextrec); - RESOLVE_TAG (&tag_s_blank, inquire->blank); - RESOLVE_TAG (&tag_s_position, inquire->position); - RESOLVE_TAG (&tag_s_action, inquire->action); - RESOLVE_TAG (&tag_read, inquire->read); - RESOLVE_TAG (&tag_write, inquire->write); - RESOLVE_TAG (&tag_readwrite, inquire->readwrite); - RESOLVE_TAG (&tag_s_delim, inquire->delim); - RESOLVE_TAG (&tag_s_pad, inquire->pad); - RESOLVE_TAG (&tag_s_encoding, inquire->encoding); - RESOLVE_TAG (&tag_s_round, inquire->round); - RESOLVE_TAG (&tag_iolength, inquire->iolength); - RESOLVE_TAG (&tag_convert, inquire->convert); - RESOLVE_TAG (&tag_strm_out, inquire->strm_pos); - RESOLVE_TAG (&tag_s_async, inquire->asynchronous); - RESOLVE_TAG (&tag_s_sign, inquire->sign); - RESOLVE_TAG (&tag_s_round, inquire->round); - RESOLVE_TAG (&tag_pending, inquire->pending); - RESOLVE_TAG (&tag_size, inquire->size); RESOLVE_TAG (&tag_id, inquire->id); + /* For INQUIRE, all tags except FILE, ID and UNIT are variable definition + contexts. Thus, use an extended RESOLVE_TAG macro for that. */ +#define INQUIRE_RESOLVE_TAG(tag, expr) \ + RESOLVE_TAG (tag, expr); \ + if (expr) \ + { \ + char context[64]; \ + sprintf (context, _("%s tag with INQUIRE"), (tag)->name); \ + if (gfc_check_vardef_context ((expr), false, context) == FAILURE) \ + return FAILURE; \ + } + INQUIRE_RESOLVE_TAG (&tag_iomsg, inquire->iomsg); + INQUIRE_RESOLVE_TAG (&tag_iostat, inquire->iostat); + INQUIRE_RESOLVE_TAG (&tag_exist, inquire->exist); + INQUIRE_RESOLVE_TAG (&tag_opened, inquire->opened); + INQUIRE_RESOLVE_TAG (&tag_number, inquire->number); + INQUIRE_RESOLVE_TAG (&tag_named, inquire->named); + INQUIRE_RESOLVE_TAG (&tag_name, inquire->name); + INQUIRE_RESOLVE_TAG (&tag_s_access, inquire->access); + INQUIRE_RESOLVE_TAG (&tag_sequential, inquire->sequential); + INQUIRE_RESOLVE_TAG (&tag_direct, inquire->direct); + INQUIRE_RESOLVE_TAG (&tag_s_form, inquire->form); + INQUIRE_RESOLVE_TAG (&tag_formatted, inquire->formatted); + INQUIRE_RESOLVE_TAG (&tag_unformatted, inquire->unformatted); + INQUIRE_RESOLVE_TAG (&tag_s_recl, inquire->recl); + INQUIRE_RESOLVE_TAG (&tag_nextrec, inquire->nextrec); + INQUIRE_RESOLVE_TAG (&tag_s_blank, inquire->blank); + INQUIRE_RESOLVE_TAG (&tag_s_position, inquire->position); + INQUIRE_RESOLVE_TAG (&tag_s_action, inquire->action); + INQUIRE_RESOLVE_TAG (&tag_read, inquire->read); + INQUIRE_RESOLVE_TAG (&tag_write, inquire->write); + INQUIRE_RESOLVE_TAG (&tag_readwrite, inquire->readwrite); + INQUIRE_RESOLVE_TAG (&tag_s_delim, inquire->delim); + INQUIRE_RESOLVE_TAG (&tag_s_pad, inquire->pad); + INQUIRE_RESOLVE_TAG (&tag_s_encoding, inquire->encoding); + INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round); + INQUIRE_RESOLVE_TAG (&tag_iolength, inquire->iolength); + INQUIRE_RESOLVE_TAG (&tag_convert, inquire->convert); + INQUIRE_RESOLVE_TAG (&tag_strm_out, inquire->strm_pos); + INQUIRE_RESOLVE_TAG (&tag_s_async, inquire->asynchronous); + INQUIRE_RESOLVE_TAG (&tag_s_sign, inquire->sign); + INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round); + INQUIRE_RESOLVE_TAG (&tag_pending, inquire->pending); + INQUIRE_RESOLVE_TAG (&tag_size, inquire->size); +#undef INQUIRE_RESOLVE_TAG + if (gfc_reference_st_label (inquire->err, ST_LABEL_TARGET) == FAILURE) return FAILURE; Index: gcc/fortran/resolve.c =================================================================== --- gcc/fortran/resolve.c (revision 164550) +++ gcc/fortran/resolve.c (working copy) @@ -7916,6 +7916,11 @@ resolve_transfer (gfc_code *code) && exp->expr_type != EXPR_FUNCTION)) return; + /* If we are reading, the variable will be changed. */ + if (code->ext.dt->dt_io_kind->value.iokind == M_READ + && gfc_check_vardef_context (exp, false, _("item in READ")) == FAILURE) + return; + sym = exp->symtree->n.sym; ts = &sym->ts; Index: gcc/testsuite/gfortran.dg/io_constraints_7.f03 =================================================================== --- gcc/testsuite/gfortran.dg/io_constraints_7.f03 (revision 0) +++ gcc/testsuite/gfortran.dg/io_constraints_7.f03 (revision 0) @@ -0,0 +1,37 @@ +! { dg-do compile } + +! PR fortran/45776 +! Variable definition context checks related to IO. + +! Contributed by Daniel Kraft, d@domob.eu. + +module m + implicit none + integer, protected :: a + character(len=128), protected :: msg +end module m + +program main + use :: m + integer :: x + logical :: bool + + write (*, iostat=a) 42 ! { dg-error "variable definition context" } + write (*, iomsg=msg) 42 ! { dg-error "variable definition context" } + read (*, '(I2)', advance='no', size=a) x ! { dg-error "variable definition context" } + + ! These are ok. + inquire (unit=a) + inquire (file=msg, id=a, pending=bool) + inquire (file=msg) + + ! These not, but list is not extensive. + inquire (unit=1, number=a) ! { dg-error "variable definition context" } + inquire (unit=1, encoding=msg) ! { dg-error "variable definition context" } + inquire (unit=1, formatted=msg) ! { dg-error "variable definition context" } + + open (newunit=a, file="foo") ! { dg-error "variable definition context" } + close (unit=a) +end program main + +! { dg-final { cleanup-modules "m" } } Index: gcc/testsuite/gfortran.dg/newunit_2.f90 =================================================================== --- gcc/testsuite/gfortran.dg/newunit_2.f90 (revision 0) +++ gcc/testsuite/gfortran.dg/newunit_2.f90 (revision 0) @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-std=f95" } + +! PR40008 F2008: Add NEWUNIT= for OPEN statement +! Check for rejection with pre-F2008 standard. + +! Contributed by Daniel Kraft, d@domob.eu. + +program main + character(len=25) :: str + integer(1) :: myunit + + open (newunit=myunit, file="some_file") ! { dg-error "Fortran 2008" } + close (unit=myunit) +end program main Index: gcc/testsuite/gfortran.dg/io_constraints_6.f03 =================================================================== --- gcc/testsuite/gfortran.dg/io_constraints_6.f03 (revision 0) +++ gcc/testsuite/gfortran.dg/io_constraints_6.f03 (revision 0) @@ -0,0 +1,40 @@ +! { dg-do compile } + +! PR fortran/45776 +! Variable definition context checks related to IO. + +! Contributed by Daniel Kraft, d@domob.eu. + +module m + implicit none + + integer, protected :: a + character(len=128), protected :: str +end module m + +program main + use :: m + integer, parameter :: b = 42 + integer :: x + character(len=128) :: myStr + + namelist /definable/ x, myStr + namelist /undefinable/ x, a + + ! These are invalid. + read (myStr, *) a ! { dg-error "variable definition context" } + read (myStr, *) x, b ! { dg-error "variable definition context" } + write (str, *) 5 ! { dg-error "variable definition context" } + read (*, nml=undefinable) ! { dg-error "contains the symbol 'a' which may not" } + + ! These are ok. + read (str, *) x + write (myStr, *) a + write (myStr, *) b + print *, a, b + write (*, nml=undefinable) + read (*, nml=definable) + write (*, nml=definable) +end program main + +! { dg-final { cleanup-modules "m" } }