This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

Re: [patch, fortran] PR40008 F2008: Add NEWUNIT= for OPEN statement


Jerry DeLisle wrote:
Hi,

Here is a cleaned up patch with checks included.

Bootstrapped and regression tested on x86-64.

I need to generate a couple of test cases.

OK for trunk?


The attached patch has been further updated after comments from Tobias on IRC. It includes revising two test cases so that they will pass with the added checks.


Basically, for kind>4 passed to NEWUNIT= a check is done to make sure it will fit within the range of a kind=4 unit number. These checks are created at compile time and executed at run time.

Additional checks are added to generate a compile time error if a user attempts to give a negative constant unit number to an IO statement.

If a negative unit number is provided by the user in a variable for UNIT= and it is within kind=4 range, and it does not match an already opened unit, a runtime error is generated.

Regression tested on x86-64-linux-gnu.

OK for trunk?

Regards,

Jerry

Index: gcc/testsuite/gfortran.dg/negative_unit.f
===================================================================
--- gcc/testsuite/gfortran.dg/negative_unit.f	(revision 147996)
+++ gcc/testsuite/gfortran.dg/negative_unit.f	(working copy)
@@ -6,20 +6,19 @@
 ! Test case update by Jerry DeLisle <jvdelisle@gcc.gnu.org>
 !
 ! Bugs submitted by Walt Brainerd
-      integer i
+      integer i,j
       logical l
       
-      i = 0
+      i = -1
 ! gfortran created a 'fort.-1' file and wrote "Hello" in it
-      write (unit=-1, fmt=*, iostat=i) "Hello"
-      if (i <= 0) call abort
+      write (unit=i, fmt=*, iostat=j) "Hello"
+      if (j <= 0) call abort
       
-      i = 0
-      open (unit=-11, file="xxx", iostat=i)
-      if (i <= 0) call abort
+      i = -11
+      open (unit=i, file="xxx", iostat=j)
+      if (j <= 0) call abort
 
-      i = 0
-      inquire (unit=-42, exist=l)
+      i = -42
+      inquire (unit=i, exist=l)
       if (l) call abort
-
       end
Index: gcc/testsuite/gfortran.dg/negative_unit_int8.f
===================================================================
--- gcc/testsuite/gfortran.dg/negative_unit_int8.f	(revision 147996)
+++ gcc/testsuite/gfortran.dg/negative_unit_int8.f	(working copy)
@@ -13,22 +13,22 @@
       integer, parameter ::ERROR_BAD_UNIT = 5005
       logical l
       
-      i = 0
+      i = -1
 ! gfortran created a 'fort.-1' file and wrote "Hello" in it
-      write (unit=-1, fmt=*, iostat=i) "Hello"
+      write (unit=i, fmt=*, iostat=i) "Hello"
       if (i <= 0) call abort
       
-      i = 0
-      open (unit=-11, file="xxx", iostat=i)
+      i = -11
+      open (unit=i, file="xxx", iostat=i)
       if (i <= 0) call abort
 
-      i = 0
-      inquire (unit=-42, exist=l)
+      i = -42
+      inquire (unit=i, exist=l)
       if (l) call abort
 
-      i = 0 
+      i = 2_8*huge(0_4)+20_8
 ! This one is nasty
-      inquire (unit=2_8*huge(0_4)+20_8, exist=l, iostat=i)
+      inquire (unit=i, exist=l, iostat=i)
       if (l) call abort
       if (i.ne.ERROR_BAD_UNIT) call abort
 
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 147996)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -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;
Index: gcc/fortran/io.c
===================================================================
--- gcc/fortran/io.c	(revision 147996)
+++ gcc/fortran/io.c	(working copy)
@@ -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 positive",
+		 &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 positive",
+		 &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 positive", &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)
Index: gcc/fortran/trans-io.c
===================================================================
--- gcc/fortran/trans-io.c	(revision 147996)
+++ gcc/fortran/trans-io.c	(working copy)
@@ -469,26 +469,27 @@ set_parameter_value (stmtblock_t *block,
   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);
 
Index: gcc/fortran/ioparm.def
===================================================================
--- gcc/fortran/ioparm.def	(revision 147996)
+++ gcc/fortran/ioparm.def	(working copy)
@@ -49,6 +49,7 @@ IOPARM (open,    encoding,	1 << 19, char
 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)
