From 4a8d4422b01ffec7a3481083b80cfde910016777 Mon Sep 17 00:00:00 2001 From: Jerry DeLisle Date: Fri, 23 Sep 2016 20:36:21 +0000 Subject: [PATCH] re PR fortran/48298 ([F03] User-Defined Derived-Type IO (DTIO)) 2016-09-23 Jerry DeLisle PR libgfortran/48298 * io/inquire.c (inquire_via_unit): Adjust error check for the two possible internal unit KINDs. * io/io.h: Adjust defines for is_internal_unit and is_char4_unit. (gfc_unit): Add internal unit data to structure. (get_internal_unit): Change declaration to set_internal_unit. (free_internal_unit): Change name to stash_internal_unit_number. (get_unique_unit_number): Adjust parameter argument. Define IOPARM_DT_HAS_UDTIO. (gfc_saved_unit): New structure. * io/list_read.c (next_char_internal): Use is_char4_unit. * io/open.c (st_open): Adjust call to get_unique_unit_number. * io/transfer.c (write_block): Use is_char4_unit. (data_transfer_init): Update check for unit numbers. (st_read_done): Free the various allocated memories used for the internal units and stash the negative unit number and pointer to unit structure to allow reuse. (st_write_done): Likewise stash the freed unit. * io/unit.c: Create a fixed size buffer of 16 gfc_saved_unit's to use as a stack to save newunit unit numbers and unit structure for reuse. (get_external_unit): Change name to get_gfc_unit to better reflect what it does. (find_unit): Change call to get_gfc_unit. (find_or_create_unit): Likewise. (get_internal_unit): Change name to set_internal_unit. Move internal unit from the dtp structure to the gfc_unit structure so that it can be passed to child I/O statements through the UNIT. (free_internal_unit): Change name to stash_internal_unit_number. Push the common.unit number onto the newunit stack, saving it for possible reuse later. (get_unit): Set the internal unit KIND. Use get_unique_unit_number to get a negative unit number for the internal unit. Use get_gfc_unit to get the unit structure and use set_internal_unit to initialize it. (init_units): Initialize the newunit stack. (get_unique_unit_number): Check the stack for an available unit number and use it. If none there get the next most negative number. (close_units): Free any unit structures pointed to from the save stack. 2016-09-23 Jerry DeLisle PR fortran/48298 * gfortran.h (gfc_dt): Add *udtio. * ioparm.def: Add bit IOPARM_dt_f2003 to align with library use of bit 25. Add IOPARM_dt_dtio bit to common flags. * resolve.c (resolve_transfer): Set dt->udtio to expression. * io.c (gfc_match_inquire): Adjust error message for internal unit KIND. * libgfortran.h: Adjust defines for GFC_INTERNAL_UNIT4, GFC_INTERNAL_UNIT, and GFC_INVALID_UNIT. * trans-io.c (build_dt): Set common_unit to reflect the KIND of the internal unit. Set mask bit for presence of dt->udtio. 2016-09-23 Jerry DeLisle PR fortran/48298 * gfortran.dg/negative_unit_check.f90: Update test. * gfortran.dg/dtio_14.f90: New test. From-SVN: r240456 --- gcc/fortran/ChangeLog | 14 ++ gcc/fortran/gfortran.h | 2 +- gcc/fortran/io.c | 6 +- gcc/fortran/ioparm.def | 2 + gcc/fortran/libgfortran.h | 7 +- gcc/fortran/resolve.c | 1 + gcc/fortran/trans-io.c | 6 +- gcc/testsuite/ChangeLog | 6 + gcc/testsuite/gfortran.dg/dtio_14.f90 | 64 +++++++ .../gfortran.dg/negative_unit_check.f90 | 1 + libgfortran/ChangeLog | 39 +++++ libgfortran/io/inquire.c | 2 +- libgfortran/io/io.h | 27 ++- libgfortran/io/list_read.c | 4 +- libgfortran/io/open.c | 2 +- libgfortran/io/transfer.c | 112 +++++++----- libgfortran/io/unit.c | 163 ++++++++++-------- 17 files changed, 328 insertions(+), 130 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/dtio_14.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 7a99c39986f..daed721dbad 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,17 @@ +2016-09-23 Jerry DeLisle + + PR fortran/48298 + * gfortran.h (gfc_dt): Add *udtio. + * ioparm.def: Add bit IOPARM_dt_f2003 to align with library use of bit + 25. Add IOPARM_dt_dtio bit to common flags. + * resolve.c (resolve_transfer): Set dt->udtio to expression. + * io.c (gfc_match_inquire): Adjust error message for internal + unit KIND. + * libgfortran.h: Adjust defines for GFC_INTERNAL_UNIT4, + GFC_INTERNAL_UNIT, and GFC_INVALID_UNIT. + * trans-io.c (build_dt): Set common_unit to reflect the KIND of + the internal unit. Set mask bit for presence of dt->udtio. + 2016-09-22 Andre Vehreschild * trans-intrinsic.c (gfc_conv_intrinsic_caf_get): Use the old caf- diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 912f5fb3682..1837a53ddb8 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2332,7 +2332,7 @@ typedef struct { gfc_expr *io_unit, *format_expr, *rec, *advance, *iostat, *size, *iomsg, *id, *pos, *asynchronous, *blank, *decimal, *delim, *pad, *round, - *sign, *extra_comma, *dt_io_kind; + *sign, *extra_comma, *dt_io_kind, *udtio; gfc_symbol *namelist; /* A format_label of `format_asterisk' indicates the "*" format */ diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c index 53037e22a1b..48c15ef55f9 100644 --- a/gcc/fortran/io.c +++ b/gcc/fortran/io.c @@ -4256,9 +4256,11 @@ gfc_match_inquire (void) if (inquire->unit != NULL && inquire->unit->expr_type == EXPR_CONSTANT && inquire->unit->ts.type == BT_INTEGER - && mpz_get_si (inquire->unit->value.integer) == GFC_INTERNAL_UNIT) + && ((mpz_get_si (inquire->unit->value.integer) == GFC_INTERNAL_UNIT4) + || (mpz_get_si (inquire->unit->value.integer) == GFC_INTERNAL_UNIT))) { - gfc_error ("UNIT number in INQUIRE statement at %L can not be -1", &loc); + gfc_error ("UNIT number in INQUIRE statement at %L can not " + "be %d", &loc, (int) mpz_get_si (inquire->unit->value.integer)); goto cleanup; } diff --git a/gcc/fortran/ioparm.def b/gcc/fortran/ioparm.def index e448a921279..17b7ac78818 100644 --- a/gcc/fortran/ioparm.def +++ b/gcc/fortran/ioparm.def @@ -113,3 +113,5 @@ IOPARM (dt, delim, 1 << 21, char2) IOPARM (dt, pad, 1 << 22, char1) IOPARM (dt, round, 1 << 23, char2) IOPARM (dt, sign, 1 << 24, char1) +#define IOPARM_dt_f2003 (1 << 25) +#define IOPARM_dt_dtio (1 << 26) diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h index e9132506367..cc355086cae 100644 --- a/gcc/fortran/libgfortran.h +++ b/gcc/fortran/libgfortran.h @@ -68,10 +68,11 @@ along with GCC; see the file COPYING3. If not see | GFC_RTCHECK_RECURSION | GFC_RTCHECK_DO \ | GFC_RTCHECK_POINTER | GFC_RTCHECK_MEM) -/* Special unit numbers used to convey certain conditions. Numbers -3 +/* Special unit numbers used to convey certain conditions. Numbers -4 thru -9 available. NEWUNIT values start at -10. */ -#define GFC_INTERNAL_UNIT -1 -#define GFC_INVALID_UNIT -2 +#define GFC_INTERNAL_UNIT4 -1 /* KIND=4 Internal Unit. */ +#define GFC_INTERNAL_UNIT -2 /* KIND=1 Internal Unit. */ +#define GFC_INVALID_UNIT -3 /* Possible values for the CONVERT I/O specifier. */ /* Keep in sync with GFC_FLAG_CONVERT_* in gcc/flags.h. */ diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 11b6a14824b..9998302714a 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -8739,6 +8739,7 @@ resolve_transfer (gfc_code *code) if (dtio_sub != NULL && exp->expr_type == EXPR_VARIABLE) { + dt->udtio = exp; sym = exp->symtree->n.sym->ns->proc_name; /* Check to see if this is a nested DTIO call, with the dummy as the io-list object. */ diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index 2c843497295..c0559f36237 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -1808,7 +1808,8 @@ build_dt (tree function, gfc_code * code) mask |= set_internal_unit (&block, &post_iu_block, var, dt->io_unit); set_parameter_const (&block, var, IOPARM_common_unit, - dt->io_unit->ts.kind == 1 ? 0 : -1); + dt->io_unit->ts.kind == 1 ? + GFC_INTERNAL_UNIT : GFC_INTERNAL_UNIT4); } } else @@ -1892,6 +1893,9 @@ build_dt (tree function, gfc_code * code) mask |= set_parameter_ref (&block, &post_end_block, var, IOPARM_dt_size, dt->size); + if (dt->udtio) + mask |= IOPARM_dt_dtio; + if (dt->namelist) { if (dt->format_expr || dt->format_label) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 6ac5436fc2c..09b6599c43a 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2016-09-23 Jerry DeLisle + + PR fortran/48298 + * gfortran.dg/negative_unit_check.f90: Update test. + * gfortran.dg/dtio_14.f90: New test. + 2016-09-23 Dominik Vogt * gcc.target/s390/hotpatch-compile-1.c: Fixed dg-error test. diff --git a/gcc/testsuite/gfortran.dg/dtio_14.f90 b/gcc/testsuite/gfortran.dg/dtio_14.f90 new file mode 100644 index 00000000000..16d5b1e40c9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dtio_14.f90 @@ -0,0 +1,64 @@ +! { dg-do run } +! +! Functional test of User Defined Derived Type IO with typebound bindings +! This version tests IO to internal character units. +! +MODULE p + TYPE :: person + CHARACTER (LEN=20) :: name + INTEGER(4) :: age + CONTAINS + procedure :: pwf + procedure :: prf + GENERIC :: WRITE(FORMATTED) => pwf + GENERIC :: READ(FORMATTED) => prf + END TYPE person +CONTAINS + SUBROUTINE pwf (dtv,unit,iotype,vlist,iostat,iomsg) + CLASS(person), INTENT(IN) :: dtv + INTEGER, INTENT(IN) :: unit + CHARACTER (LEN=*), INTENT(IN) :: iotype + INTEGER, INTENT(IN) :: vlist(:) + INTEGER, INTENT(OUT) :: iostat + CHARACTER (LEN=*), INTENT(INOUT) :: iomsg + WRITE(unit, FMT = *, IOSTAT=iostat) dtv%name, dtv%age + END SUBROUTINE pwf + + SUBROUTINE prf (dtv,unit,iotype,vlist,iostat,iomsg) + CLASS(person), INTENT(INOUT) :: dtv + INTEGER, INTENT(IN) :: unit + CHARACTER (LEN=*), INTENT(IN) :: iotype + INTEGER, INTENT(IN) :: vlist(:) + INTEGER, INTENT(OUT) :: iostat + CHARACTER (LEN=*), INTENT(INOUT) :: iomsg + READ (UNIT = UNIT, FMT = *) dtv%name, dtv%age + END SUBROUTINE prf +END MODULE p + +PROGRAM test + USE p + TYPE (person) :: chairman, answer + character(kind=1,len=80) :: str1 + character(kind=4,len=80) :: str4 + str1 = "" + str4 = 4_"" + chairman%name="Charlie" + chairman%age=62 + answer = chairman +! KIND=1 test + write (str1, *) chairman + if (trim(str1).ne." Charlie 62") call abort + chairman%name="Bogus" + chairman%age=99 + read (str1, *) chairman + if (chairman%name.ne.answer%name) call abort + if (chairman%age.ne.answer%age) call abort +! KIND=4 test + write (str4, *) chairman + if (trim(str4).ne.4_" Charlie 62") call abort + chairman%name="Bogus" + chairman%age=99 + read (str4, *) chairman + if (chairman%name.ne.answer%name) call abort + if (chairman%age.ne.answer%age) call abort +END PROGRAM test diff --git a/gcc/testsuite/gfortran.dg/negative_unit_check.f90 b/gcc/testsuite/gfortran.dg/negative_unit_check.f90 index 2a1b16c1093..002b5b4ac82 100644 --- a/gcc/testsuite/gfortran.dg/negative_unit_check.f90 +++ b/gcc/testsuite/gfortran.dg/negative_unit_check.f90 @@ -2,4 +2,5 @@ ! Test case from PR61933. LOGICAL :: file_exists INQUIRE(UNIT=-1,EXIST=file_exists)! { dg-error "can not be -1" } + INQUIRE(UNIT=-2,EXIST=file_exists)! { dg-error "can not be -2" } END diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 3edd9eda2d5..f312a066c18 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,42 @@ +2016-09-23 Jerry DeLisle + + PR libgfortran/48298 + * io/inquire.c (inquire_via_unit): Adjust error check for the + two possible internal unit KINDs. + * io/io.h: Adjust defines for is_internal_unit and + is_char4_unit. (gfc_unit): Add internal unit data to structure. + (get_internal_unit): Change declaration to set_internal_unit. + (free_internal_unit): Change name to stash_internal_unit_number. + (get_unique_unit_number): Adjust parameter argument. + Define IOPARM_DT_HAS_UDTIO. (gfc_saved_unit): New structure. + * io/list_read.c (next_char_internal): Use is_char4_unit. + * io/open.c (st_open): Adjust call to get_unique_unit_number. + * io/transfer.c (write_block): Use is_char4_unit. + (data_transfer_init): Update check for unit numbers. + (st_read_done): Free the various allocated memories used for the + internal units and stash the negative unit number and pointer to unit + structure to allow reuse. (st_write_done): Likewise stash the freed + unit. + * io/unit.c: Create a fixed size buffer of 16 gfc_saved_unit's to use + as a stack to save newunit unit numbers and unit structure for reuse. + (get_external_unit): Change name to get_gfc_unit to better + reflect what it does. (find_unit): Change call to get_gfc_unit. + (find_or_create_unit): Likewise. (get_internal_unit): Change + name to set_internal_unit. Move internal unit from the dtp + structure to the gfc_unit structure so that it can be passed to + child I/O statements through the UNIT. + (free_internal_unit): Change name to stash_internal_unit_number. + Push the common.unit number onto the newunit stack, saving it + for possible reuse later. (get_unit): Set the internal unit + KIND. Use get_unique_unit_number to get a negative unit number + for the internal unit. Use get_gfc_unit to get the unit structure + and use set_internal_unit to initialize it. + (init_units): Initialize the newunit stack. + (get_unique_unit_number): Check the stack for an available unit + number and use it. If none there get the next most negative + number. (close_units): Free any unit structures pointed to from the save + stack. + 2016-09-21 Janne Blomqvist * intrinsics/random.c (getosrandom): Use rand_s() on diff --git a/libgfortran/io/inquire.c b/libgfortran/io/inquire.c index ae5ba622592..2bb518b69c7 100644 --- a/libgfortran/io/inquire.c +++ b/libgfortran/io/inquire.c @@ -41,7 +41,7 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u) const char *p; GFC_INTEGER_4 cf = iqp->common.flags; - if (iqp->common.unit == GFC_INTERNAL_UNIT) + if (iqp->common.unit == GFC_INTERNAL_UNIT || iqp->common.unit == GFC_INTERNAL_UNIT4) generate_error (&iqp->common, LIBERROR_INQUIRE_INTERNAL_UNIT, NULL); if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0) diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h index ff75741effd..87c35583754 100644 --- a/libgfortran/io/io.h +++ b/libgfortran/io/io.h @@ -69,11 +69,11 @@ internal_proto(old_locale_lock); #define is_array_io(dtp) ((dtp)->internal_unit_desc) -#define is_internal_unit(dtp) ((dtp)->u.p.unit_is_internal) +#define is_internal_unit(dtp) ((dtp)->u.p.current_unit->internal_unit_kind) #define is_stream_io(dtp) ((dtp)->u.p.current_unit->flags.access == ACCESS_STREAM) -#define is_char4_unit(dtp) ((dtp)->u.p.unit_is_internal && (dtp)->common.unit) +#define is_char4_unit(dtp) ((dtp)->u.p.current_unit->internal_unit_kind == 4) /* The array_loop_spec contains the variables for the loops over index ranges that are encountered. */ @@ -409,6 +409,7 @@ st_parameter_inquire; #define IOPARM_DT_HAS_ROUND (1 << 23) #define IOPARM_DT_HAS_SIGN (1 << 24) #define IOPARM_DT_HAS_F2003 (1 << 25) +#define IOPARM_DT_HAS_UDTIO (1 << 26) /* Internal use bit. */ #define IOPARM_DT_IONML_SET (1u << 31) @@ -640,12 +641,24 @@ typedef struct gfc_unit int (*next_char_fn_ptr) (st_parameter_dt *); void (*push_char_fn_ptr) (st_parameter_dt *, int); + /* Internal unit char string data. */ + char * internal_unit; + gfc_charlen_type internal_unit_len; + gfc_array_char *string_unit_desc; + int internal_unit_kind; + /* DTIO Parent/Child procedure, 0 = parent, >0 = child level. */ int child_dtio; int last_char; } gfc_unit; +typedef struct gfc_saved_unit +{ + GFC_INTEGER_4 unit_number; + gfc_unit *unit; +} +gfc_saved_unit; /* unit.c */ @@ -663,11 +676,11 @@ 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 gfc_unit *set_internal_unit (st_parameter_dt *, gfc_unit *, int); +internal_proto(set_internal_unit); -extern void free_internal_unit (st_parameter_dt *); -internal_proto(free_internal_unit); +extern void stash_internal_unit (st_parameter_dt *); +internal_proto(stash_internal_unit); extern gfc_unit *find_unit (int); internal_proto(find_unit); @@ -687,7 +700,7 @@ internal_proto (finish_last_advance_record); extern int unit_truncate (gfc_unit *, gfc_offset, st_parameter_common *); internal_proto (unit_truncate); -extern GFC_INTEGER_4 get_unique_unit_number (st_parameter_open *); +extern GFC_INTEGER_4 get_unique_unit_number (st_parameter_common *); internal_proto(get_unique_unit_number); /* open.c */ diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c index a42f12b7269..f258c9d9249 100644 --- a/libgfortran/io/list_read.c +++ b/libgfortran/io/list_read.c @@ -267,7 +267,7 @@ next_char_internal (st_parameter_dt *dtp) /* Get the next character and handle end-of-record conditions. */ - if (dtp->common.unit) /* Check for kind=4 internal unit. */ + if (is_char4_unit(dtp)) /* Check for kind=4 internal unit. */ length = sread (dtp->u.p.current_unit->s, &c, 1); else { @@ -390,7 +390,7 @@ eat_spaces (st_parameter_dt *dtp) gfc_offset offset = stell (dtp->u.p.current_unit->s); gfc_offset i; - if (dtp->common.unit) /* kind=4 */ + if (is_char4_unit(dtp)) /* kind=4 */ { for (i = 0; i < dtp->u.p.current_unit->bytes_left; i++) { diff --git a/libgfortran/io/open.c b/libgfortran/io/open.c index d1591898185..d074b020d81 100644 --- a/libgfortran/io/open.c +++ b/libgfortran/io/open.c @@ -812,7 +812,7 @@ st_open (st_parameter_open *opp) if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK) { if ((opp->common.flags & IOPARM_OPEN_HAS_NEWUNIT)) - opp->common.unit = get_unique_unit_number(opp); + opp->common.unit = get_unique_unit_number(&opp->common); else if (opp->common.unit < 0) { u = find_unit (opp->common.unit); diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c index 98072d0b889..6009c123d71 100644 --- a/libgfortran/io/transfer.c +++ b/libgfortran/io/transfer.c @@ -737,7 +737,7 @@ write_block (st_parameter_dt *dtp, int length) if (is_internal_unit (dtp)) { - if (dtp->common.unit) /* char4 internel unit. */ + if (is_char4_unit(dtp)) /* char4 internel unit. */ { gfc_char4_t *dest4; dest4 = mem_alloc_w4 (dtp->u.p.current_unit->s, &length); @@ -2606,7 +2606,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag) st_parameter_open opp; unit_convert conv; - if (dtp->common.unit < 0) + if (dtp->common.unit < 0 && !is_internal_unit (dtp)) { close_unit (dtp->u.p.current_unit); dtp->u.p.current_unit = NULL; @@ -3943,18 +3943,34 @@ st_read_done (st_parameter_dt *dtp) { finalize_transfer (dtp); - if (is_internal_unit (dtp) || dtp->u.p.format_not_saved) - { - free_format_data (dtp->u.p.fmt); - free_format (dtp); - } - free_ionml (dtp); - if (dtp->u.p.current_unit != NULL) - unlock_unit (dtp->u.p.current_unit); - - free_internal_unit (dtp); + /* If this is a parent READ statement we do not need to retain the + internal unit structure for child use. Free it and stash the unit + number for reuse. */ + if (dtp->u.p.current_unit != NULL + && dtp->u.p.current_unit->child_dtio == 0) + { + if (is_internal_unit (dtp) && + (dtp->common.flags & IOPARM_DT_HAS_UDTIO) == 0) + { + free (dtp->u.p.current_unit->filename); + dtp->u.p.current_unit->filename = NULL; + free_format_hash_table (dtp->u.p.current_unit); + free (dtp->u.p.current_unit->s); + dtp->u.p.current_unit->s = NULL; + if (dtp->u.p.current_unit->ls) + free (dtp->u.p.current_unit->ls); + dtp->u.p.current_unit->ls = NULL; + stash_internal_unit (dtp); + } + if (is_internal_unit (dtp) || dtp->u.p.format_not_saved) + { + free_format_data (dtp->u.p.fmt); + free_format (dtp); + } + unlock_unit (dtp->u.p.current_unit); + } library_end (); } @@ -3977,43 +3993,55 @@ st_write_done (st_parameter_dt *dtp) { finalize_transfer (dtp); - /* Deal with endfile conditions associated with sequential files. */ - if (dtp->u.p.current_unit != NULL - && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL && dtp->u.p.current_unit->child_dtio == 0) - switch (dtp->u.p.current_unit->endfile) - { - case AT_ENDFILE: /* Remain at the endfile record. */ - break; - - case AFTER_ENDFILE: - dtp->u.p.current_unit->endfile = AT_ENDFILE; /* Just at it now. */ - break; - - case NO_ENDFILE: - /* Get rid of whatever is after this record. */ - if (!is_internal_unit (dtp)) - unit_truncate (dtp->u.p.current_unit, - stell (dtp->u.p.current_unit->s), - &dtp->common); - dtp->u.p.current_unit->endfile = AT_ENDFILE; - break; - } - - if (is_internal_unit (dtp) || dtp->u.p.format_not_saved) { - free_format_data (dtp->u.p.fmt); - free_format (dtp); - } + /* Deal with endfile conditions associated with sequential files. */ + if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL) + switch (dtp->u.p.current_unit->endfile) + { + case AT_ENDFILE: /* Remain at the endfile record. */ + break; - free_ionml (dtp); + case AFTER_ENDFILE: + dtp->u.p.current_unit->endfile = AT_ENDFILE; /* Just at it now. */ + break; - if (dtp->u.p.current_unit != NULL) - unlock_unit (dtp->u.p.current_unit); + case NO_ENDFILE: + /* Get rid of whatever is after this record. */ + if (!is_internal_unit (dtp)) + unit_truncate (dtp->u.p.current_unit, + stell (dtp->u.p.current_unit->s), + &dtp->common); + dtp->u.p.current_unit->endfile = AT_ENDFILE; + break; + } - free_internal_unit (dtp); + free_ionml (dtp); + /* If this is a parent WRITE statement we do not need to retain the + internal unit structure for child use. Free it and stash the + unit number for reuse. */ + if (is_internal_unit (dtp) && + (dtp->common.flags & IOPARM_DT_HAS_UDTIO) == 0) + { + free (dtp->u.p.current_unit->filename); + dtp->u.p.current_unit->filename = NULL; + free_format_hash_table (dtp->u.p.current_unit); + free (dtp->u.p.current_unit->s); + dtp->u.p.current_unit->s = NULL; + if (dtp->u.p.current_unit->ls) + free (dtp->u.p.current_unit->ls); + dtp->u.p.current_unit->ls = NULL; + stash_internal_unit (dtp); + } + if (is_internal_unit (dtp) || dtp->u.p.format_not_saved) + { + free_format_data (dtp->u.p.fmt); + free_format (dtp); + } + unlock_unit (dtp->u.p.current_unit); + } library_end (); } diff --git a/libgfortran/io/unit.c b/libgfortran/io/unit.c index fde9ac752d4..274b24b686e 100644 --- a/libgfortran/io/unit.c +++ b/libgfortran/io/unit.c @@ -72,8 +72,15 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see /* Unit number to be assigned when NEWUNIT is used in an OPEN statement. */ #define GFC_FIRST_NEWUNIT -10 +#define NEWUNIT_STACK_SIZE 16 static GFC_INTEGER_4 next_available_newunit = GFC_FIRST_NEWUNIT; +/* A stack to save previously used newunit-assigned unit numbers to + allow them to be reused without reallocating the gfc_unit structure + which is still in the treap. */ +static gfc_saved_unit newunit_stack[NEWUNIT_STACK_SIZE]; +static int newunit_tos = 0; /* Index to Top of Stack. */ + #define CACHE_SIZE 3 static gfc_unit *unit_cache[CACHE_SIZE]; gfc_offset max_offset; @@ -294,12 +301,12 @@ delete_unit (gfc_unit * old) } -/* get_external_unit()-- Given an integer, return a pointer to the unit +/* get_gfc_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) +get_gfc_unit (int n, int do_create) { gfc_unit *p; int c, created = 0; @@ -361,6 +368,7 @@ found: inc_waiting_locked (p); } + __gthread_mutex_unlock (&unit_lock); if (p != NULL && (p->child_dtio == 0)) @@ -384,14 +392,14 @@ found: gfc_unit * find_unit (int n) { - return get_external_unit (n, 0); + return get_gfc_unit (n, 0); } gfc_unit * find_or_create_unit (int n) { - return get_external_unit (n, 1); + return get_gfc_unit (n, 1); } @@ -426,31 +434,14 @@ is_trim_ok (st_parameter_dt *dtp) gfc_unit * -get_internal_unit (st_parameter_dt *dtp) +set_internal_unit (st_parameter_dt *dtp, gfc_unit *iunit, int kind) { - gfc_unit * iunit; gfc_offset start_record = 0; - /* Allocate memory for a unit structure. */ - - iunit = xcalloc (1, sizeof (gfc_unit)); - -#ifdef __GTHREAD_MUTEX_INIT - { - __gthread_mutex_t tmp = __GTHREAD_MUTEX_INIT; - iunit->lock = tmp; - } -#else - __GTHREAD_MUTEX_INIT_FUNCTION (&iunit->lock); -#endif - __gthread_mutex_lock (&iunit->lock); - 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; + iunit->internal_unit = dtp->internal_unit; + iunit->internal_unit_len = dtp->internal_unit_len; + iunit->internal_unit_kind = kind; /* As an optimization, adjust the unit record length to not include trailing blanks. This will not work under certain conditions @@ -458,14 +449,14 @@ get_internal_unit (st_parameter_dt *dtp) if (dtp->u.p.mode == READING && is_trim_ok (dtp)) { int len; - if (dtp->common.unit == 0) - len = string_len_trim (dtp->internal_unit_len, - dtp->internal_unit); + if (kind == 1) + len = string_len_trim (iunit->internal_unit_len, + iunit->internal_unit); else - len = string_len_trim_char4 (dtp->internal_unit_len, - (const gfc_char4_t*) dtp->internal_unit); - dtp->internal_unit_len = len; - iunit->recl = dtp->internal_unit_len; + len = string_len_trim_char4 (iunit->internal_unit_len, + (const gfc_char4_t*) iunit->internal_unit); + iunit->internal_unit_len = len; + iunit->recl = iunit->internal_unit_len; } /* Set up the looping specification from the array descriptor, if any. */ @@ -475,22 +466,19 @@ get_internal_unit (st_parameter_dt *dtp) iunit->rank = GFC_DESCRIPTOR_RANK (dtp->internal_unit_desc); iunit->ls = (array_loop_spec *) xmallocarray (iunit->rank, sizeof (array_loop_spec)); - dtp->internal_unit_len *= + iunit->internal_unit_len *= init_loop_spec (dtp->internal_unit_desc, iunit->ls, &start_record); start_record *= iunit->recl; } /* Set initial values for unit parameters. */ - if (dtp->common.unit) - { - iunit->s = open_internal4 (dtp->internal_unit - start_record, - dtp->internal_unit_len, -start_record); - fbuf_init (iunit, 256); - } + if (kind == 4) + iunit->s = open_internal4 (iunit->internal_unit - start_record, + iunit->internal_unit_len, -start_record); else - iunit->s = open_internal (dtp->internal_unit - start_record, - dtp->internal_unit_len, -start_record); + iunit->s = open_internal (iunit->internal_unit - start_record, + iunit->internal_unit_len, -start_record); iunit->bytes_left = iunit->recl; iunit->last_record=0; @@ -522,33 +510,22 @@ get_internal_unit (st_parameter_dt *dtp) dtp->u.p.pending_spaces = 0; dtp->u.p.max_pos = 0; dtp->u.p.at_eof = 0; - - /* This flag tells us the unit is assigned to internal I/O. */ - - dtp->u.p.unit_is_internal = 1; - return iunit; } -/* free_internal_unit()-- Free memory allocated for internal units if any. */ +/* stash_internal_unit()-- Push the internal unit number onto the + avaialble stack. */ void -free_internal_unit (st_parameter_dt *dtp) +stash_internal_unit (st_parameter_dt *dtp) { - if (!is_internal_unit (dtp)) - return; - - if (unlikely (is_char4_unit (dtp))) - fbuf_destroy (dtp->u.p.current_unit); - - if (dtp->u.p.current_unit != NULL) - { - free (dtp->u.p.current_unit->ls); - - free (dtp->u.p.current_unit->s); - - destroy_unit_mutex (dtp->u.p.current_unit); - } + __gthread_mutex_lock (&unit_lock); + newunit_tos++; + if (newunit_tos >= NEWUNIT_STACK_SIZE) + internal_error (&dtp->common, "stash_internal_unit(): Stack Size Exceeded"); + newunit_stack[newunit_tos].unit_number = dtp->common.unit; + newunit_stack[newunit_tos].unit = dtp->u.p.current_unit; + __gthread_mutex_unlock (&unit_lock); } @@ -559,16 +536,51 @@ free_internal_unit (st_parameter_dt *dtp) gfc_unit * get_unit (st_parameter_dt *dtp, int do_create) { + gfc_unit * unit; if ((dtp->common.flags & IOPARM_DT_HAS_INTERNAL_UNIT) != 0) - return get_internal_unit (dtp); + { + int kind; + if (dtp->common.unit == GFC_INTERNAL_UNIT) + kind = 1; + else if (dtp->common.unit == GFC_INTERNAL_UNIT4) + kind = 4; + else + internal_error (&dtp->common, "get_unit(): Bad internal unit KIND"); + if ((dtp->common.flags & IOPARM_DT_HAS_UDTIO) != 0) + { + dtp->u.p.unit_is_internal = 1; + dtp->common.unit = get_unique_unit_number (&dtp->common); + unit = get_gfc_unit (dtp->common.unit, do_create); + set_internal_unit (dtp, unit, kind); + fbuf_init (unit, 128); + return unit; + } + else + { + if (newunit_tos) + { + dtp->common.unit = newunit_stack[newunit_tos].unit_number; + unit = newunit_stack[newunit_tos--].unit; + unit->fbuf->act = unit->fbuf->pos = 0; + } + else + { + dtp->common.unit = get_unique_unit_number (&dtp->common); + unit = xcalloc (1, sizeof (gfc_unit)); + fbuf_init (unit, 128); + } + set_internal_unit (dtp, unit, kind); + return unit; + } + } /* Has to be an external unit. */ - dtp->u.p.unit_is_internal = 0; + dtp->internal_unit = NULL; dtp->internal_unit_desc = NULL; - - return get_external_unit (dtp->common.unit, do_create); + unit = get_gfc_unit (dtp->common.unit, do_create); + return unit; } @@ -687,6 +699,10 @@ init_units (void) max_offset = 0; for (i = 0; i < sizeof (max_offset) * 8 - 1; i++) max_offset = max_offset + ((gfc_offset) 1 << i); + + /* Initialize the newunit stack. */ + memset (newunit_stack, 0, NEWUNIT_STACK_SIZE * sizeof(gfc_saved_unit)); + newunit_tos = 0; } @@ -765,6 +781,13 @@ close_units (void) close_unit_1 (unit_root, 1); __gthread_mutex_unlock (&unit_lock); + while (newunit_tos != 0) + if (newunit_stack[newunit_tos].unit) + { + fbuf_destroy (newunit_stack[newunit_tos].unit); + free (newunit_stack[newunit_tos].unit->s); + free (newunit_stack[newunit_tos--].unit); + } #ifdef HAVE_FREELOCALE freelocale (c_locale); #endif @@ -862,9 +885,10 @@ finish_last_advance_record (gfc_unit *u) fbuf_flush (u, u->mode); } -/* Assign a negative number for NEWUNIT in OPEN statements. */ +/* Assign a negative number for NEWUNIT in OPEN statements or for + internal units. */ GFC_INTEGER_4 -get_unique_unit_number (st_parameter_open *opp) +get_unique_unit_number (st_parameter_common *common) { GFC_INTEGER_4 num; @@ -875,11 +899,10 @@ get_unique_unit_number (st_parameter_open *opp) num = next_available_newunit--; __gthread_mutex_unlock (&unit_lock); #endif - /* Do not allow NEWUNIT numbers to wrap. */ if (num > GFC_FIRST_NEWUNIT) { - generate_error (&opp->common, LIBERROR_INTERNAL, "NEWUNIT exhausted"); + generate_error (common, LIBERROR_INTERNAL, "NEWUNIT exhausted"); return 0; } return num; -- 2.30.2