From patchwork Fri Sep 24 16:36:14 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Daniel Kraft X-Patchwork-Id: 65661 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 36BCDB711B for ; Sat, 25 Sep 2010 02:31:08 +1000 (EST) Received: (qmail 27984 invoked by alias); 24 Sep 2010 16:30:55 -0000 Received: (qmail 27837 invoked by uid 22791); 24 Sep 2010 16:30:44 -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 taro.utanet.at (HELO taro.utanet.at) (213.90.36.45) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Fri, 24 Sep 2010 16:30:34 +0000 Received: from patricia.xoc.tele2net.at ([213.90.36.9]) by taro.utanet.at with esmtp (Exim 4.71) (envelope-from ) id 1OzBAN-00062d-I7; Fri, 24 Sep 2010 18:30:31 +0200 Received: from d86-33-93-69.cust.tele2.at ([86.33.93.69] helo=[10.0.0.18]) by patricia.xoc.tele2net.at with esmtpa (Exim 4.71) (envelope-from ) id 1OzBAN-0003ho-AZ; Fri, 24 Sep 2010 18:30:31 +0200 Message-ID: <4C9CD37E.2020602@domob.eu> Date: Fri, 24 Sep 2010 18:36:14 +0200 From: Daniel Kraft User-Agent: Thunderbird 2.0.0.0 (X11/20070425) MIME-Version: 1.0 To: Fortran List , gcc-patches Subject: [Patch, Fortran] PR fortran/45776: More variable definition checks 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 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? Thanks, Daniel Index: gcc/fortran/gfortran.h =================================================================== --- gcc/fortran/gfortran.h (revision 164550) +++ gcc/fortran/gfortran.h (working copy) @@ -2111,6 +2111,13 @@ typedef struct gfc_code gfc_inquire *inquire; gfc_wait *wait; gfc_dt *dt; + + /* For transfer, store whether this is reading or writing. */ + /* XXX: Can we in some other way determine in resolve_transfer whether + we are reading or writing? Possibly via global variables, but that + does not feel right. */ + io_kind transfer_io_kind; + gfc_forall_iterator *forall_iterator; struct gfc_code *which_construct; int stop_code; @@ -2827,7 +2834,7 @@ gfc_try gfc_resolve_filepos (gfc_filepos void gfc_free_inquire (gfc_inquire *); gfc_try gfc_resolve_inquire (gfc_inquire *); void gfc_free_dt (gfc_dt *); -gfc_try gfc_resolve_dt (gfc_dt *, locus *); +gfc_try gfc_resolve_dt (gfc_dt *, locus *, gfc_exec_op); void gfc_free_wait (gfc_wait *); gfc_try gfc_resolve_wait (gfc_wait *); 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; } @@ -2716,10 +2734,16 @@ gfc_free_dt (gfc_dt *dt) /* Resolve everything in a gfc_dt structure. */ gfc_try -gfc_resolve_dt (gfc_dt *dt, locus *loc) +gfc_resolve_dt (gfc_dt *dt, locus *loc, gfc_exec_op op) { gfc_expr *e; + /* XXX: Is there a way to get whether we are READing or WRITing without + this new extra argument? Note that below there is code doing something + like that based on extra_comma, but it does not really look like + a general method to me. What if extra_comma is not present? */ + gcc_assert (op == EXEC_READ || op == EXEC_WRITE); + RESOLVE_TAG (&tag_format, dt->format_expr); RESOLVE_TAG (&tag_rec, dt->rec); RESOLVE_TAG (&tag_spos, dt->pos); @@ -2790,6 +2814,12 @@ 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. */ + if (op == EXEC_WRITE + && gfc_check_vardef_context (e, false, _("internal unit in WRITE")) + == FAILURE) + return FAILURE; } if (e->rank && e->ts.type != BT_CHARACTER) @@ -2801,10 +2831,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 (op == EXEC_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 +2910,7 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc) &dt->format_label->where); return FAILURE; } + return SUCCESS; } @@ -3012,50 +3069,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 +3081,7 @@ match_io_element (io_kind k, gfc_code ** cp = gfc_get_code (); cp->op = EXEC_TRANSFER; cp->expr1 = expr; + cp->ext.transfer_io_kind = k; *cpp = cp; return MATCH_YES; @@ -3973,41 +3989,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.transfer_io_kind == M_READ + && gfc_check_vardef_context (exp, false, _("item in READ")) == FAILURE) + return; + sym = exp->symtree->n.sym; ts = &sym->ts; @@ -9059,7 +9064,7 @@ resolve_code (gfc_code *code, gfc_namesp case EXEC_READ: case EXEC_WRITE: - if (gfc_resolve_dt (code->ext.dt, &code->loc) == FAILURE) + if (gfc_resolve_dt (code->ext.dt, &code->loc, code->op) == FAILURE) break; resolve_branch (code->ext.dt->err, code); 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" } }