Index: libgfortran/libgfortran.h
===================================================================
--- libgfortran/libgfortran.h	(revision 147996)
+++ libgfortran/libgfortran.h	(working copy)
@@ -590,6 +590,7 @@ st_parameter_common;
 #define IOPARM_OPEN_HAS_ROUND		(1 << 20)
 #define IOPARM_OPEN_HAS_SIGN		(1 << 21)
 #define IOPARM_OPEN_HAS_ASYNCHRONOUS	(1 << 22)
+#define IOPARM_OPEN_HAS_NEWUNIT		(1 << 23)
 
 /* library start function and end macro.  These can be expanded if needed
    in the future.  cmp is st_parameter_common *cmp  */
Index: libgfortran/io/open.c
===================================================================
--- libgfortran/io/open.c	(revision 147996)
+++ libgfortran/io/open.c	(working copy)
@@ -814,7 +814,7 @@ st_open (st_parameter_open *opp)
 
   flags.convert = conv;
 
-  if (opp->common.unit < 0)
+  if (!(opp->common.flags & IOPARM_OPEN_HAS_NEWUNIT) && opp->common.unit < 0)
     generate_error (&opp->common, LIBERROR_BAD_OPTION,
 		    "Bad unit number in OPEN statement");
 
@@ -842,8 +842,13 @@ st_open (st_parameter_open *opp)
 
   if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
     {
-      u = find_or_create_unit (opp->common.unit);
+      if ((opp->common.flags & IOPARM_OPEN_HAS_NEWUNIT))
+	{
+	  *opp->newunit = get_unique_unit_number(opp);
+	  opp->common.unit = *opp->newunit;
+	}
 
+      u = find_or_create_unit (opp->common.unit);
       if (u->s == NULL)
 	{
 	  u = new_unit (opp, u, &flags);
Index: libgfortran/io/io.h
===================================================================
--- libgfortran/io/io.h	(revision 147996)
+++ libgfortran/io/io.h	(working copy)
@@ -297,6 +297,7 @@ typedef struct
   CHARACTER2 (round);
   CHARACTER1 (sign);
   CHARACTER2 (asynchronous);
+  GFC_INTEGER_4 *newunit;
 }
 st_parameter_open;
 
@@ -794,6 +795,10 @@ internal_proto(unpack_filename);
 extern gfc_offset max_offset;
 internal_proto(max_offset);
 
+/* Unit number to be assigned when NEWUNIT is used in an OPEN statement.  */
+extern GFC_INTEGER_4 next_available_newunit;
+internal_proto(next_available_newunit);
+
 /* Unit tree root.  */
 extern gfc_unit *unit_root;
 internal_proto(unit_root);
@@ -831,6 +836,9 @@ internal_proto (finish_last_advance_reco
 extern int unit_truncate (gfc_unit *, gfc_offset, st_parameter_common *);
 internal_proto (unit_truncate);
 
+extern GFC_INTEGER_4 get_unique_unit_number (st_parameter_open *);
+internal_proto(get_unique_unit_number);
+
 /* open.c */
 
 extern gfc_unit *new_unit (st_parameter_open *, gfc_unit *, unit_flags *);
Index: libgfortran/io/unit.c
===================================================================
--- libgfortran/io/unit.c	(revision 147996)
+++ libgfortran/io/unit.c	(working copy)
@@ -67,6 +67,8 @@ see the files COPYING3 and COPYING.RUNTI
 
 /* Subroutines related to units */
 
+GFC_INTEGER_4 next_available_newunit;
+#define GFC_FIRST_NEWUNIT -10
 
 #define CACHE_SIZE 3
 static gfc_unit *unit_cache[CACHE_SIZE];
@@ -131,7 +133,6 @@ rotate_right (gfc_unit * t)
 }
 
 
-
 static int
 compare (int a, int b)
 {
@@ -480,7 +481,7 @@ free_internal_unit (st_parameter_dt *dtp
 
 
 /* get_unit()-- Returns the unit structure associated with the integer
- * unit or the internal file. */
+   unit or the internal file.  */
 
 gfc_unit *
 get_unit (st_parameter_dt *dtp, int do_create)
@@ -489,7 +490,7 @@ get_unit (st_parameter_dt *dtp, int do_c
   if ((dtp->common.flags & IOPARM_DT_HAS_INTERNAL_UNIT) != 0)
     return get_internal_unit(dtp);
 
-  /* Has to be an external unit */
+  /* Has to be an external unit.  */
 
   dtp->u.p.unit_is_internal = 0;
   dtp->internal_unit_desc = NULL;
@@ -499,7 +500,7 @@ get_unit (st_parameter_dt *dtp, int do_c
 
 
 /*************************/
-/* Initialize everything */
+/* Initialize everything.  */
 
 void
 init_units (void)
@@ -511,6 +512,8 @@ init_units (void)
   __GTHREAD_MUTEX_INIT_FUNCTION (&unit_lock);
 #endif
 
+  next_available_newunit = GFC_FIRST_NEWUNIT;
+
   if (options.stdin_unit >= 0)
     {				/* STDIN */
       u = insert_unit (options.stdin_unit);
@@ -601,10 +604,8 @@ init_units (void)
     }
 
   /* Calculate the maximum file offset in a portable manner.
-   * max will be the largest signed number for the type gfc_offset.
-   *
-   * set a 1 in the LSB and keep a running sum, stopping at MSB-1 bit. */
-
+     max will be the largest signed number for the type gfc_offset.
+     set a 1 in the LSB and keep a running sum, stopping at MSB-1 bit.  */
   max_offset = 0;
   for (i = 0; i < sizeof (max_offset) * 8 - 1; i++)
     max_offset = max_offset + ((gfc_offset) 1 << i);
@@ -663,8 +664,8 @@ unlock_unit (gfc_unit *u)
 }
 
 /* close_unit()-- Close a unit.  The stream is closed, and any memory
- * associated with the stream is freed.  Returns nonzero on I/O error.
- * Should be called with the u->lock locked. */
+   associated with the stream is freed.  Returns nonzero on I/O error.
+   Should be called with the u->lock locked. */
 
 int
 close_unit (gfc_unit *u)
@@ -674,11 +675,11 @@ close_unit (gfc_unit *u)
 
 
 /* close_units()-- Delete units on completion.  We just keep deleting
- * the root of the treap until there is nothing left.
- * Not sure what to do with locking here.  Some other thread might be
- * holding some unit's lock and perhaps hold it indefinitely
- * (e.g. waiting for input from some pipe) and close_units shouldn't
- * delay the program too much.  */
+   the root of the treap until there is nothing left.
+   Not sure what to do with locking here.  Some other thread might be
+   holding some unit's lock and perhaps hold it indefinitely
+   (e.g. waiting for input from some pipe) and close_units shouldn't
+   delay the program too much.  */
 
 void
 close_units (void)
@@ -813,3 +814,22 @@ finish_last_advance_record (gfc_unit *u)
   fbuf_flush (u, u->mode);
 }
 
+/* Assign a negative number for NEWUNIT in OPEN statements.  */
+GFC_INTEGER_4
+get_unique_unit_number (st_parameter_open *opp)
+{
+  GFC_INTEGER_4 num;
+
+  __gthread_mutex_lock (&unit_lock);
+  num = next_available_newunit--;
+
+  /* Do not allow NEWUNIT numbers to wrap.  */
+  if (next_available_newunit >=  GFC_FIRST_NEWUNIT )
+    {
+      __gthread_mutex_unlock (&unit_lock);
+      generate_error (&opp->common, LIBERROR_INTERNAL, "NEWUNIT exhausted");
+      return 0;
+    }
+  __gthread_mutex_unlock (&unit_lock);
+  return num;
+}
Index: libgfortran/io/transfer.c
===================================================================
--- libgfortran/io/transfer.c	(revision 147996)
+++ libgfortran/io/transfer.c	(working copy)
@@ -2020,7 +2020,7 @@ data_transfer_init (st_parameter_dt *dtp
 	close_unit (dtp->u.p.current_unit);
 	dtp->u.p.current_unit = NULL;
 	generate_error (&dtp->common, LIBERROR_BAD_OPTION,
-			"Bad unit number in OPEN statement");
+			"Bad unit number in statement");
 	return;
       }
     memset (&u_flags, '\0', sizeof (u_flags));

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]