OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/48298 ([F03] User-Defined Derived-Type IO (DTIO)) 

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-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.

From-SVN: r240456
This commit is contained in:
Jerry DeLisle 2016-09-23 20:36:21 +00:00
parent 9f38dde230
commit 4a8d4422b0
17 changed files with 331 additions and 133 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
gcc/fortran/ChangeLog
View File

@ -1,3 +1,17 @@
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-

2
gcc/fortran/gfortran.h
View File

@ -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 */

6
gcc/fortran/io.c
View File

@ -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;
}

2
gcc/fortran/ioparm.def
View File

@ -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)

7
gcc/fortran/libgfortran.h
View File

@ -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. */

1
gcc/fortran/resolve.c
View File

@ -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. */

6
gcc/fortran/trans-io.c
View File

@ -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)

6
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,9 @@
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.

64
gcc/testsuite/gfortran.dg/dtio_14.f90 Normal file
View File

@ -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

1
gcc/testsuite/gfortran.dg/negative_unit_check.f90
View File

@ -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

39
libgfortran/ChangeLog
View File

@ -1,3 +1,42 @@
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

2
libgfortran/io/inquire.c
View File

@ -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)

27
libgfortran/io/io.h
View File

@ -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 */

4
libgfortran/io/list_read.c
View File

@ -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++)
{

2
libgfortran/io/open.c
View File

@ -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);

118
libgfortran/io/transfer.c
View File

@ -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;
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;
}
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);
}
free_ionml (dtp);
if (dtp->u.p.current_unit != NULL)
unlock_unit (dtp->u.p.current_unit);
free_internal_unit (dtp);
library_end ();
}

163
libgfortran/io/unit.c
View File

@ -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;