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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@148252 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 0a737bf..14cef2b 100644 (file)
--- 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
 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 9027904..c8347d0 100644 (file)
--- 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,
 {
   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;
   gfc_st_label *err;
 }
 gfc_open;

diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c
index c902257..ea56292 100644 (file)
--- a/gcc/fortran/io.c
+++ b/gcc/fortran/io.c
@@ -38,8 +38,8 @@ typedef struct
 io_tag;
 
 static const io_tag
 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},
        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_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;
 
 
 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_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;
 }
 
   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->sign);
   gfc_free_expr (open->convert);
   gfc_free_expr (open->asynchronous);

+  gfc_free_expr (open->newunit);

   gfc_free (open);
 }
 
   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_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;
 
   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;
     }
 
   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)
     {
   /* 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 (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;
 }
 
   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 (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;
 }
 
   return SUCCESS;
 }
 


@@ -2589,6 +2631,12 @@ gfc_resolve_dt (gfc_dt *dt)
       return FAILURE;
     }
 
       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)
   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 (file)
--- 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,    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)
 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 (file)
--- 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.  */
   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);
 
       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,
       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,
       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.  */
                               &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,
       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);
       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->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);
 
 
   set_parameter_const (&block, var, IOPARM_common_flags, mask);