From 8e8dc0603560c94f84c0061f3040d8f2654f8036 Mon Sep 17 00:00:00 2001 From: Daniel Kraft Date: Sat, 25 Sep 2010 16:27:20 +0200 Subject: [PATCH] re PR fortran/45776 (Full implementation of variable definition contexts (and related checks)) 2010-09-25 Daniel Kraft PR fortran/45776 * gfortran.h (struct gfc_dt): New member `dt_io_kind'. * io.c (resolve_tag): F2008 check for NEWUNIT and variable definition checks for NEWUNIT, IOSTAT, SIZE and IOMSG. (gfc_free_dt): Correctly handle freeing of `dt_io_kind' and `extra_comma' with changed semantics. (gfc_resolve_dt): Check variable definitions. (match_io_element): Remove INTENT and PURE checks here and initialize code->ext.dt member. (match_io): Set dt->dt_io_kind. (gfc_resolve_inquire): Check variable definition for all tags except UNIT, FILE and ID. * resolve.c (resolve_transfer): Variable definition check. 2010-09-25 Daniel Kraft PR fortran/45776 * gfortran.dg/io_constraints_6.f03: New test. * gfortran.dg/io_constraints_7.f03: New test. * gfortran.dg/newunit_2.f90: New test. From-SVN: r164619 --- gcc/fortran/ChangeLog | 16 ++ gcc/fortran/gfortran.h | 2 +- gcc/fortran/io.c | 205 ++++++++++-------- gcc/fortran/resolve.c | 7 + gcc/testsuite/ChangeLog | 7 + .../gfortran.dg/io_constraints_6.f03 | 40 ++++ .../gfortran.dg/io_constraints_7.f03 | 37 ++++ gcc/testsuite/gfortran.dg/newunit_2.f90 | 15 ++ 8 files changed, 239 insertions(+), 90 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/io_constraints_6.f03 create mode 100644 gcc/testsuite/gfortran.dg/io_constraints_7.f03 create mode 100644 gcc/testsuite/gfortran.dg/newunit_2.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 5df77bf70f9..40b472080cc 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,19 @@ +2010-09-25 Daniel Kraft + + PR fortran/45776 + * gfortran.h (struct gfc_dt): New member `dt_io_kind'. + * io.c (resolve_tag): F2008 check for NEWUNIT and variable + definition checks for NEWUNIT, IOSTAT, SIZE and IOMSG. + (gfc_free_dt): Correctly handle freeing of `dt_io_kind' and + `extra_comma' with changed semantics. + (gfc_resolve_dt): Check variable definitions. + (match_io_element): Remove INTENT and PURE checks here and + initialize code->ext.dt member. + (match_io): Set dt->dt_io_kind. + (gfc_resolve_inquire): Check variable definition for all tags + except UNIT, FILE and ID. + * resolve.c (resolve_transfer): Variable definition check. + 2010-09-25 Tobias Burnus * interface.c (gfc_match_end_interface): Constify char pointer diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 95886cd2c9a..b9c79f26878 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2000,7 +2000,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 */ diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c index afbde0210b4..e80202fab06 100644 --- a/gcc/fortran/io.c +++ b/gcc/fortran/io.c @@ -1505,13 +1505,31 @@ resolve_tag (const io_tag *tag, gfc_expr *e) 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 **cpp) 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 **cpp) 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 *inquire) { 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; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 30ca7ce2181..0dce3f86b18 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -7916,6 +7916,13 @@ resolve_transfer (gfc_code *code) && exp->expr_type != EXPR_FUNCTION)) return; + /* If we are reading, the variable will be changed. Note that + code->ext.dt may be NULL if the TRANSFER is related to + an INQUIRE statement -- but in this case, we are not reading, either. */ + if (code->ext.dt && 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; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 3815b943618..6a65c793d11 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2010-09-25 Daniel Kraft + + PR fortran/45776 + * gfortran.dg/io_constraints_6.f03: New test. + * gfortran.dg/io_constraints_7.f03: New test. + * gfortran.dg/newunit_2.f90: New test. + 2010-09-24 Steven G. Kargl < kargl@gcc.gnu.org> * testsuite/gfortran.dg/operator_c1202.f90: New test. diff --git a/gcc/testsuite/gfortran.dg/io_constraints_6.f03 b/gcc/testsuite/gfortran.dg/io_constraints_6.f03 new file mode 100644 index 00000000000..d0484f5f4fe --- /dev/null +++ b/gcc/testsuite/gfortran.dg/io_constraints_6.f03 @@ -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" } } diff --git a/gcc/testsuite/gfortran.dg/io_constraints_7.f03 b/gcc/testsuite/gfortran.dg/io_constraints_7.f03 new file mode 100644 index 00000000000..4d184919814 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/io_constraints_7.f03 @@ -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" } } diff --git a/gcc/testsuite/gfortran.dg/newunit_2.f90 b/gcc/testsuite/gfortran.dg/newunit_2.f90 new file mode 100644 index 00000000000..b0f797a0736 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/newunit_2.f90 @@ -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 -- 2.30.2