[PATCH, libgfortran] Fix PR26766 Recursive I/O to internal units

[Jerry DeLisle <jvdelisle at verizon dot net>]

:ADDPATCH fortran:

The attached patch fixes the subject bug by modifying get_unit to allocate 
memory for a unit structure dynamically when the unit is internal.  The memory 
is freed when the I/O operation is completed.  A flag in the dtp structure is 
used to identify the unit as internal for subsequent operations after it is opened.

I am not familiar with the thread safe gomp locking stuff in here.  So I have 
left it in place for the moment, asking for input from others.

What I would like to do is delete the static internal_unit that is declared in 
unit.c and eliminate the locking altogether.  It seems to me that this code 
should be thread safe because a new structure is allocated for each I/O 
operation and then freed when done.  But I am not certain of this.

Advice on this mutex lock stuff will be much appreciated.

I have regression tested, io tested, NIST tested, and used valgrind to eliminate 
all memory problems.  In fact I found a latent bug in this process in 
st_write_done where we were trying to flush and truncate an internal unit.  That 
makes no sense at all and valgrind happily reported that larger blocks were 
being freed then had been allocated.  Sort of the opposite of a memory leak.

I did some performance checking and did not see too much additional overhead 
with this solution.  I also took the opportunity to reorganize the get_unit code 
a bit and fix some line widths and white spaces.  Test case included too.

I will await comments and then we will see about committing to trunk?

Best Regards

Jerry

2006-04-06  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR libgfortran/26766
	* io/io.h: Add bit to identify associated unit as internal.
	* io/unit.c (get_external_unit): Renamed the find_unit_1 function to
	reflect the external unit functionality vs internal unit.
	(get_internal_unit): New function to allocate and initialize an internal
	unit structure.
	(get_unit): Use get_internal_unit and get_external_unit.
	(is_internal_unit): Revised to use new bit added in io.h.
	* io/transfer.c (data_transfer_init): Fix line width.
	(st_read_done): Free memory allocated for internal unit.
	(st_write_done): Add test to only flush and truncate when not an
	internal unit.  Free memory allocated for internal unit.



Index: io/io.h
===================================================================
*** io/io.h	(revision 112655)
--- io/io.h	(working copy)
*************** typedef struct st_parameter_dt
*** 414,420 ****
            /* A namelist specific flag used to enable reading input from 
  	     line_buffer for logical reads.  */
  	  unsigned line_buffer_enabled : 1;
! 	  /* 18 unused bits.  */
  
  	  char last_char;
  	  char nml_delim;
--- 414,423 ----
            /* A namelist specific flag used to enable reading input from 
  	     line_buffer for logical reads.  */
  	  unsigned line_buffer_enabled : 1;
! 	  /* An internal unit specific flag used to identify that the associated
! 	     unit is internal.  */
! 	  unsigned unit_is_internal : 1;
! 	  /* 17 unused bits.  */
  
  	  char last_char;
  	  char nml_delim;
Index: io/unit.c
===================================================================
*** io/unit.c	(revision 112655)
--- io/unit.c	(working copy)
*************** delete_unit (gfc_unit * old)
*** 260,271 ****
  }
  
  
! /* find_unit()-- Given an integer, return a pointer to the unit
   * structure.  Returns NULL if the unit does not exist,
   * otherwise returns a locked unit. */
  
  static gfc_unit *
! find_unit_1 (int n, int do_create)
  {
    gfc_unit *p;
    int c, created = 0;
--- 260,271 ----
  }
  
  
! /* get_external_unit()-- Given an integer, return a pointer to the unit
   * structure.  Returns NULL if the unit does not exist,
   * otherwise returns a locked unit. */
  
  static gfc_unit *
! get_external_unit (int n, int do_create)
  {
    gfc_unit *p;
    int c, created = 0;
*************** found:
*** 346,403 ****
    return p;
  }
  
  gfc_unit *
  find_unit (int n)
  {
!   return find_unit_1 (n, 0);
  }
  
  gfc_unit *
  find_or_create_unit (int n)
  {
!   return find_unit_1 (n, 1);
  }
  
