This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.
Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
---|---|---|
Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |
Other format: | [Raw text] |
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
Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
---|---|---|
Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |