From 6f34d6e078fafa8cdc99a2c3b98d5d8882c62303 Mon Sep 17 00:00:00 2001 From: Jerry DeLisle Date: Thu, 13 Apr 2006 06:24:58 +0000 Subject: [PATCH] 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/ChangeLog | 15 +++++ libgfortran/io/io.h | 5 +- libgfortran/io/transfer.c | 17 ++++-- libgfortran/io/unit.c | 122 ++++++++++++++++++++++++-------------- 4 files changed, 108 insertions(+), 51 deletions(-) diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 867645d2403..190d4a27687 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,18 @@ +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. + 2006-04-11 Jakub Jelinek * io/io.h (st_parameter_dt): Revert 2005-12-10 change to diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h index cfb94019633..eed15ae36e8 100644 --- a/libgfortran/io/io.h +++ b/libgfortran/io/io.h @@ -414,7 +414,10 @@ typedef struct st_parameter_dt /* A namelist specific flag used to enable reading input from line_buffer for logical reads. */ unsigned line_buffer_enabled : 1; - /* 18 unused bits. */ + /* 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; diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c index 6097c35d8a4..11be456f7ed 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 (); } diff --git a/libgfortran/io/unit.c b/libgfortran/io/unit.c index 337e10c44c3..81b128ee640 100644 --- a/libgfortran/io/unit.c +++ b/libgfortran/io/unit.c @@ -75,7 +75,7 @@ Boston, MA 02110-1301, USA. */ #define CACHE_SIZE 3 -static gfc_unit internal_unit, *unit_cache[CACHE_SIZE]; +static gfc_unit *unit_cache[CACHE_SIZE]; gfc_offset max_offset; gfc_unit *unit_root; #ifdef __GTHREAD_MUTEX_INIT @@ -260,12 +260,12 @@ delete_unit (gfc_unit * old) } -/* find_unit()-- Given an integer, return a pointer to the unit +/* 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 * -find_unit_1 (int n, int do_create) +get_external_unit (int n, int do_create) { gfc_unit *p; int c, created = 0; @@ -346,58 +346,99 @@ found: return p; } + gfc_unit * find_unit (int n) { - return find_unit_1 (n, 0); + return get_external_unit (n, 0); } + gfc_unit * find_or_create_unit (int n) { - return find_unit_1 (n, 1); + 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) - { - __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; - } + return get_internal_unit(dtp); /* Has to be an external unit */ - return find_unit_1 (dtp->common.unit, do_create); + dtp->u.p.unit_is_internal = 0; + + return get_external_unit (dtp->common.unit, do_create); } @@ -406,7 +447,7 @@ get_unit (st_parameter_dt *dtp, int do_create) int is_internal_unit (st_parameter_dt *dtp) { - return dtp->u.p.current_unit == &internal_unit; + return dtp->u.p.unit_is_internal; } @@ -432,15 +473,6 @@ init_units (void) __GTHREAD_MUTEX_INIT_FUNCTION (&unit_lock); #endif -#ifdef __GTHREAD_MUTEX_INIT - { - __gthread_mutex_t tmp = __GTHREAD_MUTEX_INIT; - internal_unit.lock = tmp; - } -#else - __GTHREAD_MUTEX_INIT_FUNCTION (&internal_unit.lock); -#endif - if (options.stdin_unit >= 0) { /* STDIN */ u = insert_unit (options.stdin_unit);