- /* get_unit()-- Returns the unit structure associated with the integer
-  * unit or the internal file. */
  
  gfc_unit *
! get_unit (st_parameter_dt *dtp, int do_create)
  {
!   if ((dtp->common.flags & IOPARM_DT_HAS_INTERNAL_UNIT) != 0)
      {
!       __gthread_mutex_lock (&internal_unit.lock);
!       internal_unit.recl = dtp->internal_unit_len;
!       if (is_array_io (dtp))
! 	{
! 	  internal_unit.rank = GFC_DESCRIPTOR_RANK (dtp->internal_unit_desc);
! 	  internal_unit.ls = (array_loop_spec *)
! 	    get_mem (internal_unit.rank * sizeof (array_loop_spec));
! 	  dtp->internal_unit_len *=
! 	    init_loop_spec (dtp->internal_unit_desc, internal_unit.ls);
! 	}
  
!       internal_unit.s =
! 	open_internal (dtp->internal_unit, dtp->internal_unit_len);
!       internal_unit.bytes_left = internal_unit.recl;
!       internal_unit.last_record=0;
!       internal_unit.maxrec=0;
!       internal_unit.current_record=0;
! 
!       /* Set flags for the internal unit */
! 
!       internal_unit.flags.access = ACCESS_SEQUENTIAL;
!       internal_unit.flags.action = ACTION_READWRITE;
!       internal_unit.flags.form = FORM_FORMATTED;
!       internal_unit.flags.delim = DELIM_NONE;
!       internal_unit.flags.pad = PAD_YES;
  
!       return &internal_unit;
      }
  
    /* Has to be an external unit */
  
!   return find_unit_1 (dtp->common.unit, do_create);
  }
  
  
--- 346,444 ----
    return p;
  }
  
+ 
  gfc_unit *
  find_unit (int n)
  {
!   return get_external_unit (n, 0);
  }
  
+ 
  gfc_unit *
  find_or_create_unit (int n)
  {
!   return get_external_unit (n, 1);
  }
  
  
  gfc_unit *
! get_internal_unit (st_parameter_dt *dtp)
  {
!   gfc_unit * iunit;
! 
!   /* Allocate memory for a unit structure.  */
! 
!   iunit = get_mem (sizeof (gfc_unit));
!   if (iunit == NULL)
      {
!       generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
!       return NULL;
!     }
! 
!   memset (iunit, '\0', sizeof (gfc_unit));
  
!   iunit->recl = dtp->internal_unit_len;
  
!   /* Set up the looping specification from the array descriptor, if any.  */
! 
!   if (is_array_io (dtp))
!     {
!       iunit->rank = GFC_DESCRIPTOR_RANK (dtp->internal_unit_desc);
!       iunit->ls = (array_loop_spec *)
! 	get_mem (iunit->rank * sizeof (array_loop_spec));
!       dtp->internal_unit_len *=
! 	init_loop_spec (dtp->internal_unit_desc, iunit->ls);
      }
  
+   /* Set initial values for unit parameters.  */
+ 
+   iunit->s = open_internal (dtp->internal_unit, dtp->internal_unit_len);
+   iunit->bytes_left = iunit->recl;
+   iunit->last_record=0;
+   iunit->maxrec=0;
+   iunit->current_record=0;
+   iunit->read_bad = 0;
+ 
+   /* Set flags for the internal unit.  */
+ 
+   iunit->flags.access = ACCESS_SEQUENTIAL;
+   iunit->flags.action = ACTION_READWRITE;
+   iunit->flags.form = FORM_FORMATTED;
+   iunit->flags.pad = PAD_YES;
+   iunit->flags.status = STATUS_UNSPECIFIED;
+ 
+   /* Initialize the data transfer parameters.  */
+ 
+   dtp->u.p.advance_status = ADVANCE_YES;
+   dtp->u.p.blank_status = BLANK_UNSPECIFIED;
+   dtp->u.p.seen_dollar = 0;
+   dtp->u.p.skips = 0;
+   dtp->u.p.pending_spaces = 0;
+   dtp->u.p.max_pos = 0;
+ 
+   /* This flag tells us the unit is assigned to internal I/O.  */
+   
+   dtp->u.p.unit_is_internal = 1;
+ 
+   return iunit;
+ }
+ 
+ 
+ /* get_unit()-- Returns the unit structure associated with the integer
+  * unit or the internal file. */
+ 
+ gfc_unit *
+ get_unit (st_parameter_dt *dtp, int do_create)
+ {
+ 
+   if ((dtp->common.flags & IOPARM_DT_HAS_INTERNAL_UNIT) != 0)
+     return get_internal_unit(dtp);
+ 
    /* Has to be an external unit */
  
!   dtp->u.p.unit_is_internal = 0;
! 
!   return get_external_unit (dtp->common.unit, do_create);
  }
  
  
*************** get_unit (st_parameter_dt *dtp, int do_c
*** 406,412 ****
  int
  is_internal_unit (st_parameter_dt *dtp)
  {
!   return dtp->u.p.current_unit == &internal_unit;
  }
  
  
--- 447,453 ----
  int
  is_internal_unit (st_parameter_dt *dtp)
  {
!   return dtp->u.p.unit_is_internal;
  }
  
  
Index: io/transfer.c
===================================================================
*** io/transfer.c	(revision 112655)
--- io/transfer.c	(working copy)
*************** data_transfer_init (st_parameter_dt *dtp
*** 1619,1625 ****
       it is always safe to truncate the file on the first write */
    if (dtp->u.p.mode == WRITING
        && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
!       && dtp->u.p.current_unit->last_record == 0 && !is_preconnected(dtp->u.p.current_unit->s))
  	struncate(dtp->u.p.current_unit->s);
  
    /* Bugware for badly written mixed C-Fortran I/O.  */
--- 1619,1626 ----
       it is always safe to truncate the file on the first write */
    if (dtp->u.p.mode == WRITING
        && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
!       && dtp->u.p.current_unit->last_record == 0 
!       && !is_preconnected(dtp->u.p.current_unit->s))
  	struncate(dtp->u.p.current_unit->s);
  
    /* Bugware for badly written mixed C-Fortran I/O.  */
*************** st_read_done (st_parameter_dt *dtp)
*** 2317,2322 ****
--- 2318,2325 ----
      free_mem (dtp->u.p.scratch);
    if (dtp->u.p.current_unit != NULL)
      unlock_unit (dtp->u.p.current_unit);
+   if (is_internal_unit (dtp) && dtp->u.p.current_unit != NULL)
+     free_mem (dtp->u.p.current_unit);
    library_end ();
  }
  
*************** st_write_done (st_parameter_dt *dtp)
*** 2353,2362 ****
  
        case NO_ENDFILE:
  	/* Get rid of whatever is after this record.  */
! 	flush (dtp->u.p.current_unit->s);
! 	if (struncate (dtp->u.p.current_unit->s) == FAILURE)
! 	  generate_error (&dtp->common, ERROR_OS, NULL);
! 
  	dtp->u.p.current_unit->endfile = AT_ENDFILE;
  	break;
        }
--- 2356,2367 ----
  
        case NO_ENDFILE:
  	/* Get rid of whatever is after this record.  */
!         if (!is_internal_unit (dtp))
! 	  {
! 	    flush (dtp->u.p.current_unit->s);
! 	    if (struncate (dtp->u.p.current_unit->s) == FAILURE)
! 	      generate_error (&dtp->common, ERROR_OS, NULL);
! 	  }
  	dtp->u.p.current_unit->endfile = AT_ENDFILE;
  	break;
        }
*************** st_write_done (st_parameter_dt *dtp)
*** 2367,2372 ****
--- 2372,2379 ----
      free_mem (dtp->u.p.scratch);
    if (dtp->u.p.current_unit != NULL)
      unlock_unit (dtp->u.p.current_unit);
+   if (is_internal_unit (dtp) && dtp->u.p.current_unit != NULL)
+     free_mem (dtp->u.p.current_unit);
    library_end ();
  }

Attachment: write_recursive.f90
Description: application/extension-f90