From 9ad55c33ae2d0c410fbc563fd59e8edb37a48b8b Mon Sep 17 00:00:00 2001
From: Jerry DeLisle <jvdelisle@gcc.gnu.org>
Date: Sun, 7 Jun 2009 18:57:43 +0000
Subject: [PATCH] re PR fortran/40008 (F2008: Add NEWUNIT= for OPEN statement)
2009-05-31 Jerry DeLisle <jvdelisle@gcc.gnu.org>
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.
From-SVN: r148252
---
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 0a737bfd1e91..14cef2b7a676 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,20 @@
+2009-05-31 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+
+ 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 <franke.daniel@gmail.com>
PR fortran/25104
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 902790428b82..c8347d032c0c 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 c902257f095f..ea562923f05b 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;
@@ -1422,6 +1423,9 @@ match_open_element (gfc_open *open)
if (m != MATCH_NO)
return m;
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;
@@ -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 ddef69370263..7de7a5101dcb 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 0acf632fc06a..bdd70f587402 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);
--
GitLab