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 <jvdelisle@gcc.gnu.org>
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 <jvdelisle@gcc.gnu.org>
PR fortran/48298
* gfortran.dg/negative_unit_check.f90: Update test.
* gfortran.dg/dtio_14.f90: New test.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@240456
138bc75d-0d04-0410-961f-
82ee72b054a4
+2016-09-23 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+
+ 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 <vehre@gcc.gnu.org>
* trans-intrinsic.c (gfc_conv_intrinsic_caf_get): Use the old caf-
{
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 */
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;
}
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)
| 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. */
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. */
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
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)
+2016-09-23 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+
+ PR fortran/48298
+ * gfortran.dg/negative_unit_check.f90: Update test.
+ * gfortran.dg/dtio_14.f90: New test.
+
2016-09-23 Dominik Vogt <vogt@linux.vnet.ibm.com>
* gcc.target/s390/hotpatch-compile-1.c: Fixed dg-error test.
--- /dev/null
+! { 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
! 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
+2016-09-23 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+
+ 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 <jb@gcc.gnu.org>
* intrinsics/random.c (getosrandom): Use rand_s() on
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)
#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. */
#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)
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 */
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);
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 */
/* 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
{
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++)
{
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);
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);
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;
{
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 ();
}
{
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 ();
}
/* 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;
}
-/* 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;
inc_waiting_locked (p);
}
+
__gthread_mutex_unlock (&unit_lock);
if (p != NULL && (p->child_dtio == 0))
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);
}
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
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. */
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;
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);
}
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;
}
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;
}
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
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;
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;
projects / thirdparty / gcc.git / commitdiff
