From 82b12af70c15f25bf9c1d3b761069473ee169888 Mon Sep 17 00:00:00 2001 From: jvdelisle Date: Sun, 7 Jun 2009 18:57:43 +0000 Subject: [PATCH] 2009-05-31 Jerry DeLisle PR fortran/40008 * gfortran.h (gfc_open): Add newunit expression to structure. * io.c (io_tag): Add new unit tag and fix whitespace. (match_open_element): Add matching for newunit. (gfc_free_open): Free the newunit expression. (gfc_resolve_open): Add newunit to resolution and check constraints. (gfc_resolve_close): Add check for non-negative unit. (gfc_resolve_filepos): Likewise. (gfc_resolve_dt): Likewise. * trans-io.c (set_parameter_value): Build runtime checks for unit numbers within range of kind=4 integer. (gfc_trans_open) Set the newunit parameter. * ioparm.def (IOPARM): Define the newunit parameter as a pointer to GFC_INTEGER_4, pint4. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@148252 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 17 ++++++++++++++++ gcc/fortran/gfortran.h | 2 +- gcc/fortran/io.c | 54 +++++++++++++++++++++++++++++++++++++++++++++++--- gcc/fortran/ioparm.def | 1 + gcc/fortran/trans-io.c | 21 ++++++++++++-------- 5 files changed, 83 insertions(+), 12 deletions(-) diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 0a737bf..14cef2b 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,20 @@ +2009-05-31 Jerry DeLisle + + PR fortran/40008 + * gfortran.h (gfc_open): Add newunit expression to structure. + * io.c (io_tag): Add new unit tag and fix whitespace. + (match_open_element): Add matching for newunit. + (gfc_free_open): Free the newunit expression. + (gfc_resolve_open): Add newunit to resolution and check constraints. + (gfc_resolve_close): Add check for non-negative unit. + (gfc_resolve_filepos): Likewise. + (gfc_resolve_dt): Likewise. + * trans-io.c (set_parameter_value): Build runtime checks for unit + numbers within range of kind=4 integer. (gfc_trans_open) Set the + newunit parameter. + * ioparm.def (IOPARM): Define the newunit parameter as a pointer + to GFC_INTEGER_4, pint4. + 2009-06-07 Daniel Franke PR fortran/25104 diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 9027904..c8347d0 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1818,7 +1818,7 @@ typedef struct { gfc_expr *unit, *file, *status, *access, *form, *recl, *blank, *position, *action, *delim, *pad, *iostat, *iomsg, *convert, - *decimal, *encoding, *round, *sign, *asynchronous, *id; + *decimal, *encoding, *round, *sign, *asynchronous, *id, *newunit; gfc_st_label *err; } gfc_open; diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c index c902257..ea56292 100644 --- a/gcc/fortran/io.c +++ b/gcc/fortran/io.c @@ -38,8 +38,8 @@ typedef struct io_tag; static const io_tag - tag_file = { "FILE", " file =", " %e", BT_CHARACTER }, - tag_status = { "STATUS", " status =", " %e", BT_CHARACTER}, + tag_file = {"FILE", " file =", " %e", BT_CHARACTER }, + tag_status = {"STATUS", " status =", " %e", BT_CHARACTER}, tag_e_access = {"ACCESS", " access =", " %e", BT_CHARACTER}, tag_e_form = {"FORM", " form =", " %e", BT_CHARACTER}, tag_e_recl = {"RECL", " recl =", " %e", BT_INTEGER}, @@ -94,7 +94,8 @@ static const io_tag tag_end = {"END", " end =", " %l", BT_UNKNOWN}, tag_eor = {"EOR", " eor =", " %l", BT_UNKNOWN}, tag_id = {"ID", " id =", " %v", BT_INTEGER}, - tag_pending = {"PENDING", " pending =", " %v", BT_LOGICAL}; + tag_pending = {"PENDING", " pending =", " %v", BT_LOGICAL}, + tag_newunit = {"NEWUNIT", " newunit =", " %v", BT_INTEGER}; static gfc_dt *current_dt; @@ -1424,6 +1425,9 @@ match_open_element (gfc_open *open) m = match_etag (&tag_convert, &open->convert); if (m != MATCH_NO) return m; + m = match_out_tag (&tag_newunit, &open->newunit); + if (m != MATCH_NO) + return m; return MATCH_NO; } @@ -1456,6 +1460,7 @@ gfc_free_open (gfc_open *open) gfc_free_expr (open->sign); gfc_free_expr (open->convert); gfc_free_expr (open->asynchronous); + gfc_free_expr (open->newunit); gfc_free (open); } @@ -1485,6 +1490,7 @@ gfc_resolve_open (gfc_open *open) RESOLVE_TAG (&tag_e_round, open->round); RESOLVE_TAG (&tag_e_sign, open->sign); RESOLVE_TAG (&tag_convert, open->convert); + RESOLVE_TAG (&tag_newunit, open->newunit); if (gfc_reference_st_label (open->err, ST_LABEL_TARGET) == FAILURE) return FAILURE; @@ -1645,6 +1651,26 @@ gfc_match_open (void) } warn = (open->err || open->iostat) ? true : false; + + /* Checks on NEWUNIT specifier. */ + if (open->newunit) + { + if (open->unit) + { + gfc_error ("UNIT specifier not allowed with NEWUNIT at %C"); + goto cleanup; + } + + if (!(open->file || (open->status + && gfc_wide_strncasecmp (open->status->value.character.string, + "scratch", 7) == 0))) + { + gfc_error ("NEWUNIT specifier must have FILE= " + "or STATUS='scratch' at %C"); + goto cleanup; + } + } + /* Checks on the ACCESS specifier. */ if (open->access && open->access->expr_type == EXPR_CONSTANT) { @@ -2072,6 +2098,14 @@ gfc_resolve_close (gfc_close *close) if (gfc_reference_st_label (close->err, ST_LABEL_TARGET) == FAILURE) return FAILURE; + if (close->unit->expr_type == EXPR_CONSTANT + && close->unit->ts.type == BT_INTEGER + && mpz_sgn (close->unit->value.integer) < 0) + { + gfc_error ("UNIT number in CLOSE statement at %L must be non-negative", + &close->unit->where); + } + return SUCCESS; } @@ -2194,6 +2228,14 @@ gfc_resolve_filepos (gfc_filepos *fp) if (gfc_reference_st_label (fp->err, ST_LABEL_TARGET) == FAILURE) return FAILURE; + if (fp->unit->expr_type == EXPR_CONSTANT + && fp->unit->ts.type == BT_INTEGER + && mpz_sgn (fp->unit->value.integer) < 0) + { + gfc_error ("UNIT number in statement at %L must be non-negative", + &fp->unit->where); + } + return SUCCESS; } @@ -2589,6 +2631,12 @@ gfc_resolve_dt (gfc_dt *dt) return FAILURE; } + 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); + } + if (dt->extra_comma && gfc_notify_std (GFC_STD_GNU, "Extension: Comma before i/o " "item list at %L", &dt->extra_comma->where) == FAILURE) diff --git a/gcc/fortran/ioparm.def b/gcc/fortran/ioparm.def index ddef693..7de7a51 100644 --- a/gcc/fortran/ioparm.def +++ b/gcc/fortran/ioparm.def @@ -49,6 +49,7 @@ IOPARM (open, encoding, 1 << 19, char1) IOPARM (open, round, 1 << 20, char2) IOPARM (open, sign, 1 << 21, char1) IOPARM (open, asynchronous, 1 << 22, char2) +IOPARM (open, newunit, 1 << 23, pint4) IOPARM (close, common, 0, common) IOPARM (close, status, 1 << 7, char1) IOPARM (filepos, common, 0, common) diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index 0acf632..bdd70f5 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -469,26 +469,27 @@ set_parameter_value (stmtblock_t *block, tree var, enum iofield type, gfc_conv_expr_val (&se, e); /* If we're storing a UNIT number, we need to check it first. */ - if (type == IOPARM_common_unit && e->ts.kind != 4) + if (type == IOPARM_common_unit && e->ts.kind > 4) { - tree cond, max; + tree cond, val; int i; /* Don't evaluate the UNIT number multiple times. */ se.expr = gfc_evaluate_now (se.expr, &se.pre); - /* UNIT numbers should be nonnegative. */ + /* UNIT numbers should be greater than the min. */ + i = gfc_validate_kind (BT_INTEGER, 4, false); + val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].pedantic_min_int, 4); cond = fold_build2 (LT_EXPR, boolean_type_node, se.expr, - build_int_cst (TREE_TYPE (se.expr),0)); + fold_convert (TREE_TYPE (se.expr), val)); gfc_trans_io_runtime_check (cond, var, LIBERROR_BAD_UNIT, - "Negative unit number in I/O statement", + "Unit number in I/O statement too small", &se.pre); /* UNIT numbers should be less than the max. */ - i = gfc_validate_kind (BT_INTEGER, 4, false); - max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4); + val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4); cond = fold_build2 (GT_EXPR, boolean_type_node, se.expr, - fold_convert (TREE_TYPE (se.expr), max)); + fold_convert (TREE_TYPE (se.expr), val)); gfc_trans_io_runtime_check (cond, var, LIBERROR_BAD_UNIT, "Unit number in I/O statement too large", &se.pre); @@ -950,6 +951,10 @@ gfc_trans_open (gfc_code * code) if (p->convert) mask |= set_string (&block, &post_block, var, IOPARM_open_convert, p->convert); + + if (p->newunit) + mask |= set_parameter_ref (&block, &post_block, var, IOPARM_open_newunit, + p->newunit); set_parameter_const (&block, var, IOPARM_common_flags, mask); -- 2.7.4