From 6f34d6e078fafa8cdc99a2c3b98d5d8882c62303 Mon Sep 17 00:00:00 2001 From: Jerry DeLisle Date: Thu, 13 Apr 2006 06:24:58 +0000 Subject: re PR fortran/26766 ([F2003] Recursive I/O still (again) broken) 2006-04-12 Jerry DeLisle 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. From-SVN: r112914 --- libgfortran/io/transfer.c | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) (limited to 'libgfortran/io/transfer.c') diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c index 6097c35..11be456 100644 --- a/libgfortran/io/transfer.c +++ b/libgfortran/io/transfer.c @@ -1619,7 +1619,8 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) 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)) + && 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. */ @@ -2317,6 +2318,8 @@ 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); library_end (); } @@ -2353,10 +2356,12 @@ st_write_done (st_parameter_dt *dtp) 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); - + 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; } @@ -2367,6 +2372,8 @@ 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); library_end (); } -- cgit v1.1