re PR libfortran/20257 (Fortran runtime error: End of record occurs when writing large arrays)
2006-04-22 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 and 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. From-SVN: r113190
This commit is contained in:
Jerry DeLisle
parent
e8bbccd643
commit
54ffdb125c
|
|
@ -1,3 +1,23 @@
|
|||
2006-04-22 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 and 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.
|
||||
|
||||
2006-04-22 Jakub Jelinek <jakub@redhat.com>
|
||||
|
||||
PR fortran/26769
|
||||
|
|
|
|||
|
|
@ -702,6 +702,12 @@ internal_proto(unit_lock);
|
|||
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);
|
||||
|
||||
|
|
|
|||
|
|
@ -257,11 +257,19 @@ read_block (st_parameter_dt *dtp, int *length)
|
|||
|
||||
if (dtp->u.p.current_unit->bytes_left < *length)
|
||||
{
|
||||
if (dtp->u.p.current_unit->flags.pad == PAD_NO)
|
||||
/* 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
|
||||
{
|
||||
generate_error (&dtp->common, ERROR_EOR, NULL);
|
||||
/* Not enough data left. */
|
||||
return NULL;
|
||||
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;
|
||||
|
|
@ -305,11 +313,19 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
|
|||
|
||||
if (dtp->u.p.current_unit->bytes_left < *nbytes)
|
||||
{
|
||||
if (dtp->u.p.current_unit->flags.pad == PAD_NO)
|
||||
/* 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
|
||||
{
|
||||
/* Not enough data left. */
|
||||
generate_error (&dtp->common, ERROR_EOR, NULL);
|
||||
return;
|
||||
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;
|
||||
|
|
@ -358,11 +374,20 @@ void *
|
|||
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;
|
||||
/* 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;
|
||||
|
|
@ -388,11 +413,20 @@ write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
|
|||
{
|
||||
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);
|
||||
/* 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 FAILURE;
|
||||
{
|
||||
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;
|
||||
|
|
@ -1592,7 +1626,9 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
|
|||
|
||||
/* 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)
|
||||
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
|
||||
|
|
@ -2186,7 +2222,8 @@ finalize_transfer (st_parameter_dt *dtp)
|
|||
{
|
||||
/* Most systems buffer lines, so force the partial record
|
||||
to be written out. */
|
||||
flush (dtp->u.p.current_unit->s);
|
||||
if (!is_internal_unit (dtp))
|
||||
flush (dtp->u.p.current_unit->s);
|
||||
dtp->u.p.seen_dollar = 0;
|
||||
return;
|
||||
}
|
||||
|
|
@ -2195,16 +2232,8 @@ finalize_transfer (st_parameter_dt *dtp)
|
|||
}
|
||||
|
||||
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. */
|
||||
|
||||
|
|
@ -2318,8 +2347,9 @@ st_read_done (st_parameter_dt *dtp)
|
|||
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);
|
||||
|
||||
free_internal_unit (dtp);
|
||||
|
||||
library_end ();
|
||||
}
|
||||
|
||||
|
|
@ -2372,8 +2402,9 @@ st_write_done (st_parameter_dt *dtp)
|
|||
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);
|
||||
|
||||
free_internal_unit (dtp);
|
||||
|
||||
library_end ();
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -378,6 +378,11 @@ get_internal_unit (st_parameter_dt *dtp)
|
|||
memset (iunit, '\0', sizeof (gfc_unit));
|
||||
|
||||
iunit->recl = dtp->internal_unit_len;
|
||||
|
||||
/* For internal units we set the unit number to -1.
|
||||
Otherwise internal units can be mistaken for a pre-connected unit or
|
||||
some other file I/O unit. */
|
||||
iunit->unit_number = -1;
|
||||
|
||||
/* Set up the looping specification from the array descriptor, if any. */
|
||||
|
||||
|
|
@ -424,6 +429,23 @@ get_internal_unit (st_parameter_dt *dtp)
|
|||
}
|
||||
|
||||
|
||||
/* 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. */
|
||||
|
||||
|
|
@ -437,6 +459,7 @@ get_unit (st_parameter_dt *dtp, int do_create)
|
|||
/* 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);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -928,7 +928,8 @@ mem_truncate (unix_stream * s __attribute__ ((unused)))
|
|||
static try
|
||||
mem_close (unix_stream * s)
|
||||
{
|
||||
free_mem (s);
|
||||
if (s != NULL)
|
||||
free_mem (s);
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
|
|
|||
Loading…
Reference in New Issue