This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[patch, libgfortran] Fix PR20257 End of record occurs when writing large arrays
- From: Jerry DeLisle <jvdelisle at verizon dot net>
- To: Fortran List <fortran at gcc dot gnu dot org>, gcc-patches <gcc-patches at gcc dot gnu dot org>
- Date: Thu, 20 Apr 2006 16:17:57 -0700
- Subject: [patch, libgfortran] Fix PR20257 End of record occurs when writing large arrays
:ADDPATCH fortran:
This patch fixes the PR. When bytes_left is less then the requested read or
write size, a check for preconnected units (stdin, stdout, stderr) is made
before generating an error and the bytes_left is reset to the dafault record
length. In such a case the error is skipped and the I/O allowed to proceed
normally.
This bypassing of the error is only allowed if the units assigned record length
is equal to the default which is very large. So the bypass will only occur
every blue moon. If the user has set the record length deliberately to
something other than the default, then it is assumed they mean it and the error
will not be skipped.
You will notice an absurd unit number being assigned to internal units. It
turns out that the stderr unit number is zero. To avoid mistaking an internal
unit as preconnected I set it to 135790. This also eliminates a case of
accessing an uninitialized value pointed out by valgrind.
While at it, I also fixed a few cases of flushing with internal units and
cleaned up free_mem use for internal units, consolidating and cleaning up the
code. This eliminates several errors noted by valgrind.
I tested the error bypass by artificially setting the default record length to
something smaller. I had to do this to test because I don't have enough memory
in my machine here to set such a large array without getting into disk swapping.
The final patch has been regression tested on i686, NIST tested, many I/O tested
and checked with valgrind on a few cases that valgrind noted had problems. All
looks solid on this end. (I even got a little progress on tonto-1.0 with it)
OK for trunk and then later 4.1.1?
A test case is somewhat impractical for this feature. (open to suggestions)
Could someone who likes to do things with very large arrays/files test this?
Best regards,
Jerry
2006-04-20 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR libgfortran/20257
* io/io.h: Add prototypes for get_internal_unit and free_internal_unit.
* io/unit.c (get_internal_unit): Initialize unit number, not zero.
(free_internal_unit): New function to consolidate freeing memory.
(get_unit): Initialize internal_unit_desc to NULL when unit is
external.
* io/unix.c (mem_close): Check for not NULL before freeing memory.
* io/transfer.c (read_block): Reset bytes_left and skip error if unit
is preconnected if default record length is reached.
(read_block_direct): Ditto.
(write_block): Ditto.
(write_buf): Ditto.
(data_transfer_init): Only flush if not internal unit.
(finalize_transfer): Ditto and delete code to free memory used by
internal units.
(st_read_done): Use new function - free_internal_unit.
(st_write_done): Use new function - free_internal unit.
Index: io/io.h
===================================================================
*** io/io.h (revision 113060)
--- io/io.h (working copy)
*************** internal_proto(unit_lock);
*** 702,707 ****
--- 702,713 ----
extern int close_unit (gfc_unit *);
internal_proto(close_unit);
+ extern gfc_unit *get_internal_unit (st_parameter_dt *);
+ internal_proto(get_internal_unit);
+
+ extern void free_internal_unit (st_parameter_dt *);
+ internal_proto(free_internal_unit);
+
extern int is_internal_unit (st_parameter_dt *);
internal_proto(is_internal_unit);
Index: io/unit.c
===================================================================
*** io/unit.c (revision 113060)
--- io/unit.c (working copy)
*************** get_internal_unit (st_parameter_dt *dtp)
*** 378,383 ****
--- 378,387 ----
memset (iunit, '\0', sizeof (gfc_unit));
iunit->recl = dtp->internal_unit_len;
+
+ /* For internal units we set the unit number to something unlikely
+ to be used. Otherwise internal units can be mistaken for stderr. */
+ iunit->unit_number = 135790;
/* Set up the looping specification from the array descriptor, if any. */
*************** get_internal_unit (st_parameter_dt *dtp)
*** 424,429 ****
--- 428,450 ----
}
+ /* free_internal_unit()-- Free memory allocated for internal units if any. */
+ void
+ free_internal_unit (st_parameter_dt *dtp)
+ {
+ if (!is_internal_unit (dtp))
+ return;
+
+ if (dtp->u.p.current_unit->ls != NULL)
+ free_mem (dtp->u.p.current_unit->ls);
+
+ sclose (dtp->u.p.current_unit->s);
+
+ if (dtp->u.p.current_unit != NULL)
+ free_mem (dtp->u.p.current_unit);
+ }
+
+
/* get_unit()-- Returns the unit structure associated with the integer
* unit or the internal file. */
*************** get_unit (st_parameter_dt *dtp, int do_c
*** 437,442 ****
--- 458,464 ----
/* Has to be an external unit */
dtp->u.p.unit_is_internal = 0;
+ dtp->internal_unit_desc = NULL;
return get_external_unit (dtp->common.unit, do_create);
}
Index: io/unix.c
===================================================================
*** io/unix.c (revision 113060)
--- io/unix.c (working copy)
*************** mem_truncate (unix_stream * s __attribut
*** 928,934 ****
static try
mem_close (unix_stream * s)
{
! free_mem (s);
return SUCCESS;
}
--- 928,935 ----
static try
mem_close (unix_stream * s)
{
! if (s != NULL)
! free_mem (s);
return SUCCESS;
}
Index: io/transfer.c
===================================================================
*** io/transfer.c (revision 113060)
--- io/transfer.c (working copy)
*************** read_block (st_parameter_dt *dtp, int *l
*** 257,267 ****
if (dtp->u.p.current_unit->bytes_left < *length)
{
! if (dtp->u.p.current_unit->flags.pad == PAD_NO)
{
! generate_error (&dtp->common, ERROR_EOR, NULL);
! /* Not enough data left. */
! return NULL;
}
*length = dtp->u.p.current_unit->bytes_left;
--- 257,275 ----
if (dtp->u.p.current_unit->bytes_left < *length)
{
! /* For preconnected units with default record length, set bytes left
! to unit record length and proceed, otherwise error. */
! if (dtp->u.p.current_unit->unit_number == options.stdin_unit
! && dtp->u.p.current_unit->recl == DEFAULT_RECL)
! dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
! else
{
! if (dtp->u.p.current_unit->flags.pad == PAD_NO)
! {
! /* Not enough data left. */
! generate_error (&dtp->common, ERROR_EOR, NULL);
! return NULL;
! }
}
*length = dtp->u.p.current_unit->bytes_left;
*************** read_block_direct (st_parameter_dt *dtp,
*** 305,315 ****
if (dtp->u.p.current_unit->bytes_left < *nbytes)
{
! if (dtp->u.p.current_unit->flags.pad == PAD_NO)
{
! /* Not enough data left. */
! generate_error (&dtp->common, ERROR_EOR, NULL);
! return;
}
*nbytes = dtp->u.p.current_unit->bytes_left;
--- 313,331 ----
if (dtp->u.p.current_unit->bytes_left < *nbytes)
{
! /* For preconnected units with default record length, set bytes left
! to unit record length and proceed, otherwise error. */
! if (dtp->u.p.current_unit->unit_number == options.stdin_unit
! && dtp->u.p.current_unit->recl == DEFAULT_RECL)
! dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
! else
{
! if (dtp->u.p.current_unit->flags.pad == PAD_NO)
! {
! /* Not enough data left. */
! generate_error (&dtp->common, ERROR_EOR, NULL);
! return;
! }
}
*nbytes = dtp->u.p.current_unit->bytes_left;
*************** void *
*** 358,368 ****
write_block (st_parameter_dt *dtp, int length)
{
char *dest;
!
if (dtp->u.p.current_unit->bytes_left < length)
{
! generate_error (&dtp->common, ERROR_EOR, NULL);
! return NULL;
}
dtp->u.p.current_unit->bytes_left -= (gfc_offset) length;
--- 374,393 ----
write_block (st_parameter_dt *dtp, int length)
{
char *dest;
!
if (dtp->u.p.current_unit->bytes_left < length)
{
! /* For preconnected units with default record length, set bytes left
! to unit record length and proceed, otherwise error. */
! if ((dtp->u.p.current_unit->unit_number == options.stdout_unit
! || dtp->u.p.current_unit->unit_number == options.stderr_unit)
! && dtp->u.p.current_unit->recl == DEFAULT_RECL)
! dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
! else
! {
! generate_error (&dtp->common, ERROR_EOR, NULL);
! return NULL;
! }
}
dtp->u.p.current_unit->bytes_left -= (gfc_offset) length;
*************** write_buf (st_parameter_dt *dtp, void *b
*** 388,398 ****
{
if (dtp->u.p.current_unit->bytes_left < nbytes)
{
! if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
! generate_error (&dtp->common, ERROR_DIRECT_EOR, NULL);
else
! generate_error (&dtp->common, ERROR_EOR, NULL);
! return FAILURE;
}
dtp->u.p.current_unit->bytes_left -= (gfc_offset) nbytes;
--- 413,432 ----
{
if (dtp->u.p.current_unit->bytes_left < nbytes)
{
! /* For preconnected units with default record length, set bytes left
! to unit record length and proceed, otherwise error. */
! if ((dtp->u.p.current_unit->unit_number == options.stdout_unit
! || dtp->u.p.current_unit->unit_number == options.stderr_unit)
! && dtp->u.p.current_unit->recl == DEFAULT_RECL)
! dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
else
! {
! if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
! generate_error (&dtp->common, ERROR_DIRECT_EOR, NULL);
! else
! generate_error (&dtp->common, ERROR_EOR, NULL);
! return FAILURE;
! }
}
dtp->u.p.current_unit->bytes_left -= (gfc_offset) nbytes;
*************** data_transfer_init (st_parameter_dt *dtp
*** 1592,1598 ****
/* Check to see if we might be reading what we wrote before */
! if (dtp->u.p.mode == READING && dtp->u.p.current_unit->mode == WRITING)
flush(dtp->u.p.current_unit->s);
/* Check whether the record exists to be read. Only
--- 1626,1634 ----
/* Check to see if we might be reading what we wrote before */
! if (dtp->u.p.mode == READING
! && dtp->u.p.current_unit->mode == WRITING
! && !is_internal_unit (dtp))
flush(dtp->u.p.current_unit->s);
/* Check whether the record exists to be read. Only
*************** finalize_transfer (st_parameter_dt *dtp)
*** 2186,2192 ****
{
/* Most systems buffer lines, so force the partial record
to be written out. */
! flush (dtp->u.p.current_unit->s);
dtp->u.p.seen_dollar = 0;
return;
}
--- 2222,2229 ----
{
/* Most systems buffer lines, so force the partial record
to be written out. */
! if (!is_internal_unit (dtp))
! flush (dtp->u.p.current_unit->s);
dtp->u.p.seen_dollar = 0;
return;
}
*************** finalize_transfer (st_parameter_dt *dtp)
*** 2195,2210 ****
}
sfree (dtp->u.p.current_unit->s);
-
- if (is_internal_unit (dtp))
- {
- if (is_array_io (dtp) && dtp->u.p.current_unit->ls != NULL)
- free_mem (dtp->u.p.current_unit->ls);
- sclose (dtp->u.p.current_unit->s);
- }
}
-
/* Transfer function for IOLENGTH. It doesn't actually do any
data transfer, it just updates the length counter. */
--- 2232,2239 ----
*************** st_read_done (st_parameter_dt *dtp)
*** 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 ();
}
--- 2347,2355 ----
free_mem (dtp->u.p.scratch);
if (dtp->u.p.current_unit != NULL)
unlock_unit (dtp->u.p.current_unit);
!
! free_internal_unit (dtp);
!
library_end ();
}
*************** st_write_done (st_parameter_dt *dtp)
*** 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 ();
}
--- 2402,2410 ----
free_mem (dtp->u.p.scratch);
if (dtp->u.p.current_unit != NULL)
unlock_unit (dtp->u.p.current_unit);
!
! free_internal_unit (dtp);
!
library_end ();
}