[RFC] NEWUNIT preliminary patch

[Jerry DeLisle <jvdelisle at verizon dot net>]

Hi,

The attached patches are provided for your review, comment, and testing.  I 
manually cut some hunks out of the front end patch from another patch, so I 
expect some fuzz when applying this. (newunit1 is library side. newunit2 is 
front-end)

The NEWUNIT unit number assignments are made as a simple sequential negative 
number beginning with -10.  I chose to use -10 to preserve some unit numbers for 
future.  We already use -1 to signify a character internal unit.  There is 
nothing special about -10.

I have attempted to be thread safe, however I am curious about the 
initialization of next_avaialble_newunit.  Is it safe as is or does it need to 
be locked?

I have not done any thorough testing.  I also have not had time to go back and 
see if I need any other checks.

I thought it would be useful to allow others to see and exercise this and find 
out what we can learn from it.

Regards,

Jerry

Index: open.c
===================================================================
--- open.c	(revision 147834)
+++ 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: io.h
===================================================================
--- io.h	(revision 147834)
+++ 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 int 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: unit.c
===================================================================
--- unit.c	(revision 147834)
+++ unit.c	(working copy)
@@ -67,6 +67,8 @@ see the files COPYING3 and COPYING.RUNTI
 
 /* Subroutines related to units */
 
+int 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: transfer.c
===================================================================
--- transfer.c	(revision 147834)
+++ 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: gfortran.h
===================================================================
--- gfortran.h	(revision 147841)
+++ gfortran.h	(working copy)
@@ -1817,7 +1817,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: io.c
===================================================================
--- io.c	(revision 147841)
+++ 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 +1450,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 +1485,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 +1515,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;
Index: trans-io.c
===================================================================
--- trans-io.c	(revision 147841)
+++ trans-io.c	(working copy)
@@ -950,6 +950,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: ioparm.def
===================================================================
--- ioparm.def	(revision 147841)
+++ 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)