Daily bump.

[pf3gnuchains/gcc-fork.git] / gcc / fortran / io.c

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
-       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)