OSDN Git Service

gcc/fortran/
authorjakub <jakub@138bc75d-0d04-0410-961f-82ee72b054a4>
Mon, 21 Nov 2005 22:03:56 +0000 (22:03 +0000)
committerjakub <jakub@138bc75d-0d04-0410-961f-82ee72b054a4>
Mon, 21 Nov 2005 22:03:56 +0000 (22:03 +0000)
PR fortran/14943
PR fortran/21647
* Make-lang.in (fortran/trans-io.o): Depend on fortran/ioparm.def.
* dump-parse-tree.c (gfc_show_code_node): Dump c->block for
EXEC_{READ,WRITE,IOLENGTH} nodes.
* io.c (terminate_io, match_io, gfc_match_inquire): Put data
transfer commands into EXEC_{READ,WRITE,IOLENGTH}'s code->block.
* resolve.c (resolve_blocks): Handle EXEC_{READ,WRITE,IOLENGTH}.
* trans-io.c (ioparm_unit, ioparm_err, ioparm_end, ioparm_eor,
ioparm_list_format, ioparm_library_return, ioparm_iostat,
ioparm_exist, ioparm_opened, ioparm_number, ioparm_named,
ioparm_rec, ioparm_nextrec, ioparm_size, ioparm_recl_in,
ioparm_recl_out, ioparm_iolength, ioparm_file, ioparm_file_len,
ioparm_status, ioparm_status_len, ioparm_access, ioparm_access_len,
ioparm_form, ioparm_form_len, ioparm_blank, ioparm_blank_len,
ioparm_position, ioparm_position_len, ioparm_action,
ioparm_action_len, ioparm_delim, ioparm_delim_len, ioparm_pad,
ioparm_pad_len, ioparm_format, ioparm_format_len, ioparm_advance,
ioparm_advance_len, ioparm_name, ioparm_name_len,
ioparm_internal_unit, ioparm_internal_unit_len,
ioparm_internal_unit_desc, ioparm_sequential, ioparm_sequential_len,
ioparm_direct, ioparm_direct_len, ioparm_formatted,
ioparm_formatted_len, ioparm_unformatted, ioparm_unformatted_len,
ioparm_read, ioparm_read_len, ioparm_write, ioparm_write_len,
ioparm_readwrite, ioparm_readwrite_len, ioparm_namelist_name,
ioparm_namelist_name_len, ioparm_namelist_read_mode, ioparm_iomsg,
ioparm_iomsg_len, ioparm_var): Remove.
(enum ioparam_type, enum iofield_type, enum iofield,
enum iocall): New enums.
(gfc_st_parameter_field, gfc_st_parameter): New typedefs.
(st_parameter, st_parameter_field, iocall): New variables.
(ADD_FIELD, ADD_STRING): Remove.
(dt_parm, dt_post_end_block): New variables.
(gfc_build_st_parameter): New function.
(gfc_build_io_library_fndecls): Use it.  Initialize iocall
array rather than ioparm_*, add extra first arguments to
the function types.
(set_parameter_const): New function.
(set_parameter_value): Add type argument, return a bitmask.
Changed to set a field in automatic structure variable rather
than set a field in a global _gfortran_ioparm variable.
(set_parameter_ref): Likewise.  If requested var has different
size than what field should point to, call with a temporary and
then copy into the user variable.  Add postblock argument.
(set_string): Remove var_len argument, add type argument, return
a bitmask.  Changed to set fields in automatic structure variable
rather than set a field in a global _gfortran_ioparm variable.
(set_internal_unit): Remove iunit, iunit_len, iunit_desc arguments,
add var argument.  Return a bitmask.  Changed to set fields in
automatic structure variable rather than set a field in a global
_gfortran_ioparm variable.
(set_flag): Removed.
(io_result): Add var argument.  Changed to read common.flags field
from automatic structure variable and bitwise AND it with 3.
(set_error_locus): Add var argument.  Changed to set fields in
automatic structure variable rather than set a field in a global
_gfortran_{filename,line} variables.
(gfc_trans_open): Use gfc_start_block rather than gfc_init_block.
Create a temporary st_parameter_* structure.  Adjust callers of
all above mentioned functions.  Pass address of the temporary
variable as first argument to the generated function call.
Use iocall array rather than ioparm_* separate variables.
(gfc_trans_close, build_filepos, gfc_trans_inquire): Likewise.
(build_dt): Likewise.  Change first argument to tree from tree *.
Don't dereference code->ext.dt if last_dt == INQUIRE.  Emit
IOLENGTH argument setup here.  Set dt_parm/dt_post_end_block
variables and gfc_trans_code the nested data transfer commands
in code->block.
(gfc_trans_iolength): Just set last_dt and call build_dt immediately.
(transfer_namelist_element): Pass address of dt_parm variable
to generated functions.  Use iocall array rather than ioparm_*
separate variables.
(gfc_trans_backspace, gfc_trans_endfile, gfc_trans_rewind,
gfc_trans_flush, gfc_trans_read, gfc_trans_write): Use iocall array
rather than ioparm_* separate variables.
(gfc_trans_dt_end): Likewise.  Pass address of dt_parm variable
as first argument to generated function.  Adjust io_result caller.
Prepend dt_post_end_block before io_result code.
(transfer_expr): Use iocall array rather than ioparm_* separate
variables.  Pass address of dt_parm variables as first argument
to generated functions.
* ioparm.def: New file.
gcc/testsuite/
PR fortran/24774
* gfortran.dg/inquire_9.f90: New test.

PR fortran/21647
* gfortran.fortran-torture/execute/inquire_5.f90: New test.
libgfortran/
PR fortran/24774
PR fortran/14943
PR fortran/21647
* Makefile.am (AM_CPPFLAGS): Add gcc directories as -I paths,
add -D_GNU_SOURCE.
* Makefile.in: Regenerated.
* acinclude.m4 (LIBGFOR_CHECK_SYNC_FETCH_AND_ADD,
LIBGFOR_CHECK_GTHR_DEFAULT, LIBGFOR_CHECK_PRAGMA_WEAK): New macros.
* configure.ac: Add them.
* configure: Rebuilt.
* config.h.in: Rebuilt.
* libtool-version: Bump libgfortran.so SONAME to libgfortran.so.1.
* libgfortran.h (library_start, show_locus, internal_error,
generate_error, find_option): Add st_parameter_common * argument.
(library_end): Change into a dummy macro.
* io/io.h: Include gthr.h.
(SUPPORTS_WEAK): Define if HAVE_PRAGMA_WEAK.
(CHARACTER): Remove define.
(st_parameter, global_t): Remove typedef.
(ioparm, g, ionml, current_unit): Remove variables.
(init_error_stream): Remove prototype.
(CHARACTER1, CHARACTER2): Define.
(st_parameter_common, st_parameter_open, st_parameter_close,
st_parameter_filepos, st_parameter_inquire, st_parameter_dt): New
typedefs.
(IOPARM_LIBRETURN_MASK, IOPARM_LIBRETURN_OK, IOPARM_LIBRETURN_ERROR,
IOPARM_LIBRETURN_END, IOPARM_LIBRETURN_EOR, IOPARM_ERR, IOPARM_END,
IOPARM_EOR, IOPARM_HAS_IOSTAT, IOPARM_HAS_IOMSG, IOPARM_COMMON_MASK,
IOPARM_OPEN_HAS_RECL_IN, IOPARM_OPEN_HAS_FILE, IOPARM_OPEN_HAS_STATUS,
IOPARM_OPEN_HAS_ACCESS, IOPARM_OPEN_HAS_FORM, IOPARM_OPEN_HAS_BLANK,
IOPARM_OPEN_HAS_POSITION, IOPARM_OPEN_HAS_ACTION,
IOPARM_OPEN_HAS_DELIM, IOPARM_OPEN_HAS_PAD, IOPARM_CLOSE_HAS_STATUS,
IOPARM_INQUIRE_HAS_EXIST, IOPARM_INQUIRE_HAS_OPENED,
IOPARM_INQUIRE_HAS_NUMBER, IOPARM_INQUIRE_HAS_NAMED,
IOPARM_INQUIRE_HAS_NEXTREC, IOPARM_INQUIRE_HAS_RECL_OUT,
IOPARM_INQUIRE_HAS_FILE, IOPARM_INQUIRE_HAS_ACCESS,
IOPARM_INQUIRE_HAS_FORM, IOPARM_INQUIRE_HAS_BLANK,
IOPARM_INQUIRE_HAS_POSITION, IOPARM_INQUIRE_HAS_ACTION,
IOPARM_INQUIRE_HAS_DELIM, IOPARM_INQUIRE_HAS_PAD,
IOPARM_INQUIRE_HAS_NAME, IOPARM_INQUIRE_HAS_SEQUENTIAL,
IOPARM_INQUIRE_HAS_DIRECT, IOPARM_INQUIRE_HAS_FORMATTED,
IOPARM_INQUIRE_HAS_UNFORMATTED, IOPARM_INQUIRE_HAS_READ,
IOPARM_INQUIRE_HAS_WRITE, IOPARM_INQUIRE_HAS_READWRITE,
IOPARM_DT_LIST_FORMAT, IOPARM_DT_NAMELIST_READ_MODE,
IOPARM_DT_HAS_REC, IOPARM_DT_HAS_SIZE, IOPARM_DT_HAS_IOLENGTH,
IOPARM_DT_HAS_FORMAT, IOPARM_DT_HAS_ADVANCE,
IOPARM_DT_HAS_INTERNAL_UNIT, IOPARM_DT_HAS_NAMELIST_NAME,
IOPARM_DT_IONML_SET): Define.
(gfc_unit): Add lock, waiting and close fields.  Change file
from flexible array member into pointer to char.
(open_external): Add st_parameter_open * argument.
(find_file, file_exists): Add file and file_len arguments.
(flush_all_units): New prototype.
(max_offset, unit_root, unit_lock): New variable.
(is_internal_unit, is_array_io, next_array_record,
parse_format, next_format, unget_format, format_error,
read_block, write_block, next_record, convert_real,
read_a, read_f, read_l, read_x, read_radix, read_decimal,
list_formatted_read, finish_list_read, namelist_read,
namelist_write, write_a, write_b, write_d, write_e, write_en,
write_es, write_f, write_i, write_l, write_o, write_x, write_z,
list_formatted_write, get_unit): Add st_parameter_dt * argument.
(insert_unit): Remove prototype.
(find_or_create_unit, unlock_unit): New prototype.
(new_unit): Return gfc_unit *.  Add st_parameter_open *
and gfc_unit * arguments.
(free_fnodes): Remove prototype.
(free_format_data): New prototype.
(scratch): Remove.
(init_at_eol): Remove prototype.
(free_ionml): New prototype.
(inc_waiting_locked, predec_waiting_locked, dec_waiting_unlocked):
New inline functions.
* io/unit.c (max_offset, unit_root, unit_lock): New variables.
(insert): Adjust os_error caller.
(insert_unit): Made static.  Allocate memory here, initialize
lock and after inserting it return it, locked.
(delete_unit): Adjust for deletion of g.
(find_unit_1): New function.
(find_unit): Use it.
(find_or_create_unit): New function.
(get_unit): Add dtp argument, change meaning of the int argument
as creation request flag.  Adjust for different st_* calling
conventions, lock internal unit's lock before returning it
and removal of g.  Call find_unit_1 instead of find_unit.
(is_internal_unit, is_array_io): Add dtp argument, adjust for
removal of most of global variables.
(init_units): Initialize unit_lock.  Adjust insert_unit callers
and adjust for g removal.
(close_unit_1): New function.
(close_unit): Use it.
(unlock_unit): New function.
(close_units): Lock unit_lock, use close_unit_1 rather than
close_unit.
* io/close.c (st_close): Add clp argument.  Adjust for new
st_* calling conventions and internal function API changes.
* io/file_pos.c (st_backspace, st_endfile, st_rewind, st_flush):
Add fpp argument.  Adjust for new st_* calling conventions and
internal function API changes.
(formatted_backspace, unformatted_backspace): Likewise.  Add
u argument.
* io/open.c (edit_modes, st_open): Add opp argument.  Adjust for
new st_* calling conventions and internal function API changes.
(already_open): Likewise.  If not HAVE_UNLINK_OPEN_FILE, unlink
scratch file.  Instead of calling close_unit just call sclose,
free u->file if any and clear a few u fields before calling
new_unit.
(new_unit): Return gfc_unit *.  Add opp and u arguments.
Adjust for new st_* calling conventions and internal function
API changes.  Don't allocate unit here, rather than work with
already created unit u already locked on entry.  In case
of failure, close_unit it.
* io/unix.c: Include unix.h.
(BUFFER_SIZE, unix_stream): Moved to unix.h.
(unit_to_fd): Add unlock_unit call.
(tempfile): Add opp argument, use its fields rather than ioparm.
(regular_file): Likewise.
(open_external): Likewise.  Only unlink file if fd >= 0.
(init_error_stream): Add error argument, set structure it points
to rather than filling static variable and returning its address.
(FIND_FILE0_DECL, FIND_FILE0_ARGS): Define.
(find_file0): Use them.  Don't crash if u->s == NULL.
(find_file): Add file and file_len arguments, use them instead
of ioparm.  Add locking.  Pass either an array of 2 struct stat
or file and file_len pair to find_file0.
(flush_all_units_1, flush_all_units): New functions.
(file_exists): Add file and file_len arguments, use them instead
of ioparm.
* io/unix.h: New file.
* io/lock.c (ioparm, g, ionml): Remove variables.
(library_start): Add cmp argument, adjust for new st_* calling
conventions.
(library_end): Remove.
(free_ionml): New function.
* io/inquire.c (inquire_via_unit, inquire_via_filename,
st_inquire): Add iqp argument, adjust for new st_* calling
conventions and internal function API changes.
* io/format.c (FARRAY_SIZE): Decrease to 64.
(fnode_array, format_data): New typedefs.
(avail, array, format_string, string, error, saved_token, value,
format_string_len, reversion_ok, saved_format): Remove variables.
(colon_node): Add const.
(free_fnode, free_fnodes): Remove.
(free_format_data): New function.
(next_char, unget_char, get_fnode, format_lex, parse_format_list,
format_error, parse_format, revert, unget_format, next_test): Add
fmt or dtp arguments, pass it all around, adjust for internal
function API changes and adjust for removal of global variables.
(next_format): Likewise.  Constify return type.
(next_format0): Constify return type.
* io/transfer.c (current_unit, sf_seen_eor, eor_condition, max_pos,
skips, pending_spaces, scratch, line_buffer, advance_status,
transfer): Remove variables.
(transfer_integer, transfer_real, transfer_logical,
transfer_character, transfer_complex, transfer_array, current_mode,
read_sf, read_block, read_block_direct, write_block,
write_block_direct, unformatted_read, unformatted_write,
type_name, write_constant_string, require_type,
formatted_transfer_scalar, us_read, us_write, pre_position,
data_transfer_init, next_record_r, next_record_w, next_record,
finalize_transfer, iolength_transfer, iolength_transfer_init,
st_iolength, st_iolength_done, st_read, st_read_done, st_write,
st_write_done, st_set_nml_var, st_set_nml_var_dim,
next_array_record): Add dtp argument, pass it all around, adjust for
internal function API changes and removal of global variables.
* io/list_read.c (repeat_count, saved_length, saved_used,
input_complete, at_eol, comma_flag, last_char, saved_string,
saved_type, namelist_mode, nml_read_error, value, parse_err_msg,
nml_err_msg, prev_nl): Remove variables.
(push_char, free_saved, next_char, unget_char, eat_spaces,
eat_separator, finish_separator, nml_bad_return, convert_integer,
parse_repeat, read_logical, read_integer, read_character,
parse_real, read_complex, read_real, check_type,
list_formatted_read_scalar, list_formatted_read, finish_list_read,
find_nml_node, nml_untouch_nodes, nml_match_name, nml_query,
namelist_read): Add dtp argument, pass it all around, adjust for
internal function API changes and removal of global variables.
(nml_parse_qualifier): Likewise.  Add parse_err_msg argument.
(nml_read_obj): Likewise.  Add pprev_nl, nml_err_msg, clow and
chigh arguments.
(nml_get_obj_data): Likewise.  Add pprev_nl and nml_err_msg
arguments.
(init_at_eol): Removed.
* io/read.c (convert_real, read_l, read_a, next_char, read_decimal,
read_radix, read_f, read_x): Add dtp argument, pass it all around,
adjust for internal function API changes and removal of global
variables.
(set_integer): Adjust internal_error caller.
* io/write.c (no_leading_blank, nml_delim): Remove variables.
(write_a, calculate_sign, calculate_G_format, output_float,
write_l, write_float, write_int, write_decimal, write_i, write_b,
write_o, write_z, write_d, write_e, write_f, write_en, write_es,
write_x, write_char, write_logical, write_integer, write_character,
write_real, write_complex, write_separator,
list_formatted_write_scalar, list_formatted_write, nml_write_obj,
namelist_write): Add dtp argument, pass it all around, adjust for
internal function API changes and removal of global variables.
(extract_int, extract_uint, extract_real): Adjust internal_error
callers.
* runtime/fpu.c (_GNU_SOURCE): Don't define here.
* runtime/error.c: Include ../io/unix.h.
(filename, line): Remove variables.
(st_printf): Pass address of a local variable to init_error_stream.
(show_locus): Add cmp argument.  Use fields it points to rather than
filename and line variables.
(os_error, runtime_error): Remove show_locus calls.
(internal_error): Add cmp argument.  Pass it down to show_locus.
(generate_error): Likewise.  Use flags bitmask instead of non-NULL
check for iostat and iomsg parameter presence, adjust for st_*
calling convention changes.
* runtime/stop.c (stop_numeric, stop_string): Remove show_locus
calls.
* runtime/pause.c (pause_numeric, pause_string): Likewise.
* runtime/string.c: Include ../io/io.h.
(find_option): Add cmp argument.  Pass it down to generate_error.
* intrinsics/flush.c (recursive_flush): Remove.
(flush_i4, flush_i8): Use flush_all_units.  Add unlock_unit
call.
* intrinsics/rand.c: Include ../io/io.h.
(rand_seed_lock): New variable.
(srand, irand): Add locking.
(init): New constructor function.
* intrinsics/random.c: Include ../io/io.h.
(random_lock): New variable.
(random_r4, random_r8, arandom_r4, arandom_r8): Add locking.
(random_seed): Likewise.  open failed if fd < 0.  Set i correctly.
(init): New constructor function.
* intrinsics/system_clock.c (tp0, t0): Remove.
(system_clock_4, system_clock_8): Don't subtract tp0/t0 from current
time, use just integer arithmetics.
* intrinsics/tty.c (isatty_l4, isatty_l8, ttynam_sub): Add
unlock_unit calls.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@107328 138bc75d-0d04-0410-961f-82ee72b054a4

43 files changed:
gcc/fortran/ChangeLog
gcc/fortran/Make-lang.in
gcc/fortran/dump-parse-tree.c
gcc/fortran/io.c
gcc/fortran/ioparm.def [new file with mode: 0644]
gcc/fortran/resolve.c
gcc/fortran/trans-io.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/inquire_9.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.fortran-torture/execute/inquire_5.f90 [new file with mode: 0644]
libgfortran/ChangeLog
libgfortran/Makefile.am
libgfortran/Makefile.in
libgfortran/acinclude.m4
libgfortran/config.h.in
libgfortran/configure
libgfortran/configure.ac
libgfortran/intrinsics/flush.c
libgfortran/intrinsics/rand.c
libgfortran/intrinsics/random.c
libgfortran/intrinsics/system_clock.c
libgfortran/intrinsics/tty.c
libgfortran/io/close.c
libgfortran/io/file_pos.c
libgfortran/io/format.c
libgfortran/io/inquire.c
libgfortran/io/io.h
libgfortran/io/list_read.c
libgfortran/io/lock.c
libgfortran/io/open.c
libgfortran/io/read.c
libgfortran/io/transfer.c
libgfortran/io/unit.c
libgfortran/io/unix.c
libgfortran/io/unix.h [new file with mode: 0644]
libgfortran/io/write.c
libgfortran/libgfortran.h
libgfortran/libtool-version
libgfortran/runtime/error.c
libgfortran/runtime/fpu.c
libgfortran/runtime/pause.c
libgfortran/runtime/stop.c
libgfortran/runtime/string.c

index 355430d..4a124d3 100644 (file)
@@ -1,3 +1,88 @@
+2005-11-21  Jakub Jelinek  <jakub@redhat.com>
+
+       PR fortran/14943
+       PR fortran/21647
+       * Make-lang.in (fortran/trans-io.o): Depend on fortran/ioparm.def.
+       * dump-parse-tree.c (gfc_show_code_node): Dump c->block for
+       EXEC_{READ,WRITE,IOLENGTH} nodes.
+       * io.c (terminate_io, match_io, gfc_match_inquire): Put data
+       transfer commands into EXEC_{READ,WRITE,IOLENGTH}'s code->block.
+       * resolve.c (resolve_blocks): Handle EXEC_{READ,WRITE,IOLENGTH}.
+       * trans-io.c (ioparm_unit, ioparm_err, ioparm_end, ioparm_eor,
+       ioparm_list_format, ioparm_library_return, ioparm_iostat,
+       ioparm_exist, ioparm_opened, ioparm_number, ioparm_named,
+       ioparm_rec, ioparm_nextrec, ioparm_size, ioparm_recl_in,
+       ioparm_recl_out, ioparm_iolength, ioparm_file, ioparm_file_len,
+       ioparm_status, ioparm_status_len, ioparm_access, ioparm_access_len,
+       ioparm_form, ioparm_form_len, ioparm_blank, ioparm_blank_len,
+       ioparm_position, ioparm_position_len, ioparm_action,
+       ioparm_action_len, ioparm_delim, ioparm_delim_len, ioparm_pad,
+       ioparm_pad_len, ioparm_format, ioparm_format_len, ioparm_advance,
+       ioparm_advance_len, ioparm_name, ioparm_name_len,
+       ioparm_internal_unit, ioparm_internal_unit_len,
+       ioparm_internal_unit_desc, ioparm_sequential, ioparm_sequential_len,
+       ioparm_direct, ioparm_direct_len, ioparm_formatted,
+       ioparm_formatted_len, ioparm_unformatted, ioparm_unformatted_len,
+       ioparm_read, ioparm_read_len, ioparm_write, ioparm_write_len,
+       ioparm_readwrite, ioparm_readwrite_len, ioparm_namelist_name,
+       ioparm_namelist_name_len, ioparm_namelist_read_mode, ioparm_iomsg,
+       ioparm_iomsg_len, ioparm_var): Remove.
+       (enum ioparam_type, enum iofield_type, enum iofield,
+       enum iocall): New enums.
+       (gfc_st_parameter_field, gfc_st_parameter): New typedefs.
+       (st_parameter, st_parameter_field, iocall): New variables.
+       (ADD_FIELD, ADD_STRING): Remove.
+       (dt_parm, dt_post_end_block): New variables.
+       (gfc_build_st_parameter): New function.
+       (gfc_build_io_library_fndecls): Use it.  Initialize iocall
+       array rather than ioparm_*, add extra first arguments to
+       the function types.
+       (set_parameter_const): New function.
+       (set_parameter_value): Add type argument, return a bitmask.
+       Changed to set a field in automatic structure variable rather
+       than set a field in a global _gfortran_ioparm variable.
+       (set_parameter_ref): Likewise.  If requested var has different
+       size than what field should point to, call with a temporary and
+       then copy into the user variable.  Add postblock argument.
+       (set_string): Remove var_len argument, add type argument, return
+       a bitmask.  Changed to set fields in automatic structure variable
+       rather than set a field in a global _gfortran_ioparm variable.
+       (set_internal_unit): Remove iunit, iunit_len, iunit_desc arguments,
+       add var argument.  Return a bitmask.  Changed to set fields in
+       automatic structure variable rather than set a field in a global
+       _gfortran_ioparm variable.
+       (set_flag): Removed.
+       (io_result): Add var argument.  Changed to read common.flags field
+       from automatic structure variable and bitwise AND it with 3.
+       (set_error_locus): Add var argument.  Changed to set fields in
+       automatic structure variable rather than set a field in a global
+       _gfortran_{filename,line} variables.
+       (gfc_trans_open): Use gfc_start_block rather than gfc_init_block.
+       Create a temporary st_parameter_* structure.  Adjust callers of
+       all above mentioned functions.  Pass address of the temporary
+       variable as first argument to the generated function call.
+       Use iocall array rather than ioparm_* separate variables.
+       (gfc_trans_close, build_filepos, gfc_trans_inquire): Likewise.
+       (build_dt): Likewise.  Change first argument to tree from tree *.
+       Don't dereference code->ext.dt if last_dt == INQUIRE.  Emit
+       IOLENGTH argument setup here.  Set dt_parm/dt_post_end_block
+       variables and gfc_trans_code the nested data transfer commands
+       in code->block.
+       (gfc_trans_iolength): Just set last_dt and call build_dt immediately.
+       (transfer_namelist_element): Pass address of dt_parm variable
+       to generated functions.  Use iocall array rather than ioparm_*
+       separate variables.
+       (gfc_trans_backspace, gfc_trans_endfile, gfc_trans_rewind,
+       gfc_trans_flush, gfc_trans_read, gfc_trans_write): Use iocall array
+       rather than ioparm_* separate variables.
+       (gfc_trans_dt_end): Likewise.  Pass address of dt_parm variable
+       as first argument to generated function.  Adjust io_result caller.
+       Prepend dt_post_end_block before io_result code.
+       (transfer_expr): Use iocall array rather than ioparm_* separate
+       variables.  Pass address of dt_parm variables as first argument
+       to generated functions.
+       * ioparm.def: New file.
+
 2005-11-21  Paul Thomas  <pault@gcc.gnu.org>
 
        PR fortran/24223
index 96b6e25..5d3a0e0 100644 (file)
@@ -287,7 +287,8 @@ fortran/trans-types.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-types.h \
 fortran/trans-const.o: $(GFORTRAN_TRANS_DEPS)
 fortran/trans-expr.o: $(GFORTRAN_TRANS_DEPS) fortran/dependency.h
 fortran/trans-stmt.o: $(GFORTRAN_TRANS_DEPS)
-fortran/trans-io.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-io.h
+fortran/trans-io.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-io.h \
+  fortran/ioparm.def
 fortran/trans-array.o: $(GFORTRAN_TRANS_DEPS)
 fortran/trans-intrinsic.o: $(GFORTRAN_TRANS_DEPS) fortran/mathbuiltins.def \
   gt-fortran-trans-intrinsic.h
index 7d2b26d..499e1fa 100644 (file)
@@ -1357,6 +1357,7 @@ gfc_show_code_node (int level, gfc_code * c)
     case EXEC_IOLENGTH:
       gfc_status ("IOLENGTH ");
       gfc_show_expr (c->expr);
+      goto show_dt_code;
       break;
 
     case EXEC_READ:
@@ -1411,7 +1412,11 @@ gfc_show_code_node (int level, gfc_code * c)
          gfc_show_expr (dt->advance);
        }
 
-      break;
+    show_dt_code:
+      gfc_status_char ('\n');
+      for (c = c->block->next; c; c = c->next)
+       gfc_show_code_node (level + (c->next != NULL), c);
+      return;
 
     case EXEC_TRANSFER:
       gfc_status ("TRANSFER ");
index 183948e..26c3356 100644 (file)
@@ -2147,7 +2147,7 @@ terminate_io (gfc_code * io_code)
   gfc_code *c;
 
   if (io_code == NULL)
-    io_code = &new_st;
+    io_code = new_st.block;
 
   c = gfc_get_code ();
   c->op = EXEC_DT_END;
@@ -2353,7 +2353,9 @@ get_io_list:
 
   new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE;
   new_st.ext.dt = dt;
-  new_st.next = io_code;
+  new_st.block = gfc_get_code ();
+  new_st.block->op = new_st.op;
+  new_st.block->next = io_code;
 
   terminate_io (io_code);
 
@@ -2522,8 +2524,6 @@ gfc_match_inquire (void)
       if (m == MATCH_NO)
        goto syntax;
 
-      terminate_io (code);
-
       new_st.op = EXEC_IOLENGTH;
       new_st.expr = inquire->iolength;
       new_st.ext.inquire = inquire;
@@ -2535,7 +2535,10 @@ gfc_match_inquire (void)
          return MATCH_ERROR;
        }
 
-      new_st.next = code;
+      new_st.block = gfc_get_code ();
+      new_st.block->op = EXEC_IOLENGTH;
+      terminate_io (code);
+      new_st.block->next = code;
       return MATCH_YES;
     }
 
diff --git a/gcc/fortran/ioparm.def b/gcc/fortran/ioparm.def
new file mode 100644 (file)
index 0000000..9ca0cf6
--- /dev/null
@@ -0,0 +1,67 @@
+#ifndef IOPARM_common_libreturn_mask
+#define IOPARM_common_libreturn_mask   3
+#define IOPARM_common_libreturn_ok     0
+#define IOPARM_common_libreturn_error  1
+#define IOPARM_common_libreturn_end    2
+#define IOPARM_common_libreturn_eor    3
+#define IOPARM_common_err              (1 << 2)
+#define IOPARM_common_end              (1 << 3)
+#define IOPARM_common_eor              (1 << 4)
+#endif
+IOPARM (common,  flags,                0,       int4)
+IOPARM (common,  unit,         0,       int4)
+IOPARM (common,  filename,     0,       pchar)
+IOPARM (common,  line,         0,       int4)
+IOPARM (common,  iomsg,                1 << 6,  char2)
+IOPARM (common,  iostat,       1 << 5,  pint4)
+IOPARM (open,    common,       0,       common)
+IOPARM (open,    recl_in,      1 << 7,  int4)
+IOPARM (open,    file,         1 << 8,  char2)
+IOPARM (open,    status,       1 << 9,  char1)
+IOPARM (open,    access,       1 << 10, char2)
+IOPARM (open,    form,         1 << 11, char1)
+IOPARM (open,    blank,                1 << 12, char2)
+IOPARM (open,    position,     1 << 13, char1)
+IOPARM (open,    action,       1 << 14, char2)
+IOPARM (open,    delim,                1 << 15, char1)
+IOPARM (open,    pad,          1 << 16, char2)
+IOPARM (close,   common,       0,       common)
+IOPARM (close,   status,       1 << 7,  char1)
+IOPARM (filepos, common,       0,       common)
+IOPARM (inquire, common,       0,       common)
+IOPARM (inquire, exist,                1 << 7,  pint4)
+IOPARM (inquire, opened,       1 << 8,  pint4)
+IOPARM (inquire, number,       1 << 9,  pint4)
+IOPARM (inquire, named,                1 << 10, pint4)
+IOPARM (inquire, nextrec,      1 << 11, pint4)
+IOPARM (inquire, recl_out,     1 << 12, pint4)
+IOPARM (inquire, file,         1 << 13, char1)
+IOPARM (inquire, access,       1 << 14, char2)
+IOPARM (inquire, form,         1 << 15, char1)
+IOPARM (inquire, blank,                1 << 16, char2)
+IOPARM (inquire, position,     1 << 17, char1)
+IOPARM (inquire, action,       1 << 18, char2)
+IOPARM (inquire, delim,                1 << 19, char1)
+IOPARM (inquire, pad,          1 << 20, char2)
+IOPARM (inquire, name,         1 << 21, char1)
+IOPARM (inquire, sequential,   1 << 22, char2)
+IOPARM (inquire, direct,       1 << 23, char1)
+IOPARM (inquire, formatted,    1 << 24, char2)
+IOPARM (inquire, unformatted,  1 << 25, char1)
+IOPARM (inquire, read,         1 << 26, char2)
+IOPARM (inquire, write,                1 << 27, char1)
+IOPARM (inquire, readwrite,    1 << 28, char2)
+#ifndef IOPARM_dt_list_format
+#define IOPARM_dt_list_format          (1 << 7)
+#define IOPARM_dt_namelist_read_mode   (1 << 8)
+#endif
+IOPARM (dt,      common,       0,       common)
+IOPARM (dt,      rec,          1 << 9,  int4)
+IOPARM (dt,      size,         1 << 10, pint4)
+IOPARM (dt,      iolength,     1 << 11, pint4)
+IOPARM (dt,      internal_unit_desc, 0,  parray)
+IOPARM (dt,      format,       1 << 12, char1)
+IOPARM (dt,      advance,      1 << 13, char2)
+IOPARM (dt,      internal_unit,        1 << 14, char1)
+IOPARM (dt,      namelist_name,        1 << 15, char2)
+IOPARM (dt,      u,            0,       pad)
index cb9c65b..c543a95 100644 (file)
@@ -3892,6 +3892,9 @@ resolve_blocks (gfc_code * b, gfc_namespace * ns)
        case EXEC_FORALL:
        case EXEC_DO:
        case EXEC_DO_WHILE:
+       case EXEC_READ:
+       case EXEC_WRITE:
+       case EXEC_IOLENGTH:
          break;
 
        default:
index bdfa450..720ff58 100644 (file)
@@ -38,351 +38,403 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
 
 /* Members of the ioparm structure.  */
 
-static GTY(()) tree ioparm_unit;
-static GTY(()) tree ioparm_err;
-static GTY(()) tree ioparm_end;
-static GTY(()) tree ioparm_eor;
-static GTY(()) tree ioparm_list_format;
-static GTY(()) tree ioparm_library_return;
-static GTY(()) tree ioparm_iostat;
-static GTY(()) tree ioparm_exist;
-static GTY(()) tree ioparm_opened;
-static GTY(()) tree ioparm_number;
-static GTY(()) tree ioparm_named;
-static GTY(()) tree ioparm_rec;
-static GTY(()) tree ioparm_nextrec;
-static GTY(()) tree ioparm_size;
-static GTY(()) tree ioparm_recl_in;
-static GTY(()) tree ioparm_recl_out;
-static GTY(()) tree ioparm_iolength;
-static GTY(()) tree ioparm_file;
-static GTY(()) tree ioparm_file_len;
-static GTY(()) tree ioparm_status;
-static GTY(()) tree ioparm_status_len;
-static GTY(()) tree ioparm_access;
-static GTY(()) tree ioparm_access_len;
-static GTY(()) tree ioparm_form;
-static GTY(()) tree ioparm_form_len;
-static GTY(()) tree ioparm_blank;
-static GTY(()) tree ioparm_blank_len;
-static GTY(()) tree ioparm_position;
-static GTY(()) tree ioparm_position_len;
-static GTY(()) tree ioparm_action;
-static GTY(()) tree ioparm_action_len;
-static GTY(()) tree ioparm_delim;
-static GTY(()) tree ioparm_delim_len;
-static GTY(()) tree ioparm_pad;
-static GTY(()) tree ioparm_pad_len;
-static GTY(()) tree ioparm_format;
-static GTY(()) tree ioparm_format_len;
-static GTY(()) tree ioparm_advance;
-static GTY(()) tree ioparm_advance_len;
-static GTY(()) tree ioparm_name;
-static GTY(()) tree ioparm_name_len;
-static GTY(()) tree ioparm_internal_unit;
-static GTY(()) tree ioparm_internal_unit_len;
-static GTY(()) tree ioparm_internal_unit_desc;
-static GTY(()) tree ioparm_sequential;
-static GTY(()) tree ioparm_sequential_len;
-static GTY(()) tree ioparm_direct;
-static GTY(()) tree ioparm_direct_len;
-static GTY(()) tree ioparm_formatted;
-static GTY(()) tree ioparm_formatted_len;
-static GTY(()) tree ioparm_unformatted;
-static GTY(()) tree ioparm_unformatted_len;
-static GTY(()) tree ioparm_read;
-static GTY(()) tree ioparm_read_len;
-static GTY(()) tree ioparm_write;
-static GTY(()) tree ioparm_write_len;
-static GTY(()) tree ioparm_readwrite;
-static GTY(()) tree ioparm_readwrite_len;
-static GTY(()) tree ioparm_namelist_name;
-static GTY(()) tree ioparm_namelist_name_len;
-static GTY(()) tree ioparm_namelist_read_mode;
-static GTY(()) tree ioparm_iomsg;
-static GTY(()) tree ioparm_iomsg_len;
-
-/* The global I/O variables */
-
-static GTY(()) tree ioparm_var;
-static GTY(()) tree locus_file;
-static GTY(()) tree locus_line;
+enum ioparam_type
+{
+  IOPARM_ptype_common,
+  IOPARM_ptype_open,
+  IOPARM_ptype_close,
+  IOPARM_ptype_filepos,
+  IOPARM_ptype_inquire,
+  IOPARM_ptype_dt,
+  IOPARM_ptype_num
+};
+
+enum iofield_type
+{
+  IOPARM_type_int4,
+  IOPARM_type_pint4,
+  IOPARM_type_pchar,
+  IOPARM_type_parray,
+  IOPARM_type_pad,
+  IOPARM_type_char1,
+  IOPARM_type_char2,
+  IOPARM_type_common,
+  IOPARM_type_num
+};
+
+typedef struct gfc_st_parameter_field GTY(())
+{
+  const char *name;
+  unsigned int mask;
+  enum ioparam_type param_type;
+  enum iofield_type type;
+  tree field;
+  tree field_len;
+}
+gfc_st_parameter_field;
 
+typedef struct gfc_st_parameter GTY(())
+{
+  const char *name;
+  tree type;
+}
+gfc_st_parameter;
+
+enum iofield
+{
+#define IOPARM(param_type, name, mask, type) IOPARM_##param_type##_##name,
+#include "ioparm.def"
+#undef IOPARM
+  IOPARM_field_num
+};
+
+static GTY(()) gfc_st_parameter st_parameter[] =
+{
+  { "common", NULL },
+  { "open", NULL },
+  { "close", NULL },
+  { "filepos", NULL },
+  { "inquire", NULL },
+  { "dt", NULL }
+};
+
+static GTY(()) gfc_st_parameter_field st_parameter_field[] =
+{
+#define IOPARM(param_type, name, mask, type) \
+  { #name, mask, IOPARM_ptype_##param_type, IOPARM_type_##type, NULL, NULL },
+#include "ioparm.def"
+#undef IOPARM
+  { NULL, 0, 0, 0, NULL, NULL }
+};
 
 /* Library I/O subroutines */
 
-static GTY(()) tree iocall_read;
-static GTY(()) tree iocall_read_done;
-static GTY(()) tree iocall_write;
-static GTY(()) tree iocall_write_done;
-static GTY(()) tree iocall_x_integer;
-static GTY(()) tree iocall_x_logical;
-static GTY(()) tree iocall_x_character;
-static GTY(()) tree iocall_x_real;
-static GTY(()) tree iocall_x_complex;
-static GTY(()) tree iocall_x_array;
-static GTY(()) tree iocall_open;
-static GTY(()) tree iocall_close;
-static GTY(()) tree iocall_inquire;
-static GTY(()) tree iocall_iolength;
-static GTY(()) tree iocall_iolength_done;
-static GTY(()) tree iocall_rewind;
-static GTY(()) tree iocall_backspace;
-static GTY(()) tree iocall_endfile;
-static GTY(()) tree iocall_flush;
-static GTY(()) tree iocall_set_nml_val;
-static GTY(()) tree iocall_set_nml_val_dim;
+enum iocall
+{
+  IOCALL_READ,
+  IOCALL_READ_DONE,
+  IOCALL_WRITE,
+  IOCALL_WRITE_DONE,
+  IOCALL_X_INTEGER,
+  IOCALL_X_LOGICAL,
+  IOCALL_X_CHARACTER,
+  IOCALL_X_REAL,
+  IOCALL_X_COMPLEX,
+  IOCALL_X_ARRAY,
+  IOCALL_OPEN,
+  IOCALL_CLOSE,
+  IOCALL_INQUIRE,
+  IOCALL_IOLENGTH,
+  IOCALL_IOLENGTH_DONE,
+  IOCALL_REWIND,
+  IOCALL_BACKSPACE,
+  IOCALL_ENDFILE,
+  IOCALL_FLUSH,
+  IOCALL_SET_NML_VAL,
+  IOCALL_SET_NML_VAL_DIM,
+  IOCALL_NUM
+};
+
+static GTY(()) tree iocall[IOCALL_NUM];
 
 /* Variable for keeping track of what the last data transfer statement
    was.  Used for deciding which subroutine to call when the data
    transfer is complete.  */
 static enum { READ, WRITE, IOLENGTH } last_dt;
 
-#define ADD_FIELD(name, type)                                          \
-  ioparm_ ## name = gfc_add_field_to_struct                            \
-        (&(TYPE_FIELDS (ioparm_type)), ioparm_type,                    \
-        get_identifier (stringize(name)), type)
+/* The data transfer parameter block that should be shared by all
+   data transfer calls belonging to the same read/write/iolength.  */
+static GTY(()) tree dt_parm;
+static stmtblock_t *dt_post_end_block;
 
-#define ADD_STRING(name) \
-  ioparm_ ## name = gfc_add_field_to_struct                            \
-        (&(TYPE_FIELDS (ioparm_type)), ioparm_type,                    \
-        get_identifier (stringize(name)), pchar_type_node);            \
-  ioparm_ ## name ## _len = gfc_add_field_to_struct                    \
-        (&(TYPE_FIELDS (ioparm_type)), ioparm_type,                    \
-        get_identifier (stringize(name) "_len"), gfc_charlen_type_node)
+static void
+gfc_build_st_parameter (enum ioparam_type ptype, tree *types)
+{
+  enum iofield type;
+  gfc_st_parameter_field *p;
+  char name[64];
+  size_t len;
+  tree t = make_node (RECORD_TYPE);
+
+  len = strlen (st_parameter[ptype].name);
+  gcc_assert (len <= sizeof (name) - sizeof ("__st_parameter_"));
+  memcpy (name, "__st_parameter_", sizeof ("__st_parameter_"));
+  memcpy (name + sizeof ("__st_parameter_") - 1, st_parameter[ptype].name,
+         len);
+  TYPE_NAME (t) = get_identifier (name);
+
+  for (type = 0, p = st_parameter_field; type < IOPARM_field_num; type++, p++)
+    if (p->param_type == ptype)
+      switch (p->type)
+       {
+       case IOPARM_type_int4:
+       case IOPARM_type_pint4:
+       case IOPARM_type_parray:
+       case IOPARM_type_pchar:
+       case IOPARM_type_pad:
+         p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
+                                             get_identifier (p->name),
+                                             types[p->type]);
+         break;
+       case IOPARM_type_char1:
+         p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
+                                             get_identifier (p->name),
+                                             pchar_type_node);
+         /* FALLTHROUGH */
+       case IOPARM_type_char2:
+         len = strlen (p->name);
+         gcc_assert (len <= sizeof (name) - sizeof ("_len"));
+         memcpy (name, p->name, len);
+         memcpy (name + len, "_len", sizeof ("_len"));
+         p->field_len = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
+                                                 get_identifier (name),
+                                                 gfc_charlen_type_node);
+         if (p->type == IOPARM_type_char2)
+           p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
+                                               get_identifier (p->name),
+                                               pchar_type_node);
+         break;
+       case IOPARM_type_common:
+         p->field
+           = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
+                                      get_identifier (p->name),
+                                      st_parameter[IOPARM_ptype_common].type);
+         break;
+       case IOPARM_type_num:
+         gcc_unreachable ();
+       }
 
+  gfc_finish_type (t);
+  st_parameter[ptype].type = t;
+}
 
 /* Create function decls for IO library functions.  */
 
 void
 gfc_build_io_library_fndecls (void)
 {
-  tree gfc_int4_type_node;
-  tree gfc_pint4_type_node;
+  tree types[IOPARM_type_num], pad_idx, gfc_int4_type_node;
+  tree parm_type, dt_parm_type;
   tree gfc_c_int_type_node;
-  tree ioparm_type;
-
-  gfc_int4_type_node = gfc_get_int_type (4);
-  gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
+  HOST_WIDE_INT pad_size;
+  enum ioparam_type ptype;
+
+  types[IOPARM_type_int4] = gfc_int4_type_node = gfc_get_int_type (4);
+  types[IOPARM_type_pint4] = build_pointer_type (gfc_int4_type_node);
+  types[IOPARM_type_parray] = pchar_type_node;
+  types[IOPARM_type_pchar] = pchar_type_node;
+  pad_size = 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node));
+  pad_size += 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node));
+  pad_idx = build_index_type (build_int_cst (NULL_TREE, pad_size));
+  types[IOPARM_type_pad] = build_array_type (char_type_node, pad_idx);
   gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
 
-  /* Build the st_parameter structure.  Information associated with I/O
-     calls are transferred here.  This must match the one defined in the
-     library exactly.  */
-
-  ioparm_type = make_node (RECORD_TYPE);
-  TYPE_NAME (ioparm_type) = get_identifier ("_gfc_ioparm");
-
-  ADD_FIELD (unit, gfc_int4_type_node);
-  ADD_FIELD (err, gfc_int4_type_node);
-  ADD_FIELD (end, gfc_int4_type_node);
-  ADD_FIELD (eor, gfc_int4_type_node);
-  ADD_FIELD (list_format, gfc_int4_type_node);
-  ADD_FIELD (library_return, gfc_int4_type_node);
-
-  ADD_FIELD (iostat, gfc_pint4_type_node);
-  ADD_FIELD (exist, gfc_pint4_type_node);
-  ADD_FIELD (opened, gfc_pint4_type_node);
-  ADD_FIELD (number, gfc_pint4_type_node);
-  ADD_FIELD (named, gfc_pint4_type_node);
-  ADD_FIELD (rec, gfc_int4_type_node);
-  ADD_FIELD (nextrec, gfc_pint4_type_node);
-  ADD_FIELD (size, gfc_pint4_type_node);
-
-  ADD_FIELD (recl_in, gfc_int4_type_node);
-  ADD_FIELD (recl_out, gfc_pint4_type_node);
-
-  ADD_FIELD (iolength, gfc_pint4_type_node);
-
-  ADD_STRING (file);
-  ADD_STRING (status);
-
-  ADD_STRING (access);
-  ADD_STRING (form);
-  ADD_STRING (blank);
-  ADD_STRING (position);
-  ADD_STRING (action);
-  ADD_STRING (delim);
-  ADD_STRING (pad);
-  ADD_STRING (format);
-  ADD_STRING (advance);
-  ADD_STRING (name);
-  ADD_STRING (internal_unit);
-  ADD_FIELD (internal_unit_desc, pchar_type_node);
-  ADD_STRING (sequential);
-
-  ADD_STRING (direct);
-  ADD_STRING (formatted);
-  ADD_STRING (unformatted);
-  ADD_STRING (read);
-  ADD_STRING (write);
-  ADD_STRING (readwrite);
-
-  ADD_STRING (namelist_name);
-  ADD_FIELD (namelist_read_mode, gfc_int4_type_node);
-  ADD_STRING (iomsg);
-
-  gfc_finish_type (ioparm_type);
-
-  ioparm_var = build_decl (VAR_DECL, get_identifier (PREFIX("ioparm")),
-                          ioparm_type);
-  DECL_EXTERNAL (ioparm_var) = 1;
-  TREE_PUBLIC (ioparm_var) = 1;
-
-  locus_line = build_decl (VAR_DECL, get_identifier (PREFIX("line")),
-                          gfc_int4_type_node);
-  DECL_EXTERNAL (locus_line) = 1;
-  TREE_PUBLIC (locus_line) = 1;
-
-  locus_file = build_decl (VAR_DECL, get_identifier (PREFIX("filename")),
-                          pchar_type_node);
-  DECL_EXTERNAL (locus_file) = 1;
-  TREE_PUBLIC (locus_file) = 1;
+  for (ptype = IOPARM_ptype_common; ptype < IOPARM_ptype_num; ptype++)
+    gfc_build_st_parameter (ptype, types);
 
   /* Define the transfer functions.  */
 
-  iocall_x_integer =
+  dt_parm_type = build_pointer_type (st_parameter[IOPARM_ptype_dt].type);
+
+  iocall[IOCALL_X_INTEGER] =
     gfc_build_library_function_decl (get_identifier
                                     (PREFIX("transfer_integer")),
-                                    void_type_node, 2, pvoid_type_node,
-                                    gfc_int4_type_node);
+                                    void_type_node, 3, dt_parm_type,
+                                    pvoid_type_node, gfc_int4_type_node);
 
-  iocall_x_logical =
+  iocall[IOCALL_X_LOGICAL] =
     gfc_build_library_function_decl (get_identifier
                                     (PREFIX("transfer_logical")),
-                                    void_type_node, 2, pvoid_type_node,
-                                    gfc_int4_type_node);
+                                    void_type_node, 3, dt_parm_type,
+                                    pvoid_type_node, gfc_int4_type_node);
 
-  iocall_x_character =
+  iocall[IOCALL_X_CHARACTER] =
     gfc_build_library_function_decl (get_identifier
                                     (PREFIX("transfer_character")),
-                                    void_type_node, 2, pvoid_type_node,
-                                    gfc_int4_type_node);
+                                    void_type_node, 3, dt_parm_type,
+                                    pvoid_type_node, gfc_int4_type_node);
 
-  iocall_x_real =
+  iocall[IOCALL_X_REAL] =
     gfc_build_library_function_decl (get_identifier (PREFIX("transfer_real")),
-                                    void_type_node, 2,
+                                    void_type_node, 3, dt_parm_type,
                                     pvoid_type_node, gfc_int4_type_node);
 
-  iocall_x_complex =
+  iocall[IOCALL_X_COMPLEX] =
     gfc_build_library_function_decl (get_identifier
                                     (PREFIX("transfer_complex")),
-                                    void_type_node, 2, pvoid_type_node,
-                                    gfc_int4_type_node);
+                                    void_type_node, 3, dt_parm_type,
+                                    pvoid_type_node, gfc_int4_type_node);
 
-  iocall_x_array =
+  iocall[IOCALL_X_ARRAY] =
     gfc_build_library_function_decl (get_identifier
                                     (PREFIX("transfer_array")),
-                                    void_type_node, 3, pvoid_type_node,
-                                    gfc_c_int_type_node,
+                                    void_type_node, 4, dt_parm_type,
+                                    pvoid_type_node, gfc_c_int_type_node,
                                     gfc_charlen_type_node);
 
   /* Library entry points */
 
-  iocall_read =
+  iocall[IOCALL_READ] =
     gfc_build_library_function_decl (get_identifier (PREFIX("st_read")),
-                                    void_type_node, 0);
+                                    void_type_node, 1, dt_parm_type);
 
-  iocall_write =
+  iocall[IOCALL_WRITE] =
     gfc_build_library_function_decl (get_identifier (PREFIX("st_write")),
-                                    void_type_node, 0);
-  iocall_open =
+                                    void_type_node, 1, dt_parm_type);
+
+  parm_type = build_pointer_type (st_parameter[IOPARM_ptype_open].type);
+  iocall[IOCALL_OPEN] =
     gfc_build_library_function_decl (get_identifier (PREFIX("st_open")),
-                                    void_type_node, 0);
+                                    void_type_node, 1, parm_type);
+
 
-  iocall_close =
+  parm_type = build_pointer_type (st_parameter[IOPARM_ptype_close].type);
+  iocall[IOCALL_CLOSE] =
     gfc_build_library_function_decl (get_identifier (PREFIX("st_close")),
-                                    void_type_node, 0);
+                                    void_type_node, 1, parm_type);
 
-  iocall_inquire =
+  parm_type = build_pointer_type (st_parameter[IOPARM_ptype_inquire].type);
+  iocall[IOCALL_INQUIRE] =
     gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")),
-                                    gfc_int4_type_node, 0);
+                                    gfc_int4_type_node, 1, parm_type);
 
-  iocall_iolength =
+  iocall[IOCALL_IOLENGTH] =
     gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")),
-                                   void_type_node, 0);
+                                   void_type_node, 1, dt_parm_type);
 
-  iocall_rewind =
+  parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type);
+  iocall[IOCALL_REWIND] =
     gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")),
-                                    gfc_int4_type_node, 0);
+                                    gfc_int4_type_node, 1, parm_type);
 
-  iocall_backspace =
+  iocall[IOCALL_BACKSPACE] =
     gfc_build_library_function_decl (get_identifier (PREFIX("st_backspace")),
-                                    gfc_int4_type_node, 0);
+                                    gfc_int4_type_node, 1, parm_type);
 
-  iocall_endfile =
+  iocall[IOCALL_ENDFILE] =
     gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")),
-                                    gfc_int4_type_node, 0);
+                                    gfc_int4_type_node, 1, parm_type);
 
-  iocall_flush =
+  iocall[IOCALL_FLUSH] =
     gfc_build_library_function_decl (get_identifier (PREFIX("st_flush")),
-                                    gfc_int4_type_node, 0);
+                                    gfc_int4_type_node, 1, parm_type);
 
   /* Library helpers */
 
-  iocall_read_done =
+  iocall[IOCALL_READ_DONE] =
     gfc_build_library_function_decl (get_identifier (PREFIX("st_read_done")),
-                                    gfc_int4_type_node, 0);
+                                    gfc_int4_type_node, 1, dt_parm_type);
 
-  iocall_write_done =
+  iocall[IOCALL_WRITE_DONE] =
     gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")),
-                                    gfc_int4_type_node, 0);
+                                    gfc_int4_type_node, 1, dt_parm_type);
 
-  iocall_iolength_done =
+  iocall[IOCALL_IOLENGTH_DONE] =
     gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
-                                    gfc_int4_type_node, 0);
+                                    gfc_int4_type_node, 1, dt_parm_type);
 
 
-  iocall_set_nml_val =
+  iocall[IOCALL_SET_NML_VAL] =
     gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var")),
-                                     void_type_node, 5,
-                                     pvoid_type_node, pvoid_type_node,
-                                     gfc_int4_type_node, gfc_charlen_type_node, 
+                                    void_type_node, 6, dt_parm_type,
+                                    pvoid_type_node, pvoid_type_node,
+                                    gfc_int4_type_node, gfc_charlen_type_node,
                                     gfc_int4_type_node);
 
-  iocall_set_nml_val_dim =
+  iocall[IOCALL_SET_NML_VAL_DIM] =
     gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_dim")),
-                                    void_type_node, 4,
+                                    void_type_node, 5, dt_parm_type,
                                     gfc_int4_type_node, gfc_int4_type_node,
                                     gfc_int4_type_node, gfc_int4_type_node);
 }
 
 
+/* Generate code to store an integer constant into the
+   st_parameter_XXX structure.  */
+
+static unsigned int
+set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
+                    unsigned int val)
+{
+  tree tmp;
+  gfc_st_parameter_field *p = &st_parameter_field[type];
+
+  if (p->param_type == IOPARM_ptype_common)
+    var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
+                 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
+  tmp = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
+               NULL_TREE);
+  gfc_add_modify_expr (block, tmp, build_int_cst (TREE_TYPE (p->field), val));
+  return p->mask;
+}
+
+
 /* Generate code to store a non-string I/O parameter into the
-   ioparm structure.  This is a pass by value.  */
+   st_parameter_XXX structure.  This is a pass by value.  */
 
-static void
-set_parameter_value (stmtblock_t * block, tree var, gfc_expr * e)
+static unsigned int
+set_parameter_value (stmtblock_t *block, tree var, enum iofield type,
+                    gfc_expr *e)
 {
   gfc_se se;
   tree tmp;
+  gfc_st_parameter_field *p = &st_parameter_field[type];
 
   gfc_init_se (&se, NULL);
-  gfc_conv_expr_type (&se, e, TREE_TYPE (var));
+  gfc_conv_expr_type (&se, e, TREE_TYPE (p->field));
   gfc_add_block_to_block (block, &se.pre);
 
-  tmp = build3 (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
+  if (p->param_type == IOPARM_ptype_common)
+    var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
+                 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
+  tmp = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
+               NULL_TREE);
   gfc_add_modify_expr (block, tmp, se.expr);
+  return p->mask;
 }
 
 
 /* Generate code to store a non-string I/O parameter into the
-   ioparm structure.  This is pass by reference.  */
+   st_parameter_XXX structure.  This is pass by reference.  */
 
-static void
-set_parameter_ref (stmtblock_t * block, tree var, gfc_expr * e)
+static unsigned int
+set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock,
+                  tree var, enum iofield type, gfc_expr *e)
 {
   gfc_se se;
-  tree tmp;
+  tree tmp, addr;
+  gfc_st_parameter_field *p = &st_parameter_field[type];
 
+  gcc_assert (e->ts.type == BT_INTEGER || e->ts.type == BT_LOGICAL);
   gfc_init_se (&se, NULL);
-  se.want_pointer = 1;
+  gfc_conv_expr_lhs (&se, e);
 
-  gfc_conv_expr_type (&se, e, TREE_TYPE (var));
   gfc_add_block_to_block (block, &se.pre);
 
-  tmp = build3 (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
-  gfc_add_modify_expr (block, tmp, se.expr);
+  if (TYPE_MODE (TREE_TYPE (se.expr))
+      == TYPE_MODE (TREE_TYPE (TREE_TYPE (p->field))))
+    addr = convert (TREE_TYPE (p->field),
+                   gfc_build_addr_expr (NULL, se.expr));
+  else
+    {
+      /* The type used by the library has different size
+        from the type of the variable supplied by the user.
+        Need to use a temporary.  */
+      tree tmpvar
+       = gfc_create_var (TREE_TYPE (TREE_TYPE (p->field)),
+                         st_parameter_field[type].name);
+      addr = gfc_build_addr_expr (NULL, tmpvar);
+      tmp = convert (TREE_TYPE (se.expr), tmpvar);
+      gfc_add_modify_expr (postblock, se.expr, tmp);
+    }
+
+  if (p->param_type == IOPARM_ptype_common)
+    var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
+                 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
+  tmp = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
+               NULL_TREE);
+  gfc_add_modify_expr (block, tmp, addr);
+  return p->mask;
 }
 
 /* Given an array expr, find its address and length to get a string. If the
@@ -450,22 +502,27 @@ gfc_convert_array_to_string (gfc_se * se, gfc_expr * e)
 
 
 /* Generate code to store a string and its length into the
-   ioparm structure.  */
+   st_parameter_XXX structure.  */
 
-static void
+static unsigned int
 set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
-           tree var_len, gfc_expr * e)
+           enum iofield type, gfc_expr * e)
 {
   gfc_se se;
   tree tmp;
   tree msg;
   tree io;
   tree len;
+  gfc_st_parameter_field *p = &st_parameter_field[type];
 
   gfc_init_se (&se, NULL);
 
-  io = build3 (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
-  len = build3 (COMPONENT_REF, TREE_TYPE (var_len), ioparm_var, var_len,
+  if (p->param_type == IOPARM_ptype_common)
+    var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
+                 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
+  io = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
+              NULL_TREE);
+  len = build3 (COMPONENT_REF, TREE_TYPE (p->field_len), var, p->field_len,
                NULL_TREE);
 
   /* Integer variable assigned a format label.  */
@@ -500,28 +557,34 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
 
   gfc_add_block_to_block (block, &se.pre);
   gfc_add_block_to_block (postblock, &se.post);
+  return p->mask;
 }
 
 
 /* Generate code to store the character (array) and the character length
    for an internal unit.  */
 
-static void
-set_internal_unit (stmtblock_t * block, tree iunit, tree iunit_len,
-                  tree iunit_desc, gfc_expr * e)
+static unsigned int
+set_internal_unit (stmtblock_t * block, tree var, gfc_expr * e)
 {
   gfc_se se;
   tree io;
   tree len;
   tree desc;
   tree tmp;
+  gfc_st_parameter_field *p;
+  unsigned int mask;
 
   gfc_init_se (&se, NULL);
 
-  io = build3 (COMPONENT_REF, TREE_TYPE (iunit), ioparm_var, iunit, NULL_TREE);
-  len = build3 (COMPONENT_REF, TREE_TYPE (iunit_len), ioparm_var, iunit_len,
+  p = &st_parameter_field[IOPARM_dt_internal_unit];
+  mask = p->mask;
+  io = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
+              NULL_TREE);
+  len = build3 (COMPONENT_REF, TREE_TYPE (p->field_len), var, p->field_len,
                NULL_TREE);
-  desc = build3 (COMPONENT_REF, TREE_TYPE (iunit_desc), ioparm_var, iunit_desc,
+  p = &st_parameter_field[IOPARM_dt_internal_unit_desc];
+  desc = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
                 NULL_TREE);
 
   gcc_assert (e->ts.type == BT_CHARACTER);
@@ -555,19 +618,9 @@ set_internal_unit (stmtblock_t * block, tree iunit, tree iunit_len,
   gfc_add_modify_expr (&se.pre, desc, se.expr);
 
   gfc_add_block_to_block (block, &se.pre);
+  return mask;
 }
 
-/* Set a member of the ioparm structure to one.  */
-static void
-set_flag (stmtblock_t *block, tree var)
-{
-  tree tmp, type = TREE_TYPE (var);
-
-  tmp = build3 (COMPONENT_REF, type, ioparm_var, var, NULL_TREE);
-  gfc_add_modify_expr (block, tmp, convert (type, integer_one_node));
-}
-
-
 /* Add a case to a IO-result switch.  */
 
 static void
@@ -600,11 +653,12 @@ add_case (int label_value, gfc_st_label * label, stmtblock_t * body)
    be created anyway.  */
 
 static void
-io_result (stmtblock_t * block, gfc_st_label * err_label,
+io_result (stmtblock_t * block, tree var, gfc_st_label * err_label,
           gfc_st_label * end_label, gfc_st_label * eor_label)
 {
   stmtblock_t body;
   tree tmp, rc;
+  gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
 
   /* If no labels are specified, ignore the result instead
      of building an empty switch.  */
@@ -624,8 +678,12 @@ io_result (stmtblock_t * block, gfc_st_label * err_label,
 
   tmp = gfc_finish_block (&body);
 
-  rc = build3 (COMPONENT_REF, TREE_TYPE (ioparm_library_return), ioparm_var,
-              ioparm_library_return, NULL_TREE);
+  var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
+               var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
+  rc = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
+              NULL_TREE);
+  rc = build2 (BIT_AND_EXPR, TREE_TYPE (rc), rc,
+              build_int_cst (TREE_TYPE (rc), IOPARM_common_libreturn_mask));
 
   tmp = build3_v (SWITCH_EXPR, rc, tmp, NULL_TREE);
 
@@ -637,24 +695,29 @@ io_result (stmtblock_t * block, gfc_st_label * err_label,
    library call goes awry, we can tell the user where the problem is.  */
 
 static void
-set_error_locus (stmtblock_t * block, locus * where)
+set_error_locus (stmtblock_t * block, tree var, locus * where)
 {
   gfc_file *f;
-  tree tmp;
+  tree str, locus_file;
   int line;
+  gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_filename];
 
+  locus_file = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
+                      var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
+  locus_file = build3 (COMPONENT_REF, TREE_TYPE (p->field), locus_file,
+                      p->field, NULL_TREE);
   f = where->lb->file;
-  tmp = gfc_build_cstring_const (f->filename);
+  str = gfc_build_cstring_const (f->filename);
 
-  tmp = gfc_build_addr_expr (pchar_type_node, tmp);
-  gfc_add_modify_expr (block, locus_file, tmp);
+  str = gfc_build_addr_expr (pchar_type_node, str);
+  gfc_add_modify_expr (block, locus_file, str);
 
 #ifdef USE_MAPPED_LOCATION
   line = LOCATION_LINE (where->lb->location);
 #else
   line = where->lb->linenum;
 #endif
-  gfc_add_modify_expr (block, locus_line, build_int_cst (NULL_TREE, line));
+  set_parameter_const (block, var, IOPARM_common_line, line);
 }
 
 
@@ -665,69 +728,79 @@ gfc_trans_open (gfc_code * code)
 {
   stmtblock_t block, post_block;
   gfc_open *p;
-  tree tmp;
+  tree tmp, var;
+  unsigned int mask = 0;
 
-  gfc_init_block (&block);
+  gfc_start_block (&block);
   gfc_init_block (&post_block);
 
-  set_error_locus (&block, &code->loc);
+  var = gfc_create_var (st_parameter[IOPARM_ptype_open].type, "open_parm");
+
+  set_error_locus (&block, var, &code->loc);
   p = code->ext.open;
 
   if (p->unit)
-    set_parameter_value (&block, ioparm_unit, p->unit);
+    set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
+  else
+    set_parameter_const (&block, var, IOPARM_common_unit, 0);
 
   if (p->file)
-    set_string (&block, &post_block, ioparm_file, ioparm_file_len, p->file);
+    mask |= set_string (&block, &post_block, var, IOPARM_open_file, p->file);
 
   if (p->status)
-    set_string (&block, &post_block, ioparm_status,
-               ioparm_status_len, p->status);
+    mask |= set_string (&block, &post_block, var, IOPARM_open_status,
+                       p->status);
 
   if (p->access)
-    set_string (&block, &post_block, ioparm_access,
-               ioparm_access_len, p->access);
+    mask |= set_string (&block, &post_block, var, IOPARM_open_access,
+                       p->access);
 
   if (p->form)
-    set_string (&block, &post_block, ioparm_form, ioparm_form_len, p->form);
+    mask |= set_string (&block, &post_block, var, IOPARM_open_form, p->form);
 
   if (p->recl)
-    set_parameter_value (&block, ioparm_recl_in, p->recl);
+    mask |= set_parameter_value (&block, var, IOPARM_open_recl_in, p->recl);
 
   if (p->blank)
-    set_string (&block, &post_block, ioparm_blank, ioparm_blank_len,
-               p->blank);
+    mask |= set_string (&block, &post_block, var, IOPARM_open_blank,
+                       p->blank);
 
   if (p->position)
-    set_string (&block, &post_block, ioparm_position,
-               ioparm_position_len, p->position);
+    mask |= set_string (&block, &post_block, var, IOPARM_open_position,
+                       p->position);
 
   if (p->action)
-    set_string (&block, &post_block, ioparm_action,
-               ioparm_action_len, p->action);
+    mask |= set_string (&block, &post_block, var, IOPARM_open_action,
+                       p->action);
 
   if (p->delim)
-    set_string (&block, &post_block, ioparm_delim, ioparm_delim_len,
-               p->delim);
+    mask |= set_string (&block, &post_block, var, IOPARM_open_delim,
+                       p->delim);
 
   if (p->pad)
-    set_string (&block, &post_block, ioparm_pad, ioparm_pad_len, p->pad);
+    mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad);
 
   if (p->iomsg)
-    set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len,
-               p->iomsg);
+    mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
+                       p->iomsg);
 
   if (p->iostat)
-    set_parameter_ref (&block, ioparm_iostat, p->iostat);
+    mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
+                              p->iostat);
 
   if (p->err)
-    set_flag (&block, ioparm_err);
+    mask |= IOPARM_common_err;
+
+  set_parameter_const (&block, var, IOPARM_common_flags, mask);
 
-  tmp = gfc_build_function_call (iocall_open, NULL_TREE);
+  tmp = gfc_build_addr_expr (NULL_TREE, var);
+  tmp = gfc_chainon_list (NULL_TREE, tmp);
+  tmp = gfc_build_function_call (iocall[IOCALL_OPEN], tmp);
   gfc_add_expr_to_block (&block, tmp);
 
   gfc_add_block_to_block (&block, &post_block);
 
-  io_result (&block, p->err, NULL, NULL);
+  io_result (&block, var, p->err, NULL, NULL);
 
   return gfc_finish_block (&block);
 }
@@ -740,37 +813,47 @@ gfc_trans_close (gfc_code * code)
 {
   stmtblock_t block, post_block;
   gfc_close *p;
-  tree tmp;
+  tree tmp, var;
+  unsigned int mask = 0;
 
-  gfc_init_block (&block);
+  gfc_start_block (&block);
   gfc_init_block (&post_block);
 
-  set_error_locus (&block, &code->loc);
+  var = gfc_create_var (st_parameter[IOPARM_ptype_close].type, "close_parm");
+
+  set_error_locus (&block, var, &code->loc);
   p = code->ext.close;
 
   if (p->unit)
-    set_parameter_value (&block, ioparm_unit, p->unit);
+    set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
+  else
+    set_parameter_const (&block, var, IOPARM_common_unit, 0);
 
   if (p->status)
-    set_string (&block, &post_block, ioparm_status,
-               ioparm_status_len, p->status);
+    mask |= set_string (&block, &post_block, var, IOPARM_close_status,
+                       p->status);
 
   if (p->iomsg)
-    set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len,
-               p->iomsg);
+    mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
+                       p->iomsg);
 
   if (p->iostat)
-    set_parameter_ref (&block, ioparm_iostat, p->iostat);
+    mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
+                              p->iostat);
 
   if (p->err)
-    set_flag (&block, ioparm_err);
+    mask |= IOPARM_common_err;
 
-  tmp = gfc_build_function_call (iocall_close, NULL_TREE);
+  set_parameter_const (&block, var, IOPARM_common_flags, mask);
+
+  tmp = gfc_build_addr_expr (NULL_TREE, var);
+  tmp = gfc_chainon_list (NULL_TREE, tmp);
+  tmp = gfc_build_function_call (iocall[IOCALL_CLOSE], tmp);
   gfc_add_expr_to_block (&block, tmp);
 
   gfc_add_block_to_block (&block, &post_block);
 
-  io_result (&block, p->err, NULL, NULL);
+  io_result (&block, var, p->err, NULL, NULL);
 
   return gfc_finish_block (&block);
 }
@@ -783,34 +866,45 @@ build_filepos (tree function, gfc_code * code)
 {
   stmtblock_t block, post_block;
   gfc_filepos *p;
-  tree tmp;
+  tree tmp, var;
+  unsigned int mask = 0;
 
   p = code->ext.filepos;
 
-  gfc_init_block (&block);
+  gfc_start_block (&block);
   gfc_init_block (&post_block);
 
-  set_error_locus (&block, &code->loc);
+  var = gfc_create_var (st_parameter[IOPARM_ptype_filepos].type,
+                       "filepos_parm");
+
+  set_error_locus (&block, var, &code->loc);
 
   if (p->unit)
-    set_parameter_value (&block, ioparm_unit, p->unit);
+    set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
+  else
+    set_parameter_const (&block, var, IOPARM_common_unit, 0);
 
   if (p->iomsg)
-    set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len,
-               p->iomsg);
+    mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
+                       p->iomsg);
 
   if (p->iostat)
-    set_parameter_ref (&block, ioparm_iostat, p->iostat);
+    mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
+                              p->iostat);
 
   if (p->err)
-    set_flag (&block, ioparm_err);
+    mask |= IOPARM_common_err;
 
-  tmp = gfc_build_function_call (function, NULL);
+  set_parameter_const (&block, var, IOPARM_common_flags, mask);
+
+  tmp = gfc_build_addr_expr (NULL_TREE, var);
+  tmp = gfc_chainon_list (NULL_TREE, tmp);
+  tmp = gfc_build_function_call (function, tmp);
   gfc_add_expr_to_block (&block, tmp);
 
   gfc_add_block_to_block (&block, &post_block);
 
-  io_result (&block, p->err, NULL, NULL);
+  io_result (&block, var, p->err, NULL, NULL);
 
   return gfc_finish_block (&block);
 }
@@ -821,8 +915,7 @@ build_filepos (tree function, gfc_code * code)
 tree
 gfc_trans_backspace (gfc_code * code)
 {
-
-  return build_filepos (iocall_backspace, code);
+  return build_filepos (iocall[IOCALL_BACKSPACE], code);
 }
 
 
@@ -831,8 +924,7 @@ gfc_trans_backspace (gfc_code * code)
 tree
 gfc_trans_endfile (gfc_code * code)
 {
-
-  return build_filepos (iocall_endfile, code);
+  return build_filepos (iocall[IOCALL_ENDFILE], code);
 }
 
 
@@ -841,8 +933,7 @@ gfc_trans_endfile (gfc_code * code)
 tree
 gfc_trans_rewind (gfc_code * code)
 {
-
-  return build_filepos (iocall_rewind, code);
+  return build_filepos (iocall[IOCALL_REWIND], code);
 }
 
 
@@ -851,8 +942,7 @@ gfc_trans_rewind (gfc_code * code)
 tree
 gfc_trans_flush (gfc_code * code)
 {
-
-  return build_filepos (iocall_flush, code);
+  return build_filepos (iocall[IOCALL_FLUSH], code);
 }
 
 
@@ -863,12 +953,16 @@ gfc_trans_inquire (gfc_code * code)
 {
   stmtblock_t block, post_block;
   gfc_inquire *p;
-  tree tmp;
+  tree tmp, var;
+  unsigned int mask = 0;
 
-  gfc_init_block (&block);
+  gfc_start_block (&block);
   gfc_init_block (&post_block);
 
-  set_error_locus (&block, &code->loc);
+  var = gfc_create_var (st_parameter[IOPARM_ptype_inquire].type,
+                       "inquire_parm");
+
+  set_error_locus (&block, var, &code->loc);
   p = code->ext.inquire;
 
   /* Sanity check.  */
@@ -876,102 +970,119 @@ gfc_trans_inquire (gfc_code * code)
     gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers.", &code->loc);
 
   if (p->unit)
-    set_parameter_value (&block, ioparm_unit, p->unit);
+    set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
+  else
+    set_parameter_const (&block, var, IOPARM_common_unit, 0);
 
   if (p->file)
-    set_string (&block, &post_block, ioparm_file, ioparm_file_len, p->file);
+    mask |= set_string (&block, &post_block, var, IOPARM_inquire_file,
+                       p->file);
 
   if (p->iomsg)
-    set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len,
-               p->iomsg);
+    mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
+                       p->iomsg);
 
   if (p->iostat)
-    set_parameter_ref (&block, ioparm_iostat, p->iostat);
+    mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
+                              p->iostat);
 
   if (p->exist)
-    set_parameter_ref (&block, ioparm_exist, p->exist);
+    mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_exist,
+                              p->exist);
 
   if (p->opened)
-    set_parameter_ref (&block, ioparm_opened, p->opened);
+    mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_opened,
+                              p->opened);
 
   if (p->number)
-    set_parameter_ref (&block, ioparm_number, p->number);
+    mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_number,
+                              p->number);
 
   if (p->named)
-    set_parameter_ref (&block, ioparm_named, p->named);
+    mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_named,
+                              p->named);
 
   if (p->name)
-    set_string (&block, &post_block, ioparm_name, ioparm_name_len, p->name);
+    mask |= set_string (&block, &post_block, var, IOPARM_inquire_name,
+                       p->name);
 
   if (p->access)
-    set_string (&block, &post_block, ioparm_access,
-               ioparm_access_len, p->access);
+    mask |= set_string (&block, &post_block, var, IOPARM_inquire_access,
+                       p->access);
 
   if (p->sequential)
-    set_string (&block, &post_block, ioparm_sequential,
-               ioparm_sequential_len, p->sequential);
+    mask |= set_string (&block, &post_block, var, IOPARM_inquire_sequential,
+                       p->sequential);
 
   if (p->direct)
-    set_string (&block, &post_block, ioparm_direct,
-               ioparm_direct_len, p->direct);
+    mask |= set_string (&block, &post_block, var, IOPARM_inquire_direct,
+                       p->direct);
 
   if (p->form)
-    set_string (&block, &post_block, ioparm_form, ioparm_form_len, p->form);
+    mask |= set_string (&block, &post_block, var, IOPARM_inquire_form,
+                       p->form);
 
   if (p->formatted)
-    set_string (&block, &post_block, ioparm_formatted,
-               ioparm_formatted_len, p->formatted);
+    mask |= set_string (&block, &post_block, var, IOPARM_inquire_formatted,
+                       p->formatted);
 
   if (p->unformatted)
-    set_string (&block, &post_block, ioparm_unformatted,
-               ioparm_unformatted_len, p->unformatted);
+    mask |= set_string (&block, &post_block, var, IOPARM_inquire_unformatted,
+                       p->unformatted);
 
   if (p->recl)
-    set_parameter_ref (&block, ioparm_recl_out, p->recl);
+    mask |= set_parameter_ref (&block, &post_block, var,
+                              IOPARM_inquire_recl_out, p->recl);
 
   if (p->nextrec)
-    set_parameter_ref (&block, ioparm_nextrec, p->nextrec);
+    mask |= set_parameter_ref (&block, &post_block, var,
+                              IOPARM_inquire_nextrec, p->nextrec);
 
   if (p->blank)
-    set_string (&block, &post_block, ioparm_blank, ioparm_blank_len,
-               p->blank);
+    mask |= set_string (&block, &post_block, var, IOPARM_inquire_blank,
+                       p->blank);
 
   if (p->position)
-    set_string (&block, &post_block, ioparm_position,
-               ioparm_position_len, p->position);
+    mask |= set_string (&block, &post_block, var, IOPARM_inquire_position,
+                       p->position);
 
   if (p->action)
-    set_string (&block, &post_block, ioparm_action,
-               ioparm_action_len, p->action);
+    mask |= set_string (&block, &post_block, var, IOPARM_inquire_action,
+                       p->action);
 
   if (p->read)
-    set_string (&block, &post_block, ioparm_read, ioparm_read_len, p->read);
+    mask |= set_string (&block, &post_block, var, IOPARM_inquire_read,
+                       p->read);
 
   if (p->write)
-    set_string (&block, &post_block, ioparm_write,
-               ioparm_write_len, p->write);
+    mask |= set_string (&block, &post_block, var, IOPARM_inquire_write,
+                       p->write);
 
   if (p->readwrite)
-    set_string (&block, &post_block, ioparm_readwrite,
-               ioparm_readwrite_len, p->readwrite);
+    mask |= set_string (&block, &post_block, var, IOPARM_inquire_readwrite,
+                       p->readwrite);
 
   if (p->delim)
-    set_string (&block, &post_block, ioparm_delim, ioparm_delim_len,
-               p->delim);
+    mask |= set_string (&block, &post_block, var, IOPARM_inquire_delim,
+                       p->delim);
 
   if (p->pad)
-    set_string (&block, &post_block, ioparm_pad, ioparm_pad_len,
-                p->pad); 
+    mask |= set_string (&block, &post_block, var, IOPARM_inquire_pad,
+                       p->pad);
 
   if (p->err)
-    set_flag (&block, ioparm_err);
+    mask |= IOPARM_common_err;
 
-  tmp = gfc_build_function_call (iocall_inquire, NULL);
+  set_parameter_const (&block, var, IOPARM_common_flags, mask);
+
+  tmp = gfc_build_addr_expr (NULL_TREE, var);
+  tmp = gfc_chainon_list (NULL_TREE, tmp);
+  tmp = gfc_build_function_call (iocall[IOCALL_INQUIRE], tmp);
   gfc_add_expr_to_block (&block, tmp);
 
   gfc_add_block_to_block (&block, &post_block);
 
-  io_result (&block, p->err, NULL, NULL);
+  io_result (&block, var, p->err, NULL, NULL);
 
   return gfc_finish_block (&block);
 }
@@ -1085,8 +1196,8 @@ nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
 }
 
 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
-   call to iocall_set_nml_val.  For derived type variable, recursively
-   generate calls to iocall_set_nml_val for each component.  */
+   call to iocall[IOCALL_SET_NML_VAL].  For derived type variable, recursively
+   generate calls to iocall[IOCALL_SET_NML_VAL] for each component.  */
 
 #define NML_FIRST_ARG(a) args = gfc_chainon_list (NULL_TREE, a)
 #define NML_ADD_ARG(a) args = gfc_chainon_list (args, a)
@@ -1105,6 +1216,7 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
   tree tmp;
   tree args;
   tree dtype;
+  tree dt_parm_addr;
   int n_dim; 
   int itype;
   int rank = 0;
@@ -1167,7 +1279,9 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
      The call for the scalar part transfers:
      (address, name, type, kind or string_length, dtype)  */
 
-  NML_FIRST_ARG (addr_expr);
+  dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm);
+  NML_FIRST_ARG (dt_parm_addr);
+  NML_ADD_ARG (addr_expr);
   NML_ADD_ARG (string);
   NML_ADD_ARG (IARG (ts->kind));
 
@@ -1177,7 +1291,7 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
     NML_ADD_ARG (convert (gfc_charlen_type_node, integer_zero_node));
 
   NML_ADD_ARG (dtype);
-  tmp = gfc_build_function_call (iocall_set_nml_val, args);
+  tmp = gfc_build_function_call (iocall[IOCALL_SET_NML_VAL], args);
   gfc_add_expr_to_block (block, tmp);
 
   /* If the object is an array, transfer rank times:
@@ -1185,11 +1299,12 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
 
   for ( n_dim = 0 ; n_dim < rank ; n_dim++ )
     {
-      NML_FIRST_ARG (IARG (n_dim));
+      NML_FIRST_ARG (dt_parm_addr);
+      NML_ADD_ARG (IARG (n_dim));
       NML_ADD_ARG (GFC_TYPE_ARRAY_STRIDE (dt, n_dim));
       NML_ADD_ARG (GFC_TYPE_ARRAY_LBOUND (dt, n_dim));
       NML_ADD_ARG (GFC_TYPE_ARRAY_UBOUND (dt, n_dim));
-      tmp = gfc_build_function_call (iocall_set_nml_val_dim, args);
+      tmp = gfc_build_function_call (iocall[IOCALL_SET_NML_VAL_DIM], args);
       gfc_add_expr_to_block (block, tmp);
     }
 
@@ -1221,98 +1336,142 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
    out by now.  */
 
 static tree
-build_dt (tree function, gfc_code * code)
+build_dt (tree function, gfc_code * code)
 {
-  stmtblock_t block, post_block;
+  stmtblock_t block, post_block, post_end_block;
   gfc_dt *dt;
-  tree tmp;
+  tree tmp, var;
   gfc_expr *nmlname;
   gfc_namelist *nml;
+  unsigned int mask = 0;
 
-  gfc_init_block (&block);
+  gfc_start_block (&block);
   gfc_init_block (&post_block);
+  gfc_init_block (&post_end_block);
+
+  var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm");
+
+  set_error_locus (&block, var, &code->loc);
+
+  if (last_dt == IOLENGTH)
+    {
+      gfc_inquire *inq;
+
+      inq = code->ext.inquire;
 
-  set_error_locus (&block, &code->loc);
-  dt = code->ext.dt;
+      /* First check that preconditions are met.  */
+      gcc_assert (inq != NULL);
+      gcc_assert (inq->iolength != NULL);
 
-  gcc_assert (dt != NULL);
+      /* Connect to the iolength variable.  */
+      mask |= set_parameter_ref (&block, &post_end_block, var,
+                                IOPARM_dt_iolength, inq->iolength);
+      dt = NULL;
+    }
+  else
+    {
+      dt = code->ext.dt;
+      gcc_assert (dt != NULL);
+    }
 
-  if (dt->io_unit)
+  if (dt && dt->io_unit)
     {
       if (dt->io_unit->ts.type == BT_CHARACTER)
        {
-         set_internal_unit (&block,
-                            ioparm_internal_unit,
-                            ioparm_internal_unit_len,
-                            ioparm_internal_unit_desc,
-                            dt->io_unit);
+         mask |= set_internal_unit (&block, var, dt->io_unit);
+         set_parameter_const (&block, var, IOPARM_common_unit, 0);
        }
       else
-       set_parameter_value (&block, ioparm_unit, dt->io_unit);
+       set_parameter_value (&block, var, IOPARM_common_unit, dt->io_unit);
     }
+  else
+    set_parameter_const (&block, var, IOPARM_common_unit, 0);
 
-  if (dt->rec)
-    set_parameter_value (&block, ioparm_rec, dt->rec);
+  if (dt)
+    {
+      if (dt->rec)
+       mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec);
 
-  if (dt->advance)
-    set_string (&block, &post_block, ioparm_advance, ioparm_advance_len,
-               dt->advance);
+      if (dt->advance)
+       mask |= set_string (&block, &post_block, var, IOPARM_dt_advance,
+                           dt->advance);
 
-  if (dt->format_expr)
-    set_string (&block, &post_block, ioparm_format, ioparm_format_len,
-               dt->format_expr);
+      if (dt->format_expr)
+       mask |= set_string (&block, &post_block, var, IOPARM_dt_format,
+                           dt->format_expr);
 
-  if (dt->format_label)
-    {
-      if (dt->format_label == &format_asterisk)
-       set_flag (&block, ioparm_list_format);
-      else
-        set_string (&block, &post_block, ioparm_format,
-                   ioparm_format_len, dt->format_label->format);
-    }
+      if (dt->format_label)
+       {
+         if (dt->format_label == &format_asterisk)
+           mask |= IOPARM_dt_list_format;
+         else
+           mask |= set_string (&block, &post_block, var, IOPARM_dt_format,
+                               dt->format_label->format);
+       }
 
-  if (dt->iomsg)
-    set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len,
-               dt->iomsg);
+      if (dt->iomsg)
+       mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
+                           dt->iomsg);
 
-  if (dt->iostat)
-    set_parameter_ref (&block, ioparm_iostat, dt->iostat);
+      if (dt->iostat)
+       mask |= set_parameter_ref (&block, &post_end_block, var,
+                                  IOPARM_common_iostat, dt->iostat);
 
-  if (dt->size)
-    set_parameter_ref (&block, ioparm_size, dt->size);
+      if (dt->size)
+       mask |= set_parameter_ref (&block, &post_end_block, var,
+                                  IOPARM_dt_size, dt->size);
 
-  if (dt->err)
-    set_flag (&block, ioparm_err);
+      if (dt->err)
+       mask |= IOPARM_common_err;
 
-  if (dt->eor)
-    set_flag(&block, ioparm_eor);
+      if (dt->eor)
+       mask |= IOPARM_common_eor;
 
-  if (dt->end)
-    set_flag(&block, ioparm_end);
+      if (dt->end)
+       mask |= IOPARM_common_end;
 
-  if (dt->namelist)
-    {
-      if (dt->format_expr || dt->format_label)
-        gfc_internal_error ("build_dt: format with namelist");
+      if (dt->namelist)
+       {
+         if (dt->format_expr || dt->format_label)
+           gfc_internal_error ("build_dt: format with namelist");
+
+         nmlname = gfc_new_nml_name_expr (dt->namelist->name);
 
-      nmlname = gfc_new_nml_name_expr(dt->namelist->name);
+         mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name,
+                             nmlname);
 
-      set_string (&block, &post_block, ioparm_namelist_name,
-                 ioparm_namelist_name_len, nmlname);
+         if (last_dt == READ)
+           mask |= IOPARM_dt_namelist_read_mode;
 
-      if (last_dt == READ)
-       set_flag (&block, ioparm_namelist_read_mode);
+         set_parameter_const (&block, var, IOPARM_common_flags, mask);
 
-      for (nml = dt->namelist->namelist; nml; nml = nml->next)
-       transfer_namelist_element (&block, nml->sym->name, nml->sym,
-                                  NULL, NULL);
+         dt_parm = var;
+
+         for (nml = dt->namelist->namelist; nml; nml = nml->next)
+           transfer_namelist_element (&block, nml->sym->name, nml->sym,
+                                      NULL, NULL);
+       }
+      else
+       set_parameter_const (&block, var, IOPARM_common_flags, mask);
     }
+  else
+    set_parameter_const (&block, var, IOPARM_common_flags, mask);
 
-  tmp = gfc_build_function_call (*function, NULL_TREE);
+  tmp = gfc_build_addr_expr (NULL_TREE, var);
+  tmp = gfc_chainon_list (NULL_TREE, tmp);
+  tmp = gfc_build_function_call (function, tmp);
   gfc_add_expr_to_block (&block, tmp);
 
   gfc_add_block_to_block (&block, &post_block);
 
+  dt_parm = var;
+  dt_post_end_block = &post_end_block;
+
+  gfc_add_expr_to_block (&block, gfc_trans_code (code->block->next));
+
+  dt_parm = NULL;
+  dt_post_end_block = NULL;
+
   return gfc_finish_block (&block);
 }
 
@@ -1324,31 +1483,8 @@ build_dt (tree * function, gfc_code * code)
 tree
 gfc_trans_iolength (gfc_code * code)
 {
-  stmtblock_t block;
-  gfc_inquire *inq;
-  tree dt;
-
-  gfc_init_block (&block);
-
-  set_error_locus (&block, &code->loc);
-
-  inq = code->ext.inquire;
-
-  /* First check that preconditions are met.  */
-  gcc_assert (inq != NULL);
-  gcc_assert (inq->iolength != NULL);
-
-  /* Connect to the iolength variable.  */
-  if (inq->iolength)
-    set_parameter_ref (&block, ioparm_iolength, inq->iolength);
-
-  /* Actual logic.  */
   last_dt = IOLENGTH;
-  dt = build_dt(&iocall_iolength, code);
-
-  gfc_add_expr_to_block (&block, dt);
-
-  return gfc_finish_block (&block);
+  return build_dt (iocall[IOCALL_IOLENGTH], code);
 }
 
 
@@ -1357,9 +1493,8 @@ gfc_trans_iolength (gfc_code * code)
 tree
 gfc_trans_read (gfc_code * code)
 {
-
   last_dt = READ;
-  return build_dt (&iocall_read, code);
+  return build_dt (iocall[IOCALL_READ], code);
 }
 
 
@@ -1368,9 +1503,8 @@ gfc_trans_read (gfc_code * code)
 tree
 gfc_trans_write (gfc_code * code)
 {
-
   last_dt = WRITE;
-  return build_dt (&iocall_write, code);
+  return build_dt (iocall[IOCALL_WRITE], code);
 }
 
 
@@ -1387,28 +1521,32 @@ gfc_trans_dt_end (gfc_code * code)
   switch (last_dt)
     {
     case READ:
-      function = iocall_read_done;
+      function = iocall[IOCALL_READ_DONE];
       break;
 
     case WRITE:
-      function = iocall_write_done;
+      function = iocall[IOCALL_WRITE_DONE];
       break;
 
     case IOLENGTH:
-      function = iocall_iolength_done;
+      function = iocall[IOCALL_IOLENGTH_DONE];
       break;
 
     default:
       gcc_unreachable ();
     }
 
-  tmp = gfc_build_function_call (function, NULL);
+  tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
+  tmp = gfc_chainon_list (NULL_TREE, tmp);
+  tmp = gfc_build_function_call (function, tmp);
   gfc_add_expr_to_block (&block, tmp);
+  gfc_add_block_to_block (&block, dt_post_end_block);
+  gfc_init_block (dt_post_end_block);
 
   if (last_dt != IOLENGTH)
     {
       gcc_assert (code->ext.dt != NULL);
-      io_result (&block, code->ext.dt->err,
+      io_result (&block, dt_parm, code->ext.dt->err,
                 code->ext.dt->end, code->ext.dt->eor);
     }
 
@@ -1523,22 +1661,22 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr)
     {
     case BT_INTEGER:
       arg2 = build_int_cst (NULL_TREE, kind);
-      function = iocall_x_integer;
+      function = iocall[IOCALL_X_INTEGER];
       break;
 
     case BT_REAL:
       arg2 = build_int_cst (NULL_TREE, kind);
-      function = iocall_x_real;
+      function = iocall[IOCALL_X_REAL];
       break;
 
     case BT_COMPLEX:
       arg2 = build_int_cst (NULL_TREE, kind);
-      function = iocall_x_complex;
+      function = iocall[IOCALL_X_COMPLEX];
       break;
 
     case BT_LOGICAL:
       arg2 = build_int_cst (NULL_TREE, kind);
-      function = iocall_x_logical;
+      function = iocall[IOCALL_X_LOGICAL];
       break;
 
     case BT_CHARACTER:
@@ -1550,7 +1688,7 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr)
          gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
          arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
        }
-      function = iocall_x_character;
+      function = iocall[IOCALL_X_CHARACTER];
       break;
 
     case BT_DERIVED:
@@ -1584,7 +1722,9 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr)
       internal_error ("Bad IO basetype (%d)", ts->type);
     }
 
-  args = gfc_chainon_list (NULL_TREE, addr_expr);
+  tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
+  args = gfc_chainon_list (NULL_TREE, tmp);
+  args = gfc_chainon_list (args, addr_expr);
   args = gfc_chainon_list (args, arg2);
 
   tmp = gfc_build_function_call (function, args);
@@ -1609,10 +1749,12 @@ transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr)
 
   kind_arg = build_int_cst (NULL_TREE, ts->kind);
 
-  args = gfc_chainon_list (NULL_TREE, addr_expr);
+  tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
+  args = gfc_chainon_list (NULL_TREE, tmp);
+  args = gfc_chainon_list (args, addr_expr);
   args = gfc_chainon_list (args, kind_arg);
   args = gfc_chainon_list (args, charlen_arg);
-  tmp = gfc_build_function_call (iocall_x_array, args);
+  tmp = gfc_build_function_call (iocall[IOCALL_X_ARRAY], args);
   gfc_add_expr_to_block (&se->pre, tmp);
   gfc_add_block_to_block (&se->pre, &se->post);
 }
index 315c0f9..23dabc9 100644 (file)
@@ -1,3 +1,11 @@
+2005-11-21  Jakub Jelinek  <jakub@redhat.com>
+
+       PR fortran/24774
+       * gfortran.dg/inquire_9.f90: New test.
+
+       PR fortran/21647
+       * gfortran.fortran-torture/execute/inquire_5.f90: New test.
+
 2005-11-21  Eric Botcazou  <ebotcazou@libertysurf.fr>
 
        PR libfortran/24432
diff --git a/gcc/testsuite/gfortran.dg/inquire_9.f90 b/gcc/testsuite/gfortran.dg/inquire_9.f90
new file mode 100644 (file)
index 0000000..f1f8ffd
--- /dev/null
@@ -0,0 +1,24 @@
+! PR fortran/24774
+! { dg-do run }
+  logical :: l
+  l = .true.
+  inquire (file='inquire_9 file that should not exist', exist=l)
+  if (l) call abort
+  l = .true.
+  inquire (unit=-16, exist=l)
+  if (l) call abort
+  open (unit=16, file='inquire_9.tst')
+  print (unit=16, fmt='(a)'), 'Test'
+  l = .false.
+  inquire (unit=16, exist=l)
+  if (.not.l) call abort
+  l = .false.
+  inquire (file='inquire_9.tst', exist=l)
+  if (.not.l) call abort
+  close (unit=16)
+  l = .false.
+  inquire (file='inquire_9.tst', exist=l)
+  if (.not.l) call abort
+  open (unit=16, file='inquire_9.tst')
+  close (unit=16, status='delete')
+end
diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/inquire_5.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/inquire_5.f90
new file mode 100644 (file)
index 0000000..1077650
--- /dev/null
@@ -0,0 +1,32 @@
+! PR fortran/21647
+program inquire_5
+  integer (kind = 8) :: unit8
+  logical (kind = 8) :: exist8
+  integer (kind = 4) :: unit4
+  logical (kind = 4) :: exist4
+  integer (kind = 2) :: unit2
+  logical (kind = 2) :: exist2
+  integer (kind = 1) :: unit1
+  logical (kind = 1) :: exist1
+  character (len = 6) :: del
+  unit8 = 78
+  open (file = 'inquire_5.txt', unit = unit8)
+  unit8 = -1
+  exist8 = .false.
+  unit4 = -1
+  exist4 = .false.
+  unit2 = -1
+  exist2 = .false.
+  unit1 = -1
+  exist1 = .false.
+  inquire (file = 'inquire_5.txt', number = unit8, exist = exist8)
+  if (unit8 .ne. 78 .or. .not. exist8) call abort
+  inquire (file = 'inquire_5.txt', number = unit4, exist = exist4)
+  if (unit4 .ne. 78 .or. .not. exist4) call abort
+  inquire (file = 'inquire_5.txt', number = unit2, exist = exist2)
+  if (unit2 .ne. 78 .or. .not. exist2) call abort
+  inquire (file = 'inquire_5.txt', number = unit1, exist = exist1)
+  if (unit1 .ne. 78 .or. .not. exist1) call abort
+  del = 'delete'
+  close (unit = 78, status = del)
+end
index a5e8af3..80ff969 100644 (file)
@@ -1,3 +1,238 @@
+2005-11-21  Jakub Jelinek  <jakub@redhat.com>
+
+       PR fortran/24774
+       PR fortran/14943
+       PR fortran/21647
+       * Makefile.am (AM_CPPFLAGS): Add gcc directories as -I paths,
+       add -D_GNU_SOURCE.
+       * Makefile.in: Regenerated.
+       * acinclude.m4 (LIBGFOR_CHECK_SYNC_FETCH_AND_ADD,
+       LIBGFOR_CHECK_GTHR_DEFAULT, LIBGFOR_CHECK_PRAGMA_WEAK): New macros.
+       * configure.ac: Add them.
+       * configure: Rebuilt.
+       * config.h.in: Rebuilt.
+       * libtool-version: Bump libgfortran.so SONAME to libgfortran.so.1.
+       * libgfortran.h (library_start, show_locus, internal_error,
+       generate_error, find_option): Add st_parameter_common * argument.
+       (library_end): Change into a dummy macro.
+       * io/io.h: Include gthr.h.
+       (SUPPORTS_WEAK): Define if HAVE_PRAGMA_WEAK.
+       (CHARACTER): Remove define.
+       (st_parameter, global_t): Remove typedef.
+       (ioparm, g, ionml, current_unit): Remove variables.
+       (init_error_stream): Remove prototype.
+       (CHARACTER1, CHARACTER2): Define.
+       (st_parameter_common, st_parameter_open, st_parameter_close,
+       st_parameter_filepos, st_parameter_inquire, st_parameter_dt): New
+       typedefs.
+       (IOPARM_LIBRETURN_MASK, IOPARM_LIBRETURN_OK, IOPARM_LIBRETURN_ERROR,
+       IOPARM_LIBRETURN_END, IOPARM_LIBRETURN_EOR, IOPARM_ERR, IOPARM_END,
+       IOPARM_EOR, IOPARM_HAS_IOSTAT, IOPARM_HAS_IOMSG, IOPARM_COMMON_MASK,
+       IOPARM_OPEN_HAS_RECL_IN, IOPARM_OPEN_HAS_FILE, IOPARM_OPEN_HAS_STATUS,
+       IOPARM_OPEN_HAS_ACCESS, IOPARM_OPEN_HAS_FORM, IOPARM_OPEN_HAS_BLANK,
+       IOPARM_OPEN_HAS_POSITION, IOPARM_OPEN_HAS_ACTION,
+       IOPARM_OPEN_HAS_DELIM, IOPARM_OPEN_HAS_PAD, IOPARM_CLOSE_HAS_STATUS,
+       IOPARM_INQUIRE_HAS_EXIST, IOPARM_INQUIRE_HAS_OPENED,
+       IOPARM_INQUIRE_HAS_NUMBER, IOPARM_INQUIRE_HAS_NAMED,
+       IOPARM_INQUIRE_HAS_NEXTREC, IOPARM_INQUIRE_HAS_RECL_OUT,
+       IOPARM_INQUIRE_HAS_FILE, IOPARM_INQUIRE_HAS_ACCESS,
+       IOPARM_INQUIRE_HAS_FORM, IOPARM_INQUIRE_HAS_BLANK,
+       IOPARM_INQUIRE_HAS_POSITION, IOPARM_INQUIRE_HAS_ACTION,
+       IOPARM_INQUIRE_HAS_DELIM, IOPARM_INQUIRE_HAS_PAD,
+       IOPARM_INQUIRE_HAS_NAME, IOPARM_INQUIRE_HAS_SEQUENTIAL,
+       IOPARM_INQUIRE_HAS_DIRECT, IOPARM_INQUIRE_HAS_FORMATTED,
+       IOPARM_INQUIRE_HAS_UNFORMATTED, IOPARM_INQUIRE_HAS_READ,
+       IOPARM_INQUIRE_HAS_WRITE, IOPARM_INQUIRE_HAS_READWRITE,
+       IOPARM_DT_LIST_FORMAT, IOPARM_DT_NAMELIST_READ_MODE,
+       IOPARM_DT_HAS_REC, IOPARM_DT_HAS_SIZE, IOPARM_DT_HAS_IOLENGTH,
+       IOPARM_DT_HAS_FORMAT, IOPARM_DT_HAS_ADVANCE,
+       IOPARM_DT_HAS_INTERNAL_UNIT, IOPARM_DT_HAS_NAMELIST_NAME,
+       IOPARM_DT_IONML_SET): Define.
+       (gfc_unit): Add lock, waiting and close fields.  Change file
+       from flexible array member into pointer to char.
+       (open_external): Add st_parameter_open * argument.
+       (find_file, file_exists): Add file and file_len arguments.
+       (flush_all_units): New prototype.
+       (max_offset, unit_root, unit_lock): New variable.
+       (is_internal_unit, is_array_io, next_array_record,
+       parse_format, next_format, unget_format, format_error,
+       read_block, write_block, next_record, convert_real,
+       read_a, read_f, read_l, read_x, read_radix, read_decimal,
+       list_formatted_read, finish_list_read, namelist_read,
+       namelist_write, write_a, write_b, write_d, write_e, write_en,
+       write_es, write_f, write_i, write_l, write_o, write_x, write_z,
+       list_formatted_write, get_unit): Add st_parameter_dt * argument.
+       (insert_unit): Remove prototype.
+       (find_or_create_unit, unlock_unit): New prototype.
+       (new_unit): Return gfc_unit *.  Add st_parameter_open *
+       and gfc_unit * arguments.
+       (free_fnodes): Remove prototype.
+       (free_format_data): New prototype.
+       (scratch): Remove.
+       (init_at_eol): Remove prototype.
+       (free_ionml): New prototype.
+       (inc_waiting_locked, predec_waiting_locked, dec_waiting_unlocked):
+       New inline functions.
+       * io/unit.c (max_offset, unit_root, unit_lock): New variables.
+       (insert): Adjust os_error caller.
+       (insert_unit): Made static.  Allocate memory here, initialize
+       lock and after inserting it return it, locked.
+       (delete_unit): Adjust for deletion of g.
+       (find_unit_1): New function.
+       (find_unit): Use it.
+       (find_or_create_unit): New function.
+       (get_unit): Add dtp argument, change meaning of the int argument
+       as creation request flag.  Adjust for different st_* calling
+       conventions, lock internal unit's lock before returning it
+       and removal of g.  Call find_unit_1 instead of find_unit.
+       (is_internal_unit, is_array_io): Add dtp argument, adjust for
+       removal of most of global variables.
+       (init_units): Initialize unit_lock.  Adjust insert_unit callers
+       and adjust for g removal.
+       (close_unit_1): New function.
+       (close_unit): Use it.
+       (unlock_unit): New function.
+       (close_units): Lock unit_lock, use close_unit_1 rather than
+       close_unit.
+       * io/close.c (st_close): Add clp argument.  Adjust for new
+       st_* calling conventions and internal function API changes.
+       * io/file_pos.c (st_backspace, st_endfile, st_rewind, st_flush):
+       Add fpp argument.  Adjust for new st_* calling conventions and
+       internal function API changes.
+       (formatted_backspace, unformatted_backspace): Likewise.  Add
+       u argument.
+       * io/open.c (edit_modes, st_open): Add opp argument.  Adjust for
+       new st_* calling conventions and internal function API changes.
+       (already_open): Likewise.  If not HAVE_UNLINK_OPEN_FILE, unlink
+       scratch file.  Instead of calling close_unit just call sclose,
+       free u->file if any and clear a few u fields before calling
+       new_unit.
+       (new_unit): Return gfc_unit *.  Add opp and u arguments.
+       Adjust for new st_* calling conventions and internal function
+       API changes.  Don't allocate unit here, rather than work with
+       already created unit u already locked on entry.  In case
+       of failure, close_unit it.
+       * io/unix.c: Include unix.h.
+       (BUFFER_SIZE, unix_stream): Moved to unix.h.
+       (unit_to_fd): Add unlock_unit call.
+       (tempfile): Add opp argument, use its fields rather than ioparm.
+       (regular_file): Likewise.
+       (open_external): Likewise.  Only unlink file if fd >= 0.
+       (init_error_stream): Add error argument, set structure it points
+       to rather than filling static variable and returning its address.
+       (FIND_FILE0_DECL, FIND_FILE0_ARGS): Define.
+       (find_file0): Use them.  Don't crash if u->s == NULL.
+       (find_file): Add file and file_len arguments, use them instead
+       of ioparm.  Add locking.  Pass either an array of 2 struct stat
+       or file and file_len pair to find_file0.
+       (flush_all_units_1, flush_all_units): New functions.
+       (file_exists): Add file and file_len arguments, use them instead
+       of ioparm.
+       * io/unix.h: New file.
+       * io/lock.c (ioparm, g, ionml): Remove variables.
+       (library_start): Add cmp argument, adjust for new st_* calling
+       conventions.
+       (library_end): Remove.
+       (free_ionml): New function.
+       * io/inquire.c (inquire_via_unit, inquire_via_filename,
+       st_inquire): Add iqp argument, adjust for new st_* calling
+       conventions and internal function API changes.
+       * io/format.c (FARRAY_SIZE): Decrease to 64.
+       (fnode_array, format_data): New typedefs.
+       (avail, array, format_string, string, error, saved_token, value,
+       format_string_len, reversion_ok, saved_format): Remove variables.
+       (colon_node): Add const.
+       (free_fnode, free_fnodes): Remove.
+       (free_format_data): New function.
+       (next_char, unget_char, get_fnode, format_lex, parse_format_list,
+       format_error, parse_format, revert, unget_format, next_test): Add
+       fmt or dtp arguments, pass it all around, adjust for internal
+       function API changes and adjust for removal of global variables.
+       (next_format): Likewise.  Constify return type.
+       (next_format0): Constify return type.
+       * io/transfer.c (current_unit, sf_seen_eor, eor_condition, max_pos,
+       skips, pending_spaces, scratch, line_buffer, advance_status,
+       transfer): Remove variables.
+       (transfer_integer, transfer_real, transfer_logical,
+       transfer_character, transfer_complex, transfer_array, current_mode,
+       read_sf, read_block, read_block_direct, write_block,
+       write_block_direct, unformatted_read, unformatted_write,
+       type_name, write_constant_string, require_type,
+       formatted_transfer_scalar, us_read, us_write, pre_position,
+       data_transfer_init, next_record_r, next_record_w, next_record,
+       finalize_transfer, iolength_transfer, iolength_transfer_init,
+       st_iolength, st_iolength_done, st_read, st_read_done, st_write,
+       st_write_done, st_set_nml_var, st_set_nml_var_dim,
+       next_array_record): Add dtp argument, pass it all around, adjust for
+       internal function API changes and removal of global variables.
+       * io/list_read.c (repeat_count, saved_length, saved_used,
+       input_complete, at_eol, comma_flag, last_char, saved_string,
+       saved_type, namelist_mode, nml_read_error, value, parse_err_msg,
+       nml_err_msg, prev_nl): Remove variables.
+       (push_char, free_saved, next_char, unget_char, eat_spaces,
+       eat_separator, finish_separator, nml_bad_return, convert_integer,
+       parse_repeat, read_logical, read_integer, read_character,
+       parse_real, read_complex, read_real, check_type,
+       list_formatted_read_scalar, list_formatted_read, finish_list_read,
+       find_nml_node, nml_untouch_nodes, nml_match_name, nml_query,
+       namelist_read): Add dtp argument, pass it all around, adjust for
+       internal function API changes and removal of global variables.
+       (nml_parse_qualifier): Likewise.  Add parse_err_msg argument.
+       (nml_read_obj): Likewise.  Add pprev_nl, nml_err_msg, clow and
+       chigh arguments.
+       (nml_get_obj_data): Likewise.  Add pprev_nl and nml_err_msg
+       arguments.
+       (init_at_eol): Removed.
+       * io/read.c (convert_real, read_l, read_a, next_char, read_decimal,
+       read_radix, read_f, read_x): Add dtp argument, pass it all around,
+       adjust for internal function API changes and removal of global
+       variables.
+       (set_integer): Adjust internal_error caller.
+       * io/write.c (no_leading_blank, nml_delim): Remove variables.
+       (write_a, calculate_sign, calculate_G_format, output_float,
+       write_l, write_float, write_int, write_decimal, write_i, write_b,
+       write_o, write_z, write_d, write_e, write_f, write_en, write_es,
+       write_x, write_char, write_logical, write_integer, write_character,
+       write_real, write_complex, write_separator,
+       list_formatted_write_scalar, list_formatted_write, nml_write_obj,
+       namelist_write): Add dtp argument, pass it all around, adjust for
+       internal function API changes and removal of global variables.
+       (extract_int, extract_uint, extract_real): Adjust internal_error
+       callers.
+       * runtime/fpu.c (_GNU_SOURCE): Don't define here.
+       * runtime/error.c: Include ../io/unix.h.
+       (filename, line): Remove variables.
+       (st_printf): Pass address of a local variable to init_error_stream.
+       (show_locus): Add cmp argument.  Use fields it points to rather than
+       filename and line variables.
+       (os_error, runtime_error): Remove show_locus calls.
+       (internal_error): Add cmp argument.  Pass it down to show_locus.
+       (generate_error): Likewise.  Use flags bitmask instead of non-NULL
+       check for iostat and iomsg parameter presence, adjust for st_*
+       calling convention changes.
+       * runtime/stop.c (stop_numeric, stop_string): Remove show_locus
+       calls.
+       * runtime/pause.c (pause_numeric, pause_string): Likewise.
+       * runtime/string.c: Include ../io/io.h.
+       (find_option): Add cmp argument.  Pass it down to generate_error.
+       * intrinsics/flush.c (recursive_flush): Remove.
+       (flush_i4, flush_i8): Use flush_all_units.  Add unlock_unit
+       call.
+       * intrinsics/rand.c: Include ../io/io.h.
+       (rand_seed_lock): New variable.
+       (srand, irand): Add locking.
+       (init): New constructor function.
+       * intrinsics/random.c: Include ../io/io.h.
+       (random_lock): New variable.
+       (random_r4, random_r8, arandom_r4, arandom_r8): Add locking.
+       (random_seed): Likewise.  open failed if fd < 0.  Set i correctly.
+       (init): New constructor function.
+       * intrinsics/system_clock.c (tp0, t0): Remove.
+       (system_clock_4, system_clock_8): Don't subtract tp0/t0 from current
+       time, use just integer arithmetics.
+       * intrinsics/tty.c (isatty_l4, isatty_l8, ttynam_sub): Add
+       unlock_unit calls.
+
 2005-11-20  Richard Henderson  <rth@redhat.com>
 
         * Makefile.am: Revert 2005-11-14 change.  Enable -free-vectorize
index 221f787..ff8b029 100644 (file)
@@ -16,7 +16,9 @@ libgfortranbegin_la_LDFLAGS = -static
 
 ## io.h conflicts with some a system header on some platforms, so
 ## use -iquote
-AM_CPPFLAGS = -iquote$(srcdir)/io
+AM_CPPFLAGS = -iquote$(srcdir)/io -I$(srcdir)/$(MULTISRCTOP)../gcc \
+             -I$(srcdir)/$(MULTISRCTOP)../gcc/config \
+             -I$(MULTIBUILDTOP)../../gcc -D_GNU_SOURCE
 
 gfor_io_src= \
 io/close.c \
index 1d995fd..c34a86c 100644 (file)
@@ -358,7 +358,10 @@ toolexeclib_LTLIBRARIES = libgfortran.la libgfortranbegin.la
 libgfortran_la_LDFLAGS = -version-info `grep -v '^\#' $(srcdir)/libtool-version` -lm $(extra_ldflags_libgfortran)
 libgfortranbegin_la_SOURCES = fmain.c
 libgfortranbegin_la_LDFLAGS = -static
-AM_CPPFLAGS = -iquote$(srcdir)/io
+AM_CPPFLAGS = -iquote$(srcdir)/io -I$(srcdir)/$(MULTISRCTOP)../gcc \
+             -I$(srcdir)/$(MULTISRCTOP)../gcc/config \
+             -I$(MULTIBUILDTOP)../../gcc -D_GNU_SOURCE
+
 gfor_io_src = \
 io/close.c \
 io/file_pos.c \
index 857733a..9d06a8b 100644 (file)
@@ -149,6 +149,44 @@ extern void bar(void) __attribute__((alias(ULP "foo")));],
       [Define to 1 if the target supports __attribute__((alias(...))).])
   fi])
 
+dnl Check whether the target supports __sync_fetch_and_add.
+AC_DEFUN([LIBGFOR_CHECK_SYNC_FETCH_AND_ADD], [
+  AC_CACHE_CHECK([whether the target supports __sync_fetch_and_add],
+                have_sync_fetch_and_add, [
+  AC_TRY_LINK([int foovar = 0;], [
+if (foovar <= 0) return __sync_fetch_and_add (&foovar, 1);
+if (foovar > 10) return __sync_add_and_fetch (&foovar, -1);],
+             have_sync_fetch_and_add=yes, have_sync_fetch_and_add=no)])
+  if test $have_sync_fetch_and_add = yes; then
+    AC_DEFINE(HAVE_SYNC_FETCH_AND_ADD, 1,
+             [Define to 1 if the target supports __sync_fetch_and_add])
+  fi])
+
+dnl Check if threads are supported.
+AC_DEFUN([LIBGFOR_CHECK_GTHR_DEFAULT], [
+  AC_CACHE_CHECK([configured target thread model],
+                target_thread_file, [
+target_thread_file=`$CC -v 2>&1 | sed -n 's/^Thread model: //p'`])
+
+  if test $target_thread_file != single; then
+    AC_DEFINE(HAVE_GTHR_DEFAULT, 1,
+             [Define if the compiler has a thread header that is non single.])
+  fi])
+
+dnl Check for pragma weak.
+AC_DEFUN([LIBGFOR_CHECK_PRAGMA_WEAK], [
+  AC_CACHE_CHECK([whether pragma weak works],
+                have_pragma_weak, [
+  gfor_save_CFLAGS="$CFLAGS"
+  CFLAGS="$CFLAGS -Wunknown-pragmas"
+  AC_TRY_COMPILE([void foo (void);
+#pragma weak foo], [if (foo) foo ();],
+                have_pragma_weak=yes, have_pragma_weak=no)])
+  if test $have_pragma_weak = yes; then
+    AC_DEFINE(HAVE_PRAGMA_WEAK, 1,
+             [Define to 1 if the target supports #pragma weak])
+  fi])
+
 dnl Check whether target can unlink a file still open.
 AC_DEFUN([LIBGFOR_CHECK_UNLINK_OPEN_FILE], [
   AC_CACHE_CHECK([whether the target can unlink an open file],
index 04cda0c..ba0ca49 100644 (file)
 /* libc includes getuid */
 #undef HAVE_GETUID
 
+/* Define if the compiler has a thread header that is non single. */
+#undef HAVE_GTHR_DEFAULT
+
 /* libm includes hypot */
 #undef HAVE_HYPOT
 
 /* libm includes powl */
 #undef HAVE_POWL
 
+/* Define to 1 if the target supports #pragma weak */
+#undef HAVE_PRAGMA_WEAK
+
 /* libm includes round */
 #undef HAVE_ROUND
 
 /* Define to 1 if you have the `symlink' function. */
 #undef HAVE_SYMLINK
 
+/* Define to 1 if the target supports __sync_fetch_and_add */
+#undef HAVE_SYNC_FETCH_AND_ADD
+
 /* Define to 1 if you have the <sys/mman.h> header file. */
 #undef HAVE_SYS_MMAN_H
 
index a76360d..6799fa5 100755 (executable)
@@ -20699,6 +20699,166 @@ _ACEOF
 
   fi
 
+# Check out sync builtins support.
+
+  echo "$as_me:$LINENO: checking whether the target supports __sync_fetch_and_add" >&5
+echo $ECHO_N "checking whether the target supports __sync_fetch_and_add... $ECHO_C" >&6
+if test "${have_sync_fetch_and_add+set}" = set; then
+  echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+
+  if test x$gcc_no_link = xyes; then
+  { { echo "$as_me:$LINENO: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&5
+echo "$as_me: error: Link tests are not allowed after GCC_NO_EXECUTABLES." >&2;}
+   { (exit 1); exit 1; }; }
+fi
+cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h.  */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h.  */
+int foovar = 0;
+int
+main ()
+{
+
+if (foovar <= 0) return __sync_fetch_and_add (&foovar, 1);
+if (foovar > 10) return __sync_add_and_fetch (&foovar, -1);
+  ;
+  return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext conftest$ac_exeext
+if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
+  (eval $ac_link) 2>conftest.er1
+  ac_status=$?
+  grep -v '^ *+' conftest.er1 >conftest.err
+  rm -f conftest.er1
+  cat conftest.err >&5
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); } &&
+        { ac_try='test -z "$ac_c_werror_flag"
+                        || test ! -s conftest.err'
+  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+  (eval $ac_try) 2>&5
+  ac_status=$?
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); }; } &&
+        { ac_try='test -s conftest$ac_exeext'
+  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+  (eval $ac_try) 2>&5
+  ac_status=$?
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); }; }; then
+  have_sync_fetch_and_add=yes
+else
+  echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+have_sync_fetch_and_add=no
+fi
+rm -f conftest.err conftest.$ac_objext \
+      conftest$ac_exeext conftest.$ac_ext
+fi
+echo "$as_me:$LINENO: result: $have_sync_fetch_and_add" >&5
+echo "${ECHO_T}$have_sync_fetch_and_add" >&6
+  if test $have_sync_fetch_and_add = yes; then
+
+cat >>confdefs.h <<\_ACEOF
+#define HAVE_SYNC_FETCH_AND_ADD 1
+_ACEOF
+
+  fi
+
+# Check out thread support.
+
+  echo "$as_me:$LINENO: checking configured target thread model" >&5
+echo $ECHO_N "checking configured target thread model... $ECHO_C" >&6
+if test "${target_thread_file+set}" = set; then
+  echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+
+target_thread_file=`$CC -v 2>&1 | sed -n 's/^Thread model: //p'`
+fi
+echo "$as_me:$LINENO: result: $target_thread_file" >&5
+echo "${ECHO_T}$target_thread_file" >&6
+
+  if test $target_thread_file != single; then
+
+cat >>confdefs.h <<\_ACEOF
+#define HAVE_GTHR_DEFAULT 1
+_ACEOF
+
+  fi
+
+# Check out #pragma weak.
+
+  echo "$as_me:$LINENO: checking whether pragma weak works" >&5
+echo $ECHO_N "checking whether pragma weak works... $ECHO_C" >&6
+if test "${have_pragma_weak+set}" = set; then
+  echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+
+  gfor_save_CFLAGS="$CFLAGS"
+  CFLAGS="$CFLAGS -Wunknown-pragmas"
+  cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h.  */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h.  */
+void foo (void);
+#pragma weak foo
+int
+main ()
+{
+if (foo) foo ();
+  ;
+  return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext
+if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
+  (eval $ac_compile) 2>conftest.er1
+  ac_status=$?
+  grep -v '^ *+' conftest.er1 >conftest.err
+  rm -f conftest.er1
+  cat conftest.err >&5
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); } &&
+        { ac_try='test -z "$ac_c_werror_flag"
+                        || test ! -s conftest.err'
+  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+  (eval $ac_try) 2>&5
+  ac_status=$?
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); }; } &&
+        { ac_try='test -s conftest.$ac_objext'
+  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+  (eval $ac_try) 2>&5
+  ac_status=$?
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); }; }; then
+  have_pragma_weak=yes
+else
+  echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+have_pragma_weak=no
+fi
+rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+fi
+echo "$as_me:$LINENO: result: $have_pragma_weak" >&5
+echo "${ECHO_T}$have_pragma_weak" >&6
+  if test $have_pragma_weak = yes; then
+
+cat >>confdefs.h <<\_ACEOF
+#define HAVE_PRAGMA_WEAK 1
+_ACEOF
+
+  fi
+
 # Various other checks on target
 
   echo "$as_me:$LINENO: checking whether the target can unlink an open file" >&5
index e8e983b..7dc9298 100644 (file)
@@ -374,6 +374,15 @@ LIBGFOR_CHECK_ATTRIBUTE_VISIBILITY
 LIBGFOR_CHECK_ATTRIBUTE_DLLEXPORT
 LIBGFOR_CHECK_ATTRIBUTE_ALIAS
 
+# Check out sync builtins support.
+LIBGFOR_CHECK_SYNC_FETCH_AND_ADD
+
+# Check out thread support.
+LIBGFOR_CHECK_GTHR_DEFAULT
+
+# Check out #pragma weak.
+LIBGFOR_CHECK_PRAGMA_WEAK
+
 # Various other checks on target
 LIBGFOR_CHECK_UNLINK_OPEN_FILE
 
index a0ca44d..2164b47 100644 (file)
@@ -41,19 +41,6 @@ Boston, MA 02110-1301, USA.  */
 /* SUBROUTINE FLUSH(UNIT)
    INTEGER, INTENT(IN), OPTIONAL :: UNIT  */
 
-static void
-recursive_flush (gfc_unit *us)
-{
-  /* There can be no open files.  */
-  if (us == NULL)
-    return;
-
-  flush (us->s);
-  recursive_flush (us->left);
-  recursive_flush (us->right);
-}
-
-
 extern void flush_i4 (GFC_INTEGER_4 *);
 export_proto(flush_i4);
 
@@ -64,15 +51,15 @@ flush_i4 (GFC_INTEGER_4 *unit)
 
   /* flush all streams */
   if (unit == NULL)
-    {
-      us = g.unit_root;
-      recursive_flush(us);
-    }
+    flush_all_units ();
   else
     {
-      us = find_unit(*unit);
+      us = find_unit (*unit);
       if (us != NULL)
-        flush (us->s);
+       {
+         flush (us->s);
+         unlock_unit (us);
+       }
     }
 }
 
@@ -87,14 +74,14 @@ flush_i8 (GFC_INTEGER_8 *unit)
 
   /* flush all streams */
   if (unit == NULL)
-    {
-      us = g.unit_root;
-      recursive_flush(us);
-    }
+    flush_all_units ();
   else
     {
-      us = find_unit(*unit);
+      us = find_unit (*unit);
       if (us != NULL)
-        flush (us->s);
+       {
+         flush (us->s);
+         unlock_unit (us);
+       }
     }
 }
index a580060..7af525e 100644 (file)
@@ -1,5 +1,5 @@
 /* Implementation of the IRAND, RAND, and SRAND intrinsics.
-   Copyright (C) 2004 Free Software Foundation, Inc.
+   Copyright (C) 2004, 2005 Free Software Foundation, Inc.
    Contributed by Steven G. Kargl <kargls@comcast.net>.
 
 This file is part of the GNU Fortran 95 runtime library (libgfortran).
@@ -37,12 +37,18 @@ Boston, MA 02110-1301, USA.  */
 
 #include "config.h"
 #include "libgfortran.h"
+#include "../io/io.h"
 
 #define GFC_RAND_A     16807
 #define GFC_RAND_M     2147483647
 #define GFC_RAND_M1    (GFC_RAND_M - 1)
 
 static GFC_UINTEGER_8 rand_seed = 1;
+#ifdef __GTHREAD_MUTEX_INIT
+static __gthread_mutex_t rand_seed_lock = __GTHREAD_MUTEX_INIT;
+#else
+static __gthread_mutex_t rand_seed_lock;
+#endif
 
 
 /* Set the seed of the irand generator.  Note 0 is a bad seed.  */
@@ -59,7 +65,9 @@ export_proto_np(PREFIX(srand));
 void
 PREFIX(srand) (GFC_INTEGER_4 *i)
 {
+  __gthread_mutex_lock (&rand_seed_lock);
   srand_internal (*i);
+  __gthread_mutex_unlock (&rand_seed_lock);
 }
 
 /* Return an INTEGER in the range [1,GFC_RAND_M-1].  */
@@ -76,6 +84,8 @@ irand (GFC_INTEGER_4 *i)
   else
     j = 0;
 
+  __gthread_mutex_lock (&rand_seed_lock);
+
   switch (j)
   {
     /* Return the next RN. */
@@ -95,8 +105,11 @@ irand (GFC_INTEGER_4 *i)
    }
 
    rand_seed = GFC_RAND_A * rand_seed % GFC_RAND_M;
+   j = (GFC_INTEGER_4) rand_seed;
+
+  __gthread_mutex_unlock (&rand_seed_lock);
 
-   return (GFC_INTEGER_4) rand_seed;
+   return j;
 }
 iexport(irand);
 
@@ -111,3 +124,11 @@ PREFIX(rand) (GFC_INTEGER_4 *i)
 {
   return normalize_r4_i4 (irand (i) - 1, GFC_RAND_M1 - 1);
 }
+
+#ifndef __GTHREAD_MUTEX_INIT
+static void __attribute__((constructor))
+init (void)
+{
+  __GTHREAD_MUTEX_INIT_FUNCTION (&rand_seed_lock);
+}
+#endif
index 363083e..463b7e0 100644 (file)
@@ -30,6 +30,7 @@ write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
 Boston, MA 02110-1301, USA.  */
 
 #include "libgfortran.h"
+#include "../io/io.h"
 
 extern void random_r4 (GFC_REAL_4 *);
 iexport_proto(random_r4);
@@ -43,6 +44,12 @@ export_proto(arandom_r4);
 extern void arandom_r8 (gfc_array_r8 *);
 export_proto(arandom_r8);
 
+#ifdef __GTHREAD_MUTEX_INIT
+static __gthread_mutex_t random_lock = __GTHREAD_MUTEX_INIT;
+#else
+static __gthread_mutex_t random_lock;
+#endif
+
 #if 0
 
 /*  The Mersenne Twister code is currently commented out due to
@@ -111,12 +118,14 @@ static unsigned int seed[N];
 void
 random_seed (GFC_INTEGER_4 *size, gfc_array_i4 *put, gfc_array_i4 *get)
 {
+  __gthread_mutex_lock (&random_lock);
+
   /* Initialize the seed in system dependent manner.  */
   if (get == NULL && put == NULL && size == NULL)
     {
       int fd;
       fd = open ("/dev/urandom", O_RDONLY);
-      if (fd == 0)
+      if (fd < 0)
        {
          /* We dont have urandom.  */
          GFC_UINTEGER_4 s = (GFC_UINTEGER_4) seed;
@@ -131,15 +140,16 @@ random_seed (GFC_INTEGER_4 *size, gfc_array_i4 *put, gfc_array_i4 *get)
          /* Using urandom, might have a length issue.  */
          read (fd, &seed[0], sizeof (GFC_UINTEGER_4) * N);
          close (fd);
+         i = N;
        }
-      return;
+      goto return_unlock;
     }
 
   /* Return the size of the seed */
   if (size != NULL)
     {
       *size = N;
-      return;
+      goto return_unlock;
     }
 
   /* if we have gotten to this pount we have a get or put
@@ -159,7 +169,7 @@ random_seed (GFC_INTEGER_4 *size, gfc_array_i4 *put, gfc_array_i4 *get)
 
       /* If this is the case the array is a temporary */
       if (put->dim[0].stride == 0)
-       return;
+       goto return_unlock;
 
       /*  This code now should do correct strides. */
       for (i = 0; i < N; i++)
@@ -179,12 +189,15 @@ random_seed (GFC_INTEGER_4 *size, gfc_array_i4 *put, gfc_array_i4 *get)
 
       /* If this is the case the array is a temporary */
       if (get->dim[0].stride == 0)
-       return;
+       goto return_unlock;
 
       /*  This code now should do correct strides. */
       for (i = 0; i < N; i++)
        get->data[i * get->dim[0].stride] = seed[i];
     }
+
+ random_unlock:
+  __gthread_mutex_unlock (&random_lock);
 }
 iexport(random_seed);
 
@@ -220,6 +233,8 @@ random_generate (void)
 void
 random_r4 (GFC_REAL_4 * harv)
 {
+  __gthread_mutex_lock (&random_lock);
+
   /* Regenerate if we need to.  */
   if (i >= N)
     random_generate ();
@@ -227,6 +242,7 @@ random_r4 (GFC_REAL_4 * harv)
   /* Convert uint32 to REAL(KIND=4).  */
   *harv = (GFC_REAL_4) ((GFC_REAL_4) (GFC_UINTEGER_4) seed[i++] /
                        (GFC_REAL_4) (~(GFC_UINTEGER_4) 0));
+  __gthread_mutex_unlock (&random_lock);
 }
 iexport(random_r4);
 
@@ -235,6 +251,8 @@ iexport(random_r4);
 void
 random_r8 (GFC_REAL_8 * harv)
 {
+  __gthread_mutex_lock (&random_lock);
+
   /* Regenerate if we need to, may waste one 32-bit value.  */
   if ((i + 1) >= N)
     random_generate ();
@@ -243,6 +261,7 @@ random_r8 (GFC_REAL_8 * harv)
   *harv = ((GFC_REAL_8) ((((GFC_UINTEGER_8) seed[i+1]) << 32) + seed[i])) /
          (GFC_REAL_8) (~(GFC_UINTEGER_8) 0);
   i += 2;
+  __gthread_mutex_unlock (&random_lock);
 }
 iexport(random_r8);
 
@@ -279,6 +298,8 @@ arandom_r4 (gfc_array_r4 * harv)
 
   stride0 = stride[0];
 
+  __gthread_mutex_lock (&random_lock);
+
   while (dest)
     {
       /* Set the elements.  */
@@ -319,6 +340,8 @@ arandom_r4 (gfc_array_r4 * harv)
            }
        }
     }
+
+  __gthread_mutex_unlock (&random_lock);
 }
 
 /* REAL(KIND=8) array.  */
@@ -352,6 +375,8 @@ arandom_r8 (gfc_array_r8 * harv)
 
   stride0 = stride[0];
 
+  __gthread_mutex_lock (&random_lock);
+
   while (dest)
     {
       /* Set the elements.  */
@@ -393,6 +418,8 @@ arandom_r8 (gfc_array_r8 * harv)
            }
        }
     }
+
+  __gthread_mutex_unlock (&random_lock);
 }
 
 #else
@@ -470,11 +497,13 @@ random_r4 (GFC_REAL_4 *x)
 {
   GFC_UINTEGER_4 kiss;
 
+  __gthread_mutex_lock (&random_lock);
   kiss = kiss_random_kernel ();
   /* Burn a random number, so the REAL*4 and REAL*8 functions
      produce similar sequences of random numbers.  */
   kiss_random_kernel ();
   *x = normalize_r4_i4 (kiss, ~(GFC_UINTEGER_4) 0);
+  __gthread_mutex_unlock (&random_lock);
 }
 iexport(random_r4);
 
@@ -486,9 +515,11 @@ random_r8 (GFC_REAL_8 *x)
 {
   GFC_UINTEGER_8 kiss;
 
+  __gthread_mutex_lock (&random_lock);
   kiss = ((GFC_UINTEGER_8)kiss_random_kernel ()) << 32;
   kiss += kiss_random_kernel ();
   *x = normalize_r8_i8 (kiss, ~(GFC_UINTEGER_8) 0);
+  __gthread_mutex_unlock (&random_lock);
 }
 iexport(random_r8);
 
@@ -504,6 +535,7 @@ arandom_r4 (gfc_array_r4 *x)
   index_type stride0;
   index_type dim;
   GFC_REAL_4 *dest;
+  GFC_UINTEGER_4 kiss;
   int n;
 
   dest = x->data;
@@ -524,9 +556,16 @@ arandom_r4 (gfc_array_r4 *x)
 
   stride0 = stride[0];
 
+  __gthread_mutex_lock (&random_lock);
+
   while (dest)
     {
-      random_r4 (dest);
+      /* random_r4 (dest); */
+      kiss = kiss_random_kernel ();
+      /* Burn a random number, so the REAL*4 and REAL*8 functions
+        produce similar sequences of random numbers.  */
+      kiss_random_kernel ();
+      *dest = normalize_r4_i4 (kiss, ~(GFC_UINTEGER_4) 0);
 
       /* Advance to the next element.  */
       dest += stride0;
@@ -554,6 +593,7 @@ arandom_r4 (gfc_array_r4 *x)
             }
         }
     }
+  __gthread_mutex_unlock (&random_lock);
 }
 
 /*  This function fills a REAL(8) array with values from the uniform
@@ -568,6 +608,7 @@ arandom_r8 (gfc_array_r8 *x)
   index_type stride0;
   index_type dim;
   GFC_REAL_8 *dest;
+  GFC_UINTEGER_8 kiss;
   int n;
 
   dest = x->data;
@@ -588,9 +629,14 @@ arandom_r8 (gfc_array_r8 *x)
 
   stride0 = stride[0];
 
+  __gthread_mutex_lock (&random_lock);
+
   while (dest)
     {
-      random_r8 (dest);
+      /* random_r8 (dest); */
+      kiss = ((GFC_UINTEGER_8)kiss_random_kernel ()) << 32;
+      kiss += kiss_random_kernel ();
+      *dest = normalize_r8_i8 (kiss, ~(GFC_UINTEGER_8) 0);
 
       /* Advance to the next element.  */
       dest += stride0;
@@ -618,6 +664,7 @@ arandom_r8 (gfc_array_r8 *x)
             }
         }
     }
+  __gthread_mutex_unlock (&random_lock);
 }
 
 /* random_seed is used to seed the PRNG with either a default
@@ -629,6 +676,8 @@ random_seed (GFC_INTEGER_4 *size, gfc_array_i4 *put, gfc_array_i4 *get)
 {
   int i;
 
+  __gthread_mutex_lock (&random_lock);
+
   if (size == NULL && put == NULL && get == NULL)
     {
       /* From the standard: "If no argument is present, the processor assigns
@@ -678,7 +727,17 @@ random_seed (GFC_INTEGER_4 *size, gfc_array_i4 *put, gfc_array_i4 *get)
       for (i = 0; i < kiss_size; i++)
         get->data[i * get->dim[0].stride] = (GFC_INTEGER_4) kiss_seed[i];
     }
+
+  __gthread_mutex_unlock (&random_lock);
 }
 iexport(random_seed);
 
 #endif /* mersenne twister */
+
+#ifndef __GTHREAD_MUTEX_INIT
+static void __attribute__((constructor))
+init (void)
+{
+  __GTHREAD_MUTEX_INIT_FUNCTION (&random_lock);
+}
+#endif
index 8a38f78..63c7045 100644 (file)
@@ -44,13 +44,6 @@ Boston, MA 02110-1301, USA.  */
 #endif
 
 
-#if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY)
-static struct timeval tp0 = {-1, 0};
-#elif defined(HAVE_TIME_H)
-static time_t t0 = (time_t) -2;
-#endif
-
-
 extern void system_clock_4 (GFC_INTEGER_4 *, GFC_INTEGER_4 *, GFC_INTEGER_4 *);
 export_proto(system_clock_4);
 
@@ -74,31 +67,18 @@ system_clock_4(GFC_INTEGER_4 *count, GFC_INTEGER_4 *count_rate,
 #if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY)
   struct timeval tp1;
   struct timezone tzp;
-  double t;
+
+  if (sizeof (tp1.tv_sec) < sizeof (GFC_INTEGER_4))
+    internal_error (NULL, "tv_sec too small");
 
   if (gettimeofday(&tp1, &tzp) == 0)
     {
-      if (tp0.tv_sec < 0)
-        {
-          tp0 = tp1;
-          cnt = 0;
-        }
+      GFC_UINTEGER_4 ucnt = (GFC_UINTEGER_4) tp1.tv_sec * TCK;
+      ucnt += (tp1.tv_usec + 500000 / TCK) / (1000000 / TCK);
+      if (ucnt > GFC_INTEGER_4_HUGE)
+       cnt = ucnt - GFC_INTEGER_4_HUGE - 1;
       else
-        {
-         /* TODO: Convert this to integer arithmetic.  */
-          t  = (double) (tp1.tv_sec  - tp0.tv_sec);
-          t += (double) (tp1.tv_usec - tp0.tv_usec) * 1.e-6;
-          t *= TCK;
-
-          if (t > (double) GFC_INTEGER_4_HUGE)
-            {
-              /* Time has wrapped. */
-              while (t > (double) GFC_INTEGER_4_HUGE)
-                t -= (double) GFC_INTEGER_4_HUGE;
-              tp0 = tp1;
-            }
-         cnt = (GFC_INTEGER_4) t;
-        }
+       cnt = ucnt;
       rate = TCK;
       mx = GFC_INTEGER_4_HUGE;
     }
@@ -113,24 +93,17 @@ system_clock_4(GFC_INTEGER_4 *count, GFC_INTEGER_4 *count_rate,
       return;
     }
 #elif defined(HAVE_TIME_H)
-  time_t t, t1;
+  GFC_UINTEGER_4 ucnt;
 
-  t1 = time(NULL);
+  if (sizeof (time_t) < sizeof (GFC_INTEGER_4))
+    internal_error (NULL, "time_t too small");
 
-  if (t1 == (time_t) -1)
-    {
-      cnt = - GFC_INTEGER_4_HUGE;
-      mx = 0;
-    }
-  else if (t0 == (time_t) -2)
-    t0 = t1;
+  ucnt = time (NULL);
+  if (ucnt > GFC_INTEGER_4_HUGE)
+    cnt = ucnt - GFC_INTEGER_4_HUGE - 1;
   else
-    {
-      /* The timer counts in seconts, so for simplicity assume it never wraps.
-        Even with 32-bit counters this only happens once every 68 years.  */
-      cnt = t1 - t0;
-      mx = GFC_INTEGER_4_HUGE;
-    }
+    cnt = ucnt;
+  mx = GFC_INTEGER_4_HUGE;
 #else
   cnt = - GFC_INTEGER_4_HUGE;
   mx = 0;
@@ -148,7 +121,7 @@ system_clock_4(GFC_INTEGER_4 *count, GFC_INTEGER_4 *count_rate,
 
 void
 system_clock_8 (GFC_INTEGER_8 *count, GFC_INTEGER_8 *count_rate,
-               GFC_INTEGER_8 *count_max)
+               GFC_INTEGER_8 *count_max)
 {
   GFC_INTEGER_8 cnt;
   GFC_INTEGER_8 rate;
@@ -157,33 +130,33 @@ system_clock_8 (GFC_INTEGER_8 *count, GFC_INTEGER_8 *count_rate,
 #if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY)
   struct timeval tp1;
   struct timezone tzp;
-  double t;
+
+  if (sizeof (tp1.tv_sec) < sizeof (GFC_INTEGER_4))
+    internal_error (NULL, "tv_sec too small");
 
   if (gettimeofday(&tp1, &tzp) == 0)
     {
-      if (tp0.tv_sec < 0)
-        {
-          tp0 = tp1;
-          cnt = 0;
-        }
+      if (sizeof (tp1.tv_sec) < sizeof (GFC_INTEGER_8))
+       {
+         GFC_UINTEGER_4 ucnt = (GFC_UINTEGER_4) tp1.tv_sec * TCK;
+         ucnt += (tp1.tv_usec + 500000 / TCK) / (1000000 / TCK);
+         if (ucnt > GFC_INTEGER_4_HUGE)
+           cnt = ucnt - GFC_INTEGER_4_HUGE - 1;
+         else
+           cnt = ucnt;
+         mx = GFC_INTEGER_4_HUGE;
+       }
       else
-        {
-         /* TODO: Convert this to integer arithmetic.  */
-          t  = (double) (tp1.tv_sec  - tp0.tv_sec);
-          t += (double) (tp1.tv_usec - tp0.tv_usec) * 1.e-6;
-          t *= TCK;
-
-          if (t > (double) GFC_INTEGER_8_HUGE)
-            {
-              /* Time has wrapped. */
-              while (t > (double) GFC_INTEGER_8_HUGE)
-                t -= (double) GFC_INTEGER_8_HUGE;
-              tp0 = tp1;
-            }
-         cnt = (GFC_INTEGER_8) t;
-        }
+       {
+         GFC_UINTEGER_8 ucnt = (GFC_UINTEGER_8) tp1.tv_sec * TCK;
+         ucnt += (tp1.tv_usec + 500000 / TCK) / (1000000 / TCK);
+         if (ucnt > GFC_INTEGER_8_HUGE)
+           cnt = ucnt - GFC_INTEGER_8_HUGE - 1;
+         else
+           cnt = ucnt;
+         mx = GFC_INTEGER_8_HUGE;
+       }
       rate = TCK;
-      mx = GFC_INTEGER_8_HUGE;
     }
   else
     {
@@ -197,22 +170,24 @@ system_clock_8 (GFC_INTEGER_8 *count, GFC_INTEGER_8 *count_rate,
       return;
     }
 #elif defined(HAVE_TIME_H)
-  time_t t, t1;
-
-  t1 = time(NULL);
-
-  if (t1 == (time_t) -1)
+  if (sizeof (time_t) < sizeof (GFC_INTEGER_4))
+    internal_error (NULL, "time_t too small");
+  else if (sizeof (time_t) == sizeof (GFC_INTEGER_4))
     {
-      cnt = - GFC_INTEGER_8_HUGE;
-      mx = 0;
+      GFC_UINTEGER_4 ucnt = time (NULL);
+      if (ucnt > GFC_INTEGER_4_HUGE)
+       cnt = ucnt - GFC_INTEGER_4_HUGE - 1;
+      else
+       cnt = ucnt;
+      mx = GFC_INTEGER_4_HUGE;
     }
-  else if (t0 == (time_t) -2)
-    t0 = t1;
   else
     {
-      /* The timer counts in seconts, so for simplicity assume it never wraps.
-        Even with 32-bit counters this only happens once every 68 years.  */
-      cnt = t1 - t0;
+      GFC_UINTEGER_8 ucnt = time (NULL);
+      if (ucnt > GFC_INTEGER_8_HUGE)
+       cnt = ucnt - GFC_INTEGER_8_HUGE - 1;
+      else
+       cnt = ucnt;
       mx = GFC_INTEGER_8_HUGE;
     }
 #else
index f4bfecd..63c2a5e 100644 (file)
@@ -44,12 +44,15 @@ GFC_LOGICAL_4
 isatty_l4 (int *unit)
 {
   gfc_unit *u;
+  GFC_LOGICAL_4 ret = 0;
 
   u = find_unit (*unit);
   if (u != NULL)
-    return (GFC_LOGICAL_4) stream_isatty (u->s);
-  else
-    return 0;
+    {
+      ret = (GFC_LOGICAL_4) stream_isatty (u->s);
+      unlock_unit (u);
+    }
+  return ret;
 }
 
 
@@ -60,12 +63,15 @@ GFC_LOGICAL_8
 isatty_l8 (int *unit)
 {
   gfc_unit *u;
+  GFC_LOGICAL_8 ret = 0;
 
   u = find_unit (*unit);
   if (u != NULL)
-    return (GFC_LOGICAL_8) stream_isatty (u->s);
-  else
-    return 0;
+    {
+      ret = (GFC_LOGICAL_8) stream_isatty (u->s);
+      unlock_unit (u);
+    }
+  return ret;
 }
 
 
@@ -94,6 +100,7 @@ ttynam_sub (int *unit, char * name, gfc_charlen_type name_len)
          while (*n && i < name_len)
            name[i++] = *(n++);
        }
+      unlock_unit (u);
     }
 }
 
index dcb1809..9dcc1a3 100644 (file)
@@ -43,11 +43,11 @@ static const st_option status_opt[] = {
 };
 
 
-extern void st_close (void);
+extern void st_close (st_parameter_close *);
 export_proto(st_close);
 
 void
-st_close (void)
+st_close (st_parameter_close *clp)
 {
   close_status status;
   gfc_unit *u;
@@ -57,25 +57,25 @@ st_close (void)
   path = NULL;
 #endif
 
-  library_start ();
+  library_start (&clp->common);
 
-  status = (ioparm.status == NULL) ? CLOSE_UNSPECIFIED :
-    find_option (ioparm.status, ioparm.status_len, status_opt,
-                "Bad STATUS parameter in CLOSE statement");
+  status = !(clp->common.flags & IOPARM_CLOSE_HAS_STATUS) ? CLOSE_UNSPECIFIED :
+    find_option (&clp->common, clp->status, clp->status_len,
+                status_opt, "Bad STATUS parameter in CLOSE statement");
 
-  if (ioparm.library_return != LIBRARY_OK)
+  if ((clp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
   {
     library_end ();
     return;
   }
 
-  u = find_unit (ioparm.unit);
+  u = find_unit (clp->common.unit);
   if (u != NULL)
     {
       if (u->flags.status == STATUS_SCRATCH)
        {
          if (status == CLOSE_KEEP)
-           generate_error (ERROR_BAD_OPTION,
+           generate_error (&clp->common, ERROR_BAD_OPTION,
                            "Can't KEEP a scratch file on CLOSE");
 #if !HAVE_UNLINK_OPEN_FILE
          path = (char *) gfc_alloca (u->file_len + 1);
index d175471..0049718 100644 (file)
@@ -36,7 +36,7 @@ Boston, MA 02110-1301, USA.  */
    ENDFILE, and REWIND as well as the FLUSH statement.  */
 
 
-/* formatted_backspace(void)-- Move the file back one line.  The
+/* formatted_backspace(fpp, u)-- Move the file back one line.  The
    current position is after the newline that terminates the previous
    record, and we have to sift backwards to find the newline before
    that or the start of the file, whichever comes first.  */
@@ -44,20 +44,20 @@ Boston, MA 02110-1301, USA.  */
 #define READ_CHUNK 4096
 
 static void
-formatted_backspace (void)
+formatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
 {
   gfc_offset base;
   char *p;
   int n;
 
-  base = file_position (current_unit->s) - 1;
+  base = file_position (u->s) - 1;
 
   do
     {
       n = (base < READ_CHUNK) ? base : READ_CHUNK;
       base -= n;
 
-      p = salloc_r_at (current_unit->s, &n, base);
+      p = salloc_r_at (u->s, &n, base);
       if (p == NULL)
        goto io_error;
 
@@ -84,24 +84,24 @@ formatted_backspace (void)
 
   /* base is the new pointer.  Seek to it exactly.  */
  done:
-  if (sseek (current_unit->s, base) == FAILURE)
+  if (sseek (u->s, base) == FAILURE)
     goto io_error;
-  current_unit->last_record--;
-  current_unit->endfile = NO_ENDFILE;
+  u->last_record--;
+  u->endfile = NO_ENDFILE;
 
   return;
 
  io_error:
-  generate_error (ERROR_OS, NULL);
+  generate_error (&fpp->common, ERROR_OS, NULL);
 }
 
 
-/* unformatted_backspace() -- Move the file backwards for an unformatted
+/* unformatted_backspace(fpp) -- Move the file backwards for an unformatted
    sequential file.  We are guaranteed to be between records on entry and 
    we have to shift to the previous record.  */
 
 static void
-unformatted_backspace (void)
+unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
 {
   gfc_offset m, new;
   int length;
@@ -109,43 +109,41 @@ unformatted_backspace (void)
 
   length = sizeof (gfc_offset);
 
-  p = salloc_r_at (current_unit->s, &length,
-                  file_position (current_unit->s) - length);
+  p = salloc_r_at (u->s, &length,
+                  file_position (u->s) - length);
   if (p == NULL)
     goto io_error;
 
   memcpy (&m, p, sizeof (gfc_offset));
-  new = file_position (current_unit->s) - m - 2*length;
-  if (sseek (current_unit->s, new) == FAILURE)
+  new = file_position (u->s) - m - 2*length;
+  if (sseek (u->s, new) == FAILURE)
     goto io_error;
 
-  current_unit->last_record--;
+  u->last_record--;
   return;
 
  io_error:
-  generate_error (ERROR_OS, NULL);
+  generate_error (&fpp->common, ERROR_OS, NULL);
 }
 
 
-extern void st_backspace (void);
+extern void st_backspace (st_parameter_filepos *);
 export_proto(st_backspace);
 
 void
-st_backspace (void)
+st_backspace (st_parameter_filepos *fpp)
 {
   gfc_unit *u;
 
-  library_start ();
+  library_start (&fpp->common);
 
-  u = find_unit (ioparm.unit);
+  u = find_unit (fpp->common.unit);
   if (u == NULL)
     {
-      generate_error (ERROR_BAD_UNIT, NULL);
+      generate_error (&fpp->common, ERROR_BAD_UNIT, NULL);
       goto done;
     }
 
-  current_unit = u;
-
   /* Ignore direct access.  Non-advancing I/O is only allowed for formatted
      sequential I/O and the next direct access transfer repositions the file 
      anyway.  */
@@ -170,60 +168,69 @@ st_backspace (void)
         }
 
       if (u->flags.form == FORM_FORMATTED)
-       formatted_backspace ();
+       formatted_backspace (fpp, u);
       else
-       unformatted_backspace ();
+       unformatted_backspace (fpp, u);
 
       u->endfile = NO_ENDFILE;
       u->current_record = 0;
     }
 
  done:
+  if (u != NULL)
+    unlock_unit (u);
+
   library_end ();
 }
 
 
-extern void st_endfile (void);
+extern void st_endfile (st_parameter_filepos *);
 export_proto(st_endfile);
 
 void
-st_endfile (void)
+st_endfile (st_parameter_filepos *fpp)
 {
   gfc_unit *u;
 
-  library_start ();
+  library_start (&fpp->common);
 
-  u = get_unit (0);
+  u = find_unit (fpp->common.unit);
   if (u != NULL)
     {
-      current_unit = u;                /* next_record() needs this set.  */
       if (u->current_record)
-       next_record (1);
+       {
+         st_parameter_dt dtp;
+         dtp.common = fpp->common;
+         memset (&dtp.u.p, 0, sizeof (dtp.u.p));
+         dtp.u.p.current_unit = u;
+         next_record (&dtp, 1);
+       }
 
-      flush(u->s);
+      flush (u->s);
       struncate (u->s);
       u->endfile = AFTER_ENDFILE;
+      unlock_unit (u);
     }
 
   library_end ();
 }
 
 
-extern void st_rewind (void);
+extern void st_rewind (st_parameter_filepos *);
 export_proto(st_rewind);
 
 void
-st_rewind (void)
+st_rewind (st_parameter_filepos *fpp)
 {
   gfc_unit *u;
 
-  library_start ();
+  library_start (&fpp->common);
 
-  u = find_unit (ioparm.unit);
+  u = find_unit (fpp->common.unit);
   if (u != NULL)
     {
       if (u->flags.access != ACCESS_SEQUENTIAL)
-       generate_error (ERROR_BAD_OPTION,
+       generate_error (&fpp->common, ERROR_BAD_OPTION,
                        "Cannot REWIND a file opened for DIRECT access");
       else
        {
@@ -239,7 +246,7 @@ st_rewind (void)
          u->mode = READING;
          u->last_record = 0;
          if (sseek (u->s, 0) == FAILURE)
-           generate_error (ERROR_OS, NULL);
+           generate_error (&fpp->common, ERROR_OS, NULL);
 
          u->endfile = NO_ENDFILE;
          u->current_record = 0;
@@ -247,27 +254,28 @@ st_rewind (void)
        }
       /* Update position for INQUIRE.  */
       u->flags.position = POSITION_REWIND;
+      unlock_unit (u);
     }
 
   library_end ();
 }
 
 
-extern void st_flush (void);
+extern void st_flush (st_parameter_filepos *);
 export_proto(st_flush);
 
 void
-st_flush (void)
+st_flush (st_parameter_filepos *fpp)
 {
   gfc_unit *u;
 
-  library_start ();
+  library_start (&fpp->common);
 
-  u = get_unit (0);
+  u = find_unit (fpp->common.unit);
   if (u != NULL)
     {
-      current_unit = u;  /* Just to be sure.  */
-      flush(u->s);
+      flush (u->s);
+      unlock_unit (u);
     }
 
   library_end ();
index e714e3b..1d7e15b 100644 (file)
@@ -38,26 +38,30 @@ Boston, MA 02110-1301, USA.  */
 #include "libgfortran.h"
 #include "io.h"
 
+#define FARRAY_SIZE 64
 
+typedef struct fnode_array
+{
+  struct fnode_array *next;
+  fnode array[FARRAY_SIZE];
+}
+fnode_array;
 
-/* Number of format nodes that we can store statically before we have
- * to resort to dynamic allocation.  The root node is array[0]. */
-
-#define FARRAY_SIZE 200
-
-static fnode *avail, array[FARRAY_SIZE];
-
-/* Local variables for checking format strings.  The saved_token is
- * used to back up by a single format token during the parsing process. */
-
-static char *format_string, *string;
-static const char *error;
-static format_token saved_token;
-static int value, format_string_len, reversion_ok;
+typedef struct format_data
+{
+  char *format_string, *string;
+  const char *error;
+  format_token saved_token;
+  int value, format_string_len, reversion_ok;
+  fnode *avail;
+  const fnode *saved_format;
+  fnode_array *last;
+  fnode_array array;
+}
+format_data;
 
-static fnode *saved_format;
-static fnode colon_node = { FMT_COLON, 0, NULL, NULL, {{ 0, 0, 0 }}, 0,
-                           NULL };
+static const fnode colon_node = { FMT_COLON, 0, NULL, NULL, {{ 0, 0, 0 }}, 0,
+                                 NULL };
 
 /* Error messages */
 
@@ -76,17 +80,17 @@ static const char posint_required[] = "Positive width required in format",
  * spaces are significant, otherwise they are not. */
 
 static int
-next_char (int literal)
+next_char (format_data *fmt, int literal)
 {
   int c;
 
   do
     {
-      if (format_string_len == 0)
+      if (fmt->format_string_len == 0)
        return -1;
 
-      format_string_len--;
-      c = toupper (*format_string++);
+      fmt->format_string_len--;
+      c = toupper (*fmt->format_string++);
     }
   while (c == ' ' && !literal);
 
@@ -96,7 +100,8 @@ next_char (int literal)
 
 /* unget_char()-- Back up one character position. */
 
-#define unget_char() { format_string--;  format_string_len++; }
+#define unget_char(fmt) \
+  { fmt->format_string--; fmt->format_string_len++; }
 
 
 /* get_fnode()-- Allocate a new format node, inserting it into the
@@ -104,17 +109,19 @@ next_char (int literal)
  * static buffer. */
 
 static fnode *
-get_fnode (fnode ** head, fnode ** tail, format_token t)
+get_fnode (format_data *fmt, fnode **head, fnode **tail, format_token t)
 {
   fnode *f;
 
-  if (avail - array >= FARRAY_SIZE)
-    f = get_mem (sizeof (fnode));
-  else
+  if (fmt->avail == &fmt->last->array[FARRAY_SIZE])
     {
-      f = avail++;
-      memset (f, '\0', sizeof (fnode));
+      fmt->last->next = get_mem (sizeof (fnode_array));
+      fmt->last = fmt->last->next;
+      fmt->last->next = NULL;
+      fmt->avail = &fmt->last->array[0];
     }
+  f = fmt->avail++;
+  memset (f, '\0', sizeof (fnode));
 
   if (*head == NULL)
     *head = *tail = f;
@@ -126,67 +133,54 @@ get_fnode (fnode ** head, fnode ** tail, format_token t)
 
   f->format = t;
   f->repeat = -1;
-  f->source = format_string;
+  f->source = fmt->format_string;
   return f;
 }
 
 
-/* free_fnode()-- Recursive function to free the given fnode and
- * everything it points to.  We only have to actually free something
- * if it is outside of the static array. */
+/* free_format_data()-- Free all allocated format data.  */
 
-static void
-free_fnode (fnode * f)
+void
+free_format_data (st_parameter_dt *dtp)
 {
-  fnode *next;
+  fnode_array *fa, *fa_next;
+  format_data *fmt = dtp->u.p.fmt;
 
-  for (; f; f = next)
-    {
-      next = f->next;
+  if (fmt == NULL)
+    return;
 
-      if (f->format == FMT_LPAREN)
-       free_fnode (f->u.child);
-      if (f < array || f >= array + FARRAY_SIZE)
-       free_mem (f);
+  for (fa = fmt->array.next; fa; fa = fa_next)
+    {
+      fa_next = fa->next;
+      free_mem (fa);
     }
-}
-
 
-/* free_fnodes()-- Free the current tree of fnodes.  We only have to
- * traverse the tree if some nodes were allocated dynamically. */
-
-void
-free_fnodes (void)
-{
-  if (avail - array >= FARRAY_SIZE)
-    free_fnode (&array[0]);
-
-  avail = array;
-  memset(array, 0, sizeof(avail[0]) * FARRAY_SIZE);
+  free_mem (fmt);
+  dtp->u.p.fmt = NULL;
 }
 
 
 /* format_lex()-- Simple lexical analyzer for getting the next token
  * in a FORMAT string.  We support a one-level token pushback in the
- * saved_token variable. */
+ * fmt->saved_token variable. */
 
 static format_token
-format_lex (void)
+format_lex (format_data *fmt)
 {
   format_token token;
   int negative_flag;
   int c;
   char delim;
 
-  if (saved_token != FMT_NONE)
+  if (fmt->saved_token != FMT_NONE)
     {
-      token = saved_token;
-      saved_token = FMT_NONE;
+      token = fmt->saved_token;
+      fmt->saved_token = FMT_NONE;
       return token;
     }
 
   negative_flag = 0;
-  c = next_char (0);
+  c = next_char (fmt, 0);
 
   switch (c)
     {
@@ -195,28 +189,28 @@ format_lex (void)
       /* Fall Through */
 
     case '+':
-      c = next_char (0);
+      c = next_char (fmt, 0);
       if (!isdigit (c))
        {
          token = FMT_UNKNOWN;
          break;
        }
 
-      value = c - '0';
+      fmt->value = c - '0';
 
       for (;;)
        {
-         c = next_char (0);
+         c = next_char (fmt, 0);
          if (!isdigit (c))
            break;
 
-         value = 10 * value + c - '0';
+         fmt->value = 10 * fmt->value + c - '0';
        }
 
-      unget_char ();
+      unget_char (fmt);
 
       if (negative_flag)
-       value = -value;
+       fmt->value = -fmt->value;
       token = FMT_SIGNED_INT;
       break;
 
@@ -230,19 +224,19 @@ format_lex (void)
     case '7':
     case '8':
     case '9':
-      value = c - '0';
+      fmt->value = c - '0';
 
       for (;;)
        {
-         c = next_char (0);
+         c = next_char (fmt, 0);
          if (!isdigit (c))
            break;
 
-         value = 10 * value + c - '0';
+         fmt->value = 10 * fmt->value + c - '0';
        }
 
-      unget_char ();
-      token = (value == 0) ? FMT_ZERO : FMT_POSINT;
+      unget_char (fmt);
+      token = (fmt->value == 0) ? FMT_ZERO : FMT_POSINT;
       break;
 
     case '.':
@@ -266,7 +260,7 @@ format_lex (void)
       break;
 
     case 'T':
-      switch (next_char (0))
+      switch (next_char (fmt, 0))
        {
        case 'L':
          token = FMT_TL;
@@ -276,7 +270,7 @@ format_lex (void)
          break;
        default:
          token = FMT_T;
-         unget_char ();
+         unget_char (fmt);
          break;
        }
 
@@ -295,7 +289,7 @@ format_lex (void)
       break;
 
     case 'S':
-      switch (next_char (0))
+      switch (next_char (fmt, 0))
        {
        case 'S':
          token = FMT_SS;
@@ -305,14 +299,14 @@ format_lex (void)
          break;
        default:
          token = FMT_S;
-         unget_char ();
+         unget_char (fmt);
          break;
        }
 
       break;
 
     case 'B':
-      switch (next_char (0))
+      switch (next_char (fmt, 0))
        {
        case 'N':
          token = FMT_BN;
@@ -322,7 +316,7 @@ format_lex (void)
          break;
        default:
          token = FMT_B;
-         unget_char ();
+         unget_char (fmt);
          break;
        }
 
@@ -332,39 +326,39 @@ format_lex (void)
     case '"':
       delim = c;
 
-      string = format_string;
-      value = 0;               /* This is the length of the string */
+      fmt->string = fmt->format_string;
+      fmt->value = 0;          /* This is the length of the string */
 
       for (;;)
        {
-         c = next_char (1);
+         c = next_char (fmt, 1);
          if (c == -1)
            {
              token = FMT_BADSTRING;
-             error = bad_string;
+             fmt->error = bad_string;
              break;
            }
 
          if (c == delim)
            {
-             c = next_char (1);
+             c = next_char (fmt, 1);
 
              if (c == -1)
                {
                  token = FMT_BADSTRING;
-                 error = bad_string;
+                 fmt->error = bad_string;
                  break;
                }
 
              if (c != delim)
                {
-                 unget_char ();
+                 unget_char (fmt);
                  token = FMT_STRING;
                  break;
                }
            }
 
-         value++;
+         fmt->value++;
        }
 
       break;
@@ -390,7 +384,7 @@ format_lex (void)
       break;
 
     case 'E':
-      switch (next_char (0))
+      switch (next_char (fmt, 0))
        {
        case 'N':
          token = FMT_EN;
@@ -400,7 +394,7 @@ format_lex (void)
          break;
        default:
          token = FMT_E;
-         unget_char ();
+         unget_char (fmt);
          break;
        }
 
@@ -444,44 +438,45 @@ format_lex (void)
  * parenthesis node which contains the rest of the list. */
 
 static fnode *
-parse_format_list (void)
+parse_format_list (st_parameter_dt *dtp)
 {
   fnode *head, *tail;
   format_token t, u, t2;
   int repeat;
+  format_data *fmt = dtp->u.p.fmt;
 
   head = tail = NULL;
 
   /* Get the next format item */
  format_item:
-  t = format_lex ();
+  t = format_lex (fmt);
  format_item_1:
   switch (t)
     {
     case FMT_POSINT:
-      repeat = value;
+      repeat = fmt->value;
 
-      t = format_lex ();
+      t = format_lex (fmt);
       switch (t)
        {
        case FMT_LPAREN:
-         get_fnode (&head, &tail, FMT_LPAREN);
+         get_fnode (fmt, &head, &tail, FMT_LPAREN);
          tail->repeat = repeat;
-         tail->u.child = parse_format_list ();
-         if (error != NULL)
+         tail->u.child = parse_format_list (dtp);
+         if (fmt->error != NULL)
            goto finished;
 
          goto between_desc;
 
        case FMT_SLASH:
-         get_fnode (&head, &tail, FMT_SLASH);
+         get_fnode (fmt, &head, &tail, FMT_SLASH);
          tail->repeat = repeat;
          goto optional_comma;
 
        case FMT_X:
-         get_fnode (&head, &tail, FMT_X);
+         get_fnode (fmt, &head, &tail, FMT_X);
          tail->repeat = 1;
-         tail->u.k = value;
+         tail->u.k = fmt->value;
          goto between_desc;
 
        case FMT_P:
@@ -492,29 +487,29 @@ parse_format_list (void)
        }
 
     case FMT_LPAREN:
-      get_fnode (&head, &tail, FMT_LPAREN);
+      get_fnode (fmt, &head, &tail, FMT_LPAREN);
       tail->repeat = 1;
-      tail->u.child = parse_format_list ();
-      if (error != NULL)
+      tail->u.child = parse_format_list (dtp);
+      if (fmt->error != NULL)
        goto finished;
 
       goto between_desc;
 
     case FMT_SIGNED_INT:       /* Signed integer can only precede a P format.  */
     case FMT_ZERO:             /* Same for zero.  */
-      t = format_lex ();
+      t = format_lex (fmt);
       if (t != FMT_P)
        {
-         error = "Expected P edit descriptor in format";
+         fmt->error = "Expected P edit descriptor in format";
          goto finished;
        }
 
     p_descriptor:
-      get_fnode (&head, &tail, FMT_P);
-      tail->u.k = value;
+      get_fnode (fmt, &head, &tail, FMT_P);
+      tail->u.k = fmt->value;
       tail->repeat = 1;
 
-      t = format_lex ();
+      t = format_lex (fmt);
       if (t == FMT_F || t == FMT_EN || t == FMT_ES || t == FMT_D
          || t == FMT_G || t == FMT_E)
        {
@@ -522,11 +517,11 @@ parse_format_list (void)
          goto data_desc;
        }
 
-      saved_token = t;
+      fmt->saved_token = t;
       goto optional_comma;
 
     case FMT_P:                /* P and X require a prior number */
-      error = "P descriptor requires leading scale factor";
+      fmt->error = "P descriptor requires leading scale factor";
       goto finished;
 
     case FMT_X:
@@ -536,7 +531,7 @@ parse_format_list (void)
    If we would be pedantic in the library, we would have to reject
    an X descriptor without an integer prefix:
 
-      error = "X descriptor requires leading space count";
+      fmt->error = "X descriptor requires leading space count";
       goto finished;
 
    However, this is an extension supported by many Fortran compilers,
@@ -544,16 +539,16 @@ parse_format_list (void)
    runtime library, and make the front end reject it if the compiler
    is in pedantic mode.  The interpretation of 'X' is '1X'.
 */
-      get_fnode (&head, &tail, FMT_X);
+      get_fnode (fmt, &head, &tail, FMT_X);
       tail->repeat = 1;
       tail->u.k = 1;
       goto between_desc;
 
     case FMT_STRING:
-      get_fnode (&head, &tail, FMT_STRING);
+      get_fnode (fmt, &head, &tail, FMT_STRING);
 
-      tail->u.string.p = string;
-      tail->u.string.length = value;
+      tail->u.string.p = fmt->string;
+      tail->u.string.length = fmt->value;
       tail->repeat = 1;
       goto optional_comma;
 
@@ -562,23 +557,23 @@ parse_format_list (void)
     case FMT_SP:
     case FMT_BN:
     case FMT_BZ:
-      get_fnode (&head, &tail, t);
+      get_fnode (fmt, &head, &tail, t);
       tail->repeat = 1;
       goto between_desc;
 
     case FMT_COLON:
-      get_fnode (&head, &tail, FMT_COLON);
+      get_fnode (fmt, &head, &tail, FMT_COLON);
       tail->repeat = 1;
       goto optional_comma;
 
     case FMT_SLASH:
-      get_fnode (&head, &tail, FMT_SLASH);
+      get_fnode (fmt, &head, &tail, FMT_SLASH);
       tail->repeat = 1;
       tail->u.r = 1;
       goto optional_comma;
 
     case FMT_DOLLAR:
-      get_fnode (&head, &tail, FMT_DOLLAR);
+      get_fnode (fmt, &head, &tail, FMT_DOLLAR);
       tail->repeat = 1;
       notify_std (GFC_STD_GNU, "Extension: $ descriptor");
       goto between_desc;
@@ -586,14 +581,14 @@ parse_format_list (void)
     case FMT_T:
     case FMT_TL:
     case FMT_TR:
-      t2 = format_lex ();
+      t2 = format_lex (fmt);
       if (t2 != FMT_POSINT)
        {
-         error = posint_required;
+         fmt->error = posint_required;
          goto finished;
        }
-      get_fnode (&head, &tail, t);
-      tail->u.n = value;
+      get_fnode (fmt, &head, &tail, t);
+      tail->u.n = fmt->value;
       tail->repeat = 1;
       goto between_desc;
 
@@ -613,25 +608,25 @@ parse_format_list (void)
       goto data_desc;
 
     case FMT_H:
-      get_fnode (&head, &tail, FMT_STRING);
+      get_fnode (fmt, &head, &tail, FMT_STRING);
 
-      if (format_string_len < 1)
+      if (fmt->format_string_len < 1)
        {
-         error = bad_hollerith;
+         fmt->error = bad_hollerith;
          goto finished;
        }
 
-      tail->u.string.p = format_string;
+      tail->u.string.p = fmt->format_string;
       tail->u.string.length = 1;
       tail->repeat = 1;
 
-      format_string++;
-      format_string_len--;
+      fmt->format_string++;
+      fmt->format_string_len--;
 
       goto between_desc;
 
     case FMT_END:
-      error = unexpected_end;
+      fmt->error = unexpected_end;
       goto finished;
 
     case FMT_BADSTRING:
@@ -641,7 +636,7 @@ parse_format_list (void)
       goto finished;
 
     default:
-      error = unexpected_element;
+      fmt->error = unexpected_element;
       goto finished;
     }
 
@@ -651,42 +646,42 @@ parse_format_list (void)
   switch (t)
     {
     case FMT_P:
-      t = format_lex ();
+      t = format_lex (fmt);
       if (t == FMT_POSINT)
        {
-         error = "Repeat count cannot follow P descriptor";
+         fmt->error = "Repeat count cannot follow P descriptor";
          goto finished;
        }
 
-      saved_token = t;
-      get_fnode (&head, &tail, FMT_P);
+      fmt->saved_token = t;
+      get_fnode (fmt, &head, &tail, FMT_P);
 
       goto optional_comma;
 
     case FMT_L:
-      t = format_lex ();
+      t = format_lex (fmt);
       if (t != FMT_POSINT)
        {
-         error = posint_required;
+         fmt->error = posint_required;
          goto finished;
        }
 
-      get_fnode (&head, &tail, FMT_L);
-      tail->u.n = value;
+      get_fnode (fmt, &head, &tail, FMT_L);
+      tail->u.n = fmt->value;
       tail->repeat = repeat;
       break;
 
     case FMT_A:
-      t = format_lex ();
+      t = format_lex (fmt);
       if (t != FMT_POSINT)
        {
-         saved_token = t;
-         value = -1;           /* Width not present */
+         fmt->saved_token = t;
+         fmt->value = -1;              /* Width not present */
        }
 
-      get_fnode (&head, &tail, FMT_A);
+      get_fnode (fmt, &head, &tail, FMT_A);
       tail->repeat = repeat;
-      tail->u.n = value;
+      tail->u.n = fmt->value;
       break;
 
     case FMT_D:
@@ -695,15 +690,15 @@ parse_format_list (void)
     case FMT_G:
     case FMT_EN:
     case FMT_ES:
-      get_fnode (&head, &tail, t);
+      get_fnode (fmt, &head, &tail, t);
       tail->repeat = repeat;
 
-      u = format_lex ();
-      if (t == FMT_F || g.mode == WRITING)
+      u = format_lex (fmt);
+      if (t == FMT_F || dtp->u.p.mode == WRITING)
        {
          if (u != FMT_POSINT && u != FMT_ZERO)
            {
-             error = nonneg_required;
+             fmt->error = nonneg_required;
              goto finished;
            }
        }
@@ -711,28 +706,28 @@ parse_format_list (void)
        {
          if (u != FMT_POSINT)
            {
-             error = posint_required;
+             fmt->error = posint_required;
              goto finished;
            }
        }
 
-      tail->u.real.w = value;
+      tail->u.real.w = fmt->value;
       t2 = t;
-      t = format_lex ();
+      t = format_lex (fmt);
       if (t != FMT_PERIOD)
        {
-         error = period_required;
+         fmt->error = period_required;
          goto finished;
        }
 
-      t = format_lex ();
+      t = format_lex (fmt);
       if (t != FMT_ZERO && t != FMT_POSINT)
        {
-         error = nonneg_required;
+         fmt->error = nonneg_required;
          goto finished;
        }
 
-      tail->u.real.d = value;
+      tail->u.real.d = fmt->value;
 
       if (t == FMT_D || t == FMT_F)
        break;
@@ -740,38 +735,38 @@ parse_format_list (void)
       tail->u.real.e = -1;
 
       /* Look for optional exponent */
-      t = format_lex ();
+      t = format_lex (fmt);
       if (t != FMT_E)
-       saved_token = t;
+       fmt->saved_token = t;
       else
        {
-         t = format_lex ();
+         t = format_lex (fmt);
          if (t != FMT_POSINT)
            {
-             error = "Positive exponent width required in format";
+             fmt->error = "Positive exponent width required in format";
              goto finished;
            }
 
-         tail->u.real.e = value;
+         tail->u.real.e = fmt->value;
        }
 
       break;
 
     case FMT_H:
-      if (repeat > format_string_len)
+      if (repeat > fmt->format_string_len)
        {
-         error = bad_hollerith;
+         fmt->error = bad_hollerith;
          goto finished;
        }
 
-      get_fnode (&head, &tail, FMT_STRING);
+      get_fnode (fmt, &head, &tail, FMT_STRING);
 
-      tail->u.string.p = format_string;
+      tail->u.string.p = fmt->format_string;
       tail->u.string.length = repeat;
       tail->repeat = 1;
 
-      format_string += value;
-      format_string_len -= repeat;
+      fmt->format_string += fmt->value;
+      fmt->format_string_len -= repeat;
 
       break;
 
@@ -779,16 +774,16 @@ parse_format_list (void)
     case FMT_B:
     case FMT_O:
     case FMT_Z:
-      get_fnode (&head, &tail, t);
+      get_fnode (fmt, &head, &tail, t);
       tail->repeat = repeat;
 
-      t = format_lex ();
+      t = format_lex (fmt);
 
-      if (g.mode == READING)
+      if (dtp->u.p.mode == READING)
        {
          if (t != FMT_POSINT)
            {
-             error = posint_required;
+             fmt->error = posint_required;
              goto finished;
            }
        }
@@ -796,47 +791,47 @@ parse_format_list (void)
        {
          if (t != FMT_ZERO && t != FMT_POSINT)
            {
-             error = nonneg_required;
+             fmt->error = nonneg_required;
              goto finished;
            }
        }
 
-      tail->u.integer.w = value;
+      tail->u.integer.w = fmt->value;
       tail->u.integer.m = -1;
 
-      t = format_lex ();
+      t = format_lex (fmt);
       if (t != FMT_PERIOD)
        {
-         saved_token = t;
+         fmt->saved_token = t;
        }
       else
        {
-         t = format_lex ();
+         t = format_lex (fmt);
          if (t != FMT_ZERO && t != FMT_POSINT)
            {
-             error = nonneg_required;
+             fmt->error = nonneg_required;
              goto finished;
            }
 
-         tail->u.integer.m = value;
+         tail->u.integer.m = fmt->value;
        }
 
       if (tail->u.integer.w != 0 && tail->u.integer.m > tail->u.integer.w)
        {
-         error = "Minimum digits exceeds field width";
+         fmt->error = "Minimum digits exceeds field width";
          goto finished;
        }
 
       break;
 
     default:
-      error = unexpected_element;
+      fmt->error = unexpected_element;
       goto finished;
     }
 
   /* Between a descriptor and what comes next */
  between_desc:
-  t = format_lex ();
+  t = format_lex (fmt);
   switch (t)
     {
     case FMT_COMMA:
@@ -846,7 +841,7 @@ parse_format_list (void)
       goto finished;
 
     case FMT_SLASH:
-      get_fnode (&head, &tail, FMT_SLASH);
+      get_fnode (fmt, &head, &tail, FMT_SLASH);
       tail->repeat = 1;
 
       /* Fall Through */
@@ -855,7 +850,7 @@ parse_format_list (void)
       goto optional_comma;
 
     case FMT_END:
-      error = unexpected_end;
+      fmt->error = unexpected_end;
       goto finished;
 
     default:
@@ -866,7 +861,7 @@ parse_format_list (void)
   /* Optional comma is a weird between state where we've just finished
      reading a colon, slash or P descriptor. */
  optional_comma:
-  t = format_lex ();
+  t = format_lex (fmt);
   switch (t)
     {
     case FMT_COMMA:
@@ -876,7 +871,7 @@ parse_format_list (void)
       goto finished;
 
     default:                   /* Assume that we have another format item */
-      saved_token = t;
+      fmt->saved_token = t;
       break;
     }
 
@@ -892,30 +887,28 @@ parse_format_list (void)
  * is assumed to happen at parse time, and the current location of the
  * parser is shown.
  *
- * After freeing any dynamically allocated fnodes, generate a message
- * showing where the problem is.  We take extra care to print only the
- * relevant part of the format if it is longer than a standard 80
- * column display. */
+ * We generate a message showing where the problem is.  We take extra
+ * care to print only the relevant part of the format if it is longer
+ * than a standard 80 column display. */
 
 void
-format_error (fnode * f, const char *message)
+format_error (st_parameter_dt *dtp, const fnode *f, const char *message)
 {
   int width, i, j, offset;
   char *p, buffer[300];
+  format_data *fmt = dtp->u.p.fmt;
 
   if (f != NULL)
-    format_string = f->source;
-
-  free_fnodes ();
+    fmt->format_string = f->source;
 
   st_sprintf (buffer, "%s\n", message);
 
-  j = format_string - ioparm.format;
+  j = fmt->format_string - dtp->format;
 
   offset = (j > 60) ? j - 40 : 0;
 
   j -= offset;
-  width = ioparm.format_len - offset;
+  width = dtp->format_len - offset;
 
   if (width > 80)
     width = 80;
@@ -924,7 +917,7 @@ format_error (fnode * f, const char *message)
 
   p = strchr (buffer, '\0');
 
-  memcpy (p, ioparm.format + offset, width);
+  memcpy (p, dtp->format + offset, width);
 
   p += width;
   *p++ = '\n';
@@ -937,42 +930,49 @@ format_error (fnode * f, const char *message)
   *p++ = '^';
   *p = '\0';
 
-  generate_error (ERROR_FORMAT, buffer);
+  generate_error (&dtp->common, ERROR_FORMAT, buffer);
 }
 
 
 /* parse_format()-- Parse a format string.  */
 
 void
-parse_format (void)
+parse_format (st_parameter_dt *dtp)
 {
-  format_string = ioparm.format;
-  format_string_len = ioparm.format_len;
+  format_data *fmt;
 
-  saved_token = FMT_NONE;
-  error = NULL;
+  dtp->u.p.fmt = fmt = get_mem (sizeof (format_data));
+  fmt->format_string = dtp->format;
+  fmt->format_string_len = dtp->format_len;
+
+  fmt->string = NULL;
+  fmt->saved_token = FMT_NONE;
+  fmt->error = NULL;
+  fmt->value = 0;
 
   /* Initialize variables used during traversal of the tree */
 
-  reversion_ok = 0;
-  g.reversion_flag = 0;
-  saved_format = NULL;
+  fmt->reversion_ok = 0;
+  fmt->saved_format = NULL;
 
   /* Allocate the first format node as the root of the tree */
 
-  avail = array;
+  fmt->last = &fmt->array;
+  fmt->last->next = NULL;
+  fmt->avail = &fmt->array.array[0];
 
-  avail->format = FMT_LPAREN;
-  avail->repeat = 1;
-  avail++;
+  memset (fmt->avail, 0, sizeof (*fmt->avail));
+  fmt->avail->format = FMT_LPAREN;
+  fmt->avail->repeat = 1;
+  fmt->avail++;
 
-  if (format_lex () == FMT_LPAREN)
-    array[0].u.child = parse_format_list ();
+  if (format_lex (fmt) == FMT_LPAREN)
+    fmt->array.array[0].u.child = parse_format_list (dtp);
   else
-    error = "Missing initial left parenthesis in format";
+    fmt->error = "Missing initial left parenthesis in format";
 
-  if (error)
-    format_error (NULL, error);
+  if (fmt->error)
+    format_error (dtp, NULL, fmt->error);
 }
 
 
@@ -984,22 +984,23 @@ parse_format (void)
  * level. */
 
 static void
-revert (void)
+revert (st_parameter_dt *dtp)
 {
   fnode *f, *r;
+  format_data *fmt = dtp->u.p.fmt;
 
-  g.reversion_flag = 1;
+  dtp->u.p.reversion_flag = 1;
 
   r = NULL;
 
-  for (f = array[0].u.child; f; f = f->next)
+  for (f = fmt->array.array[0].u.child; f; f = f->next)
     if (f->format == FMT_LPAREN)
       r = f;
 
   /* If r is NULL because no node was found, the whole tree will be used */
 
-  array[0].current = r;
-  array[0].count = 0;
+  fmt->array.array[0].current = r;
+  fmt->array.array[0].count = 0;
 }
 
 
@@ -1008,10 +1009,10 @@ revert (void)
  * Parenthesis nodes are incremented after the list has been
  * exhausted, other nodes are incremented before they are returned. */
 
-static fnode *
+static const fnode *
 next_format0 (fnode * f)
 {
-  fnode *r;
+  const fnode *r;
 
   if (f == NULL)
     return NULL;
@@ -1053,41 +1054,40 @@ next_format0 (fnode * f)
  * are no more data descriptors to return (which is an error
  * condition). */
 
-fnode *
-next_format (void)
+const fnode *
+next_format (st_parameter_dt *dtp)
 {
   format_token t;
-  fnode *f;
+  const fnode *f;
+  format_data *fmt = dtp->u.p.fmt;
 
-  if (saved_format != NULL)
+  if (fmt->saved_format != NULL)
     {                          /* Deal with a pushed-back format node */
-      f = saved_format;
-      saved_format = NULL;
+      f = fmt->saved_format;
+      fmt->saved_format = NULL;
       goto done;
     }
 
-  f = next_format0 (&array[0]);
+  f = next_format0 (&fmt->array.array[0]);
   if (f == NULL)
     {
-      if (!reversion_ok)
-       {
-         return NULL;
-       }
+      if (!fmt->reversion_ok)
+       return NULL;
 
-      reversion_ok = 0;
-      revert ();
+      fmt->reversion_ok = 0;
+      revert (dtp);
 
-      f = next_format0 (&array[0]);
+      f = next_format0 (&fmt->array.array[0]);
       if (f == NULL)
        {
-         format_error (NULL, reversion_error);
+         format_error (dtp, NULL, reversion_error);
          return NULL;
        }
 
       /* Push the first reverted token and return a colon node in case
        * there are no more data items. */
 
-      saved_format = f;
+      fmt->saved_format = f;
       return &colon_node;
     }
 
@@ -1095,11 +1095,11 @@ next_format (void)
  done:
   t = f->format;
 
-  if (!reversion_ok &&
+  if (!fmt->reversion_ok &&
       (t == FMT_I || t == FMT_B || t == FMT_O || t == FMT_Z || t == FMT_F ||
        t == FMT_E || t == FMT_EN || t == FMT_ES || t == FMT_G || t == FMT_L ||
        t == FMT_A || t == FMT_D))
-    reversion_ok = 1;
+    fmt->reversion_ok = 1;
   return f;
 }
 
@@ -1112,9 +1112,9 @@ next_format (void)
  * which calls the library back with the data item (or not). */
 
 void
-unget_format (fnode * f)
+unget_format (st_parameter_dt *dtp, const fnode *f)
 {
-  saved_format = f;
+  dtp->u.p.fmt->saved_format = f;
 }
 
 
@@ -1272,14 +1272,14 @@ dump_format (void)
 
 
 void
-next_test (void)
+next_test (st_parameter_dt *dtp)
 {
   fnode *f;
   int i;
 
   for (i = 0; i < 20; i++)
     {
-      f = next_format ();
+      f = next_format (dtp);
       if (f == NULL)
        {
          st_printf ("No format!\n");
index 56f466e..bccd5a1 100644 (file)
@@ -1,4 +1,4 @@
-/* Copyright (C) 2002-2003 Free Software Foundation, Inc.
+/* Copyright (C) 2002, 2003, 2005 Free Software Foundation, Inc.
    Contributed by Andy Vaught
 
 This file is part of the GNU Fortran 95 runtime library (libgfortran).
@@ -41,31 +41,28 @@ static const char undefined[] = "UNDEFINED";
 /* inquire_via_unit()-- Inquiry via unit number.  The unit might not exist. */
 
 static void
-inquire_via_unit (gfc_unit * u)
+inquire_via_unit (st_parameter_inquire *iqp, gfc_unit * u)
 {
   const char *p;
+  GFC_INTEGER_4 cf = iqp->common.flags;
 
-  if (ioparm.exist != NULL)
-  {
-    if (ioparm.unit >= 0)
-      *ioparm.exist = 1;
-    else
-      *ioparm.exist = 0;
-  }
+  if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0)
+    *iqp->exist = iqp->common.unit >= 0;
 
-  if (ioparm.opened != NULL)
-    *ioparm.opened = (u != NULL);
+  if ((cf & IOPARM_INQUIRE_HAS_OPENED) != 0)
+    *iqp->opened = (u != NULL);
 
-  if (ioparm.number != NULL)
-    *ioparm.number = (u != NULL) ? u->unit_number : -1;
+  if ((cf & IOPARM_INQUIRE_HAS_NUMBER) != 0)
+    *iqp->number = (u != NULL) ? u->unit_number : -1;
 
-  if (ioparm.named != NULL)
-    *ioparm.named = (u != NULL && u->flags.status != STATUS_SCRATCH);
+  if ((cf & IOPARM_INQUIRE_HAS_NAMED) != 0)
+    *iqp->named = (u != NULL && u->flags.status != STATUS_SCRATCH);
 
-  if (ioparm.name != NULL && u != NULL && u->flags.status != STATUS_SCRATCH)
-    fstrcpy (ioparm.name, ioparm.name_len, u->file, u->file_len);
+  if ((cf & IOPARM_INQUIRE_HAS_NAME) != 0
+      && u != NULL && u->flags.status != STATUS_SCRATCH)
+    fstrcpy (iqp->name, iqp->name_len, u->file, u->file_len);
 
-  if (ioparm.access != NULL)
+  if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
     {
       if (u == NULL)
        p = undefined;
@@ -79,13 +76,13 @@ inquire_via_unit (gfc_unit * u)
            p = "DIRECT";
            break;
          default:
-           internal_error ("inquire_via_unit(): Bad access");
+           internal_error (&iqp->common, "inquire_via_unit(): Bad access");
          }
 
-      cf_strcpy (ioparm.access, ioparm.access_len, p);
+      cf_strcpy (iqp->access, iqp->access_len, p);
     }
 
-  if (ioparm.sequential != NULL)
+  if ((cf & IOPARM_INQUIRE_HAS_SEQUENTIAL) != 0)
     {
       if (u == NULL)
        p = inquire_sequential (NULL, 0);
@@ -98,18 +95,18 @@ inquire_via_unit (gfc_unit * u)
             p = inquire_sequential (u->file, u->file_len);
        }
 
-      cf_strcpy (ioparm.sequential, ioparm.sequential_len, p);
+      cf_strcpy (iqp->sequential, iqp->sequential_len, p);
     }
 
-  if (ioparm.direct != NULL)
+  if ((cf & IOPARM_INQUIRE_HAS_DIRECT) != 0)
     {
       p = (u == NULL) ? inquire_direct (NULL, 0) :
        inquire_direct (u->file, u->file_len);
 
-      cf_strcpy (ioparm.direct, ioparm.direct_len, p);
+      cf_strcpy (iqp->direct, iqp->direct_len, p);
     }
 
-  if (ioparm.form != NULL)
+  if ((cf & IOPARM_INQUIRE_HAS_FORM) != 0)
     {
       if (u == NULL)
        p = undefined;
@@ -123,35 +120,35 @@ inquire_via_unit (gfc_unit * u)
            p = "UNFORMATTED";
            break;
          default:
-           internal_error ("inquire_via_unit(): Bad form");
+           internal_error (&iqp->common, "inquire_via_unit(): Bad form");
          }
 
-      cf_strcpy (ioparm.form, ioparm.form_len, p);
+      cf_strcpy (iqp->form, iqp->form_len, p);
     }
 
-  if (ioparm.formatted != NULL)
+  if ((cf & IOPARM_INQUIRE_HAS_FORMATTED) != 0)
     {
       p = (u == NULL) ? inquire_formatted (NULL, 0) :
        inquire_formatted (u->file, u->file_len);
 
-      cf_strcpy (ioparm.formatted, ioparm.formatted_len, p);
+      cf_strcpy (iqp->formatted, iqp->formatted_len, p);
     }
 
-  if (ioparm.unformatted != NULL)
+  if ((cf & IOPARM_INQUIRE_HAS_UNFORMATTED) != 0)
     {
       p = (u == NULL) ? inquire_unformatted (NULL, 0) :
        inquire_unformatted (u->file, u->file_len);
 
-      cf_strcpy (ioparm.unformatted, ioparm.unformatted_len, p);
+      cf_strcpy (iqp->unformatted, iqp->unformatted_len, p);
     }
 
-  if (ioparm.recl_out != NULL)
-    *ioparm.recl_out = (u != NULL) ? u->recl : 0;
+  if ((cf & IOPARM_INQUIRE_HAS_RECL_OUT) != 0)
+    *iqp->recl_out = (u != NULL) ? u->recl : 0;
 
-  if (ioparm.nextrec != NULL)
-    *ioparm.nextrec = (u != NULL) ? u->last_record + 1 : 0;
+  if ((cf & IOPARM_INQUIRE_HAS_NEXTREC) != 0)
+    *iqp->nextrec = (u != NULL) ? u->last_record + 1 : 0;
 
-  if (ioparm.blank != NULL)
+  if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0)
     {
       if (u == NULL)
        p = undefined;
@@ -159,19 +156,19 @@ inquire_via_unit (gfc_unit * u)
        switch (u->flags.blank)
          {
          case BLANK_NULL:
-          p = "NULL";
+           p = "NULL";
            break;
          case BLANK_ZERO:
            p = "ZERO";
            break;
          default:
-           internal_error ("inquire_via_unit(): Bad blank");
+           internal_error (&iqp->common, "inquire_via_unit(): Bad blank");
          }
 
-      cf_strcpy (ioparm.blank, ioparm.blank_len, p);
+      cf_strcpy (iqp->blank, iqp->blank_len, p);
     }
 
-  if (ioparm.position != NULL)
+  if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0)
     {
       if (u == NULL || u->flags.access == ACCESS_DIRECT)
         p = undefined;
@@ -194,10 +191,10 @@ inquire_via_unit (gfc_unit * u)
                p = "ASIS";
                break;
           }
-      cf_strcpy (ioparm.position, ioparm.position_len, p);
+      cf_strcpy (iqp->position, iqp->position_len, p);
     }
 
-  if (ioparm.action != NULL)
+  if ((cf & IOPARM_INQUIRE_HAS_ACTION) != 0)
     {
       if (u == NULL)
        p = undefined;
@@ -214,37 +211,37 @@ inquire_via_unit (gfc_unit * u)
            p = "READWRITE";
            break;
          default:
-           internal_error ("inquire_via_unit(): Bad action");
+           internal_error (&iqp->common, "inquire_via_unit(): Bad action");
          }
 
-      cf_strcpy (ioparm.action, ioparm.action_len, p);
+      cf_strcpy (iqp->action, iqp->action_len, p);
     }
 
-  if (ioparm.read != NULL)
+  if ((cf & IOPARM_INQUIRE_HAS_READ) != 0)
     {
       p = (u == NULL) ? inquire_read (NULL, 0) :
        inquire_read (u->file, u->file_len);
 
-      cf_strcpy (ioparm.read, ioparm.read_len, p);
+      cf_strcpy (iqp->read, iqp->read_len, p);
     }
 
-  if (ioparm.write != NULL)
+  if ((cf & IOPARM_INQUIRE_HAS_WRITE) != 0)
     {
       p = (u == NULL) ? inquire_write (NULL, 0) :
        inquire_write (u->file, u->file_len);
 
-      cf_strcpy (ioparm.write, ioparm.write_len, p);
+      cf_strcpy (iqp->write, iqp->write_len, p);
     }
 
-  if (ioparm.readwrite != NULL)
+  if ((cf & IOPARM_INQUIRE_HAS_READWRITE) != 0)
     {
       p = (u == NULL) ? inquire_readwrite (NULL, 0) :
        inquire_readwrite (u->file, u->file_len);
 
-      cf_strcpy (ioparm.readwrite, ioparm.readwrite_len, p);
+      cf_strcpy (iqp->readwrite, iqp->readwrite_len, p);
     }
 
-  if (ioparm.delim != NULL)
+  if ((cf & IOPARM_INQUIRE_HAS_DELIM) != 0)
     {
       if (u == NULL || u->flags.form != FORM_FORMATTED)
        p = undefined;
@@ -261,13 +258,13 @@ inquire_via_unit (gfc_unit * u)
            p = "APOSTROPHE";
            break;
          default:
-           internal_error ("inquire_via_unit(): Bad delim");
+           internal_error (&iqp->common, "inquire_via_unit(): Bad delim");
          }
 
-      cf_strcpy (ioparm.delim, ioparm.delim_len, p);
+      cf_strcpy (iqp->delim, iqp->delim_len, p);
     }
 
-  if (ioparm.pad != NULL)
+  if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
     {
       if (u == NULL || u->flags.form != FORM_FORMATTED)
        p = undefined;
@@ -281,10 +278,10 @@ inquire_via_unit (gfc_unit * u)
            p = "YES";
            break;
          default:
-           internal_error ("inquire_via_unit(): Bad pad");
+           internal_error (&iqp->common, "inquire_via_unit(): Bad pad");
          }
 
-      cf_strcpy (ioparm.pad, ioparm.pad_len, p);
+      cf_strcpy (iqp->pad, iqp->pad_len, p);
     }
 }
 
@@ -293,120 +290,125 @@ inquire_via_unit (gfc_unit * u)
  * only used if the filename is *not* connected to a unit number. */
 
 static void
-inquire_via_filename (void)
+inquire_via_filename (st_parameter_inquire *iqp)
 {
   const char *p;
+  GFC_INTEGER_4 cf = iqp->common.flags;
 
-  if (ioparm.exist != NULL)
-    *ioparm.exist = file_exists ();
+  if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0)
+    *iqp->exist = file_exists (iqp->file, iqp->file_len);
 
-  if (ioparm.opened != NULL)
-    *ioparm.opened = 0;
+  if ((cf & IOPARM_INQUIRE_HAS_OPENED) != 0)
+    *iqp->opened = 0;
 
-  if (ioparm.number != NULL)
-    *ioparm.number = -1;
+  if ((cf & IOPARM_INQUIRE_HAS_NUMBER) != 0)
+    *iqp->number = -1;
 
-  if (ioparm.named != NULL)
-    *ioparm.named = 1;
+  if ((cf & IOPARM_INQUIRE_HAS_NAMED) != 0)
+    *iqp->named = 1;
 
-  if (ioparm.name != NULL)
-    fstrcpy (ioparm.name, ioparm.name_len, ioparm.file, ioparm.file_len);
+  if ((cf & IOPARM_INQUIRE_HAS_NAME) != 0)
+    fstrcpy (iqp->name, iqp->name_len, iqp->file, iqp->file_len);
 
-  if (ioparm.access != NULL)
-    cf_strcpy (ioparm.access, ioparm.access_len, undefined);
+  if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
+    cf_strcpy (iqp->access, iqp->access_len, undefined);
 
-  if (ioparm.sequential != NULL)
+  if ((cf & IOPARM_INQUIRE_HAS_SEQUENTIAL) != 0)
     {
-      p = inquire_sequential (ioparm.file, ioparm.file_len);
-      cf_strcpy (ioparm.sequential, ioparm.sequential_len, p);
+      p = inquire_sequential (iqp->file, iqp->file_len);
+      cf_strcpy (iqp->sequential, iqp->sequential_len, p);
     }
 
-  if (ioparm.direct != NULL)
+  if ((cf & IOPARM_INQUIRE_HAS_DIRECT) != 0)
     {
-      p = inquire_direct (ioparm.file, ioparm.file_len);
-      cf_strcpy (ioparm.direct, ioparm.direct_len, p);
+      p = inquire_direct (iqp->file, iqp->file_len);
+      cf_strcpy (iqp->direct, iqp->direct_len, p);
     }
 
-  if (ioparm.form != NULL)
-    cf_strcpy (ioparm.form, ioparm.form_len, undefined);
+  if ((cf & IOPARM_INQUIRE_HAS_FORM) != 0)
+    cf_strcpy (iqp->form, iqp->form_len, undefined);
 
-  if (ioparm.formatted != NULL)
+  if ((cf & IOPARM_INQUIRE_HAS_FORMATTED) != 0)
     {
-      p = inquire_formatted (ioparm.file, ioparm.file_len);
-      cf_strcpy (ioparm.formatted, ioparm.formatted_len, p);
+      p = inquire_formatted (iqp->file, iqp->file_len);
+      cf_strcpy (iqp->formatted, iqp->formatted_len, p);
     }
 
-  if (ioparm.unformatted != NULL)
+  if ((cf & IOPARM_INQUIRE_HAS_UNFORMATTED) != 0)
     {
-      p = inquire_unformatted (ioparm.file, ioparm.file_len);
-      cf_strcpy (ioparm.unformatted, ioparm.unformatted_len, p);
+      p = inquire_unformatted (iqp->file, iqp->file_len);
+      cf_strcpy (iqp->unformatted, iqp->unformatted_len, p);
     }
 
-  if (ioparm.recl_out != NULL)
-    *ioparm.recl_out = 0;
+  if ((cf & IOPARM_INQUIRE_HAS_RECL_OUT) != 0)
+    *iqp->recl_out = 0;
 
-  if (ioparm.nextrec != NULL)
-    *ioparm.nextrec = 0;
+  if ((cf & IOPARM_INQUIRE_HAS_NEXTREC) != 0)
+    *iqp->nextrec = 0;
 
-  if (ioparm.blank != NULL)
-    cf_strcpy (ioparm.blank, ioparm.blank_len, undefined);
+  if ((cf & IOPARM_INQUIRE_HAS_BLANK) != 0)
+    cf_strcpy (iqp->blank, iqp->blank_len, undefined);
 
-  if (ioparm.position != NULL)
-    cf_strcpy (ioparm.position, ioparm.position_len, undefined);
+  if ((cf & IOPARM_INQUIRE_HAS_POSITION) != 0)
+    cf_strcpy (iqp->position, iqp->position_len, undefined);
 
-  if (ioparm.access != NULL)
-    cf_strcpy (ioparm.access, ioparm.access_len, undefined);
+  if ((cf & IOPARM_INQUIRE_HAS_ACCESS) != 0)
+    cf_strcpy (iqp->access, iqp->access_len, undefined);
 
-  if (ioparm.read != NULL)
+  if ((cf & IOPARM_INQUIRE_HAS_READ) != 0)
     {
-      p = inquire_read (ioparm.file, ioparm.file_len);
-      cf_strcpy (ioparm.read, ioparm.read_len, p);
+      p = inquire_read (iqp->file, iqp->file_len);
+      cf_strcpy (iqp->read, iqp->read_len, p);
     }
 
-  if (ioparm.write != NULL)
+  if ((cf & IOPARM_INQUIRE_HAS_WRITE) != 0)
     {
-      p = inquire_write (ioparm.file, ioparm.file_len);
-      cf_strcpy (ioparm.write, ioparm.write_len, p);
+      p = inquire_write (iqp->file, iqp->file_len);
+      cf_strcpy (iqp->write, iqp->write_len, p);
     }
 
-  if (ioparm.readwrite != NULL)
+  if ((cf & IOPARM_INQUIRE_HAS_READWRITE) != 0)
     {
-      p = inquire_read (ioparm.file, ioparm.file_len);
-      cf_strcpy (ioparm.readwrite, ioparm.readwrite_len, p);
+      p = inquire_read (iqp->file, iqp->file_len);
+      cf_strcpy (iqp->readwrite, iqp->readwrite_len, p);
     }
 
-  if (ioparm.delim != NULL)
-    cf_strcpy (ioparm.delim, ioparm.delim_len, undefined);
-
-  if (ioparm.pad != NULL)
-    cf_strcpy (ioparm.pad, ioparm.pad_len, undefined);
+  if ((cf & IOPARM_INQUIRE_HAS_DELIM) != 0)
+    cf_strcpy (iqp->delim, iqp->delim_len, undefined);
 
+  if ((cf & IOPARM_INQUIRE_HAS_PAD) != 0)
+    cf_strcpy (iqp->pad, iqp->pad_len, undefined);
 }
 
 
 /* Library entry point for the INQUIRE statement (non-IOLENGTH
    form).  */
 
-extern void st_inquire (void);
+extern void st_inquire (st_parameter_inquire *);
 export_proto(st_inquire);
 
 void
-st_inquire (void)
+st_inquire (st_parameter_inquire *iqp)
 {
   gfc_unit *u;
 
-  library_start ();
+  library_start (&iqp->common);
 
-  if (ioparm.file == NULL)
-    inquire_via_unit (find_unit (ioparm.unit));
+  if ((iqp->common.flags & IOPARM_INQUIRE_HAS_FILE) == 0)
+    {
+      u = find_unit (iqp->common.unit);
+      inquire_via_unit (iqp, u);
+    }
   else
     {
-      u = find_file ();
+      u = find_file (iqp->file, iqp->file_len);
       if (u == NULL)
-       inquire_via_filename ();
+       inquire_via_filename (iqp);
       else
-       inquire_via_unit (u);
+       inquire_via_unit (iqp, u);
     }
+  if (u != NULL)
+    unlock_unit (u);
 
   library_end ();
 }
index 47a564f..f080c46 100644 (file)
@@ -32,6 +32,11 @@ Boston, MA 02110-1301, USA.  */
 
 #include <setjmp.h>
 #include "libgfortran.h"
+#ifdef HAVE_PRAGMA_WEAK
+/* Used by gthr.h.  */
+#define SUPPORTS_WEAK 1
+#endif
+#include <gthr.h>
 
 #define DEFAULT_TEMPDIR "/tmp"
 
@@ -48,6 +53,8 @@ typedef enum
 { SUCCESS = 1, FAILURE }
 try;
 
+struct st_parameter_dt;
+
 typedef struct stream
 {
   char *(*alloc_w_at) (struct stream *, int *, gfc_offset);
@@ -202,83 +209,213 @@ typedef enum
 {READING, WRITING}
 unit_mode;
 
-/* Statement parameters.  These are all the things that can appear in
-   an I/O statement.  Some are inputs and some are outputs, but none
-   are both.  All of these values are initially zeroed and are zeroed
-   at the end of a library statement.  The relevant values need to be
-   set before entry to an I/O statement.  This structure needs to be
-   duplicated by the back end.  */
+#define CHARACTER1(name) \
+             char * name; \
+             gfc_charlen_type name ## _len
+#define CHARACTER2(name) \
+             gfc_charlen_type name ## _len; \
+             char * name
+
+#define IOPARM_LIBRETURN_MASK          (3 << 0)
+#define IOPARM_LIBRETURN_OK            (0 << 0)
+#define IOPARM_LIBRETURN_ERROR         (1 << 0)
+#define IOPARM_LIBRETURN_END           (2 << 0)
+#define IOPARM_LIBRETURN_EOR           (3 << 0)
+#define IOPARM_ERR                     (1 << 2)
+#define IOPARM_END                     (1 << 3)
+#define IOPARM_EOR                     (1 << 4)
+#define IOPARM_HAS_IOSTAT              (1 << 5)
+#define IOPARM_HAS_IOMSG               (1 << 6)
+
+#define IOPARM_COMMON_MASK             ((1 << 7) - 1)
+
+typedef struct st_parameter_common
+{
+  GFC_INTEGER_4 flags;
+  GFC_INTEGER_4 unit;
+  const char *filename;
+  GFC_INTEGER_4 line;
+  CHARACTER2 (iomsg);
+  GFC_INTEGER_4 *iostat;
+}
+st_parameter_common;
+
+#define IOPARM_OPEN_HAS_RECL_IN                (1 << 7)
+#define IOPARM_OPEN_HAS_FILE           (1 << 8)
+#define IOPARM_OPEN_HAS_STATUS         (1 << 9)
+#define IOPARM_OPEN_HAS_ACCESS         (1 << 10)
+#define IOPARM_OPEN_HAS_FORM           (1 << 11)
+#define IOPARM_OPEN_HAS_BLANK          (1 << 12)
+#define IOPARM_OPEN_HAS_POSITION       (1 << 13)
+#define IOPARM_OPEN_HAS_ACTION         (1 << 14)
+#define IOPARM_OPEN_HAS_DELIM          (1 << 15)
+#define IOPARM_OPEN_HAS_PAD            (1 << 16)
 
 typedef struct
 {
-  GFC_INTEGER_4 unit;
-  GFC_INTEGER_4 err, end, eor, list_format; /* These are flags, not values.  */
+  st_parameter_common common;
+  GFC_INTEGER_4 recl_in;
+  CHARACTER2 (file);
+  CHARACTER1 (status);
+  CHARACTER2 (access);
+  CHARACTER1 (form);
+  CHARACTER2 (blank);
+  CHARACTER1 (position);
+  CHARACTER2 (action);
+  CHARACTER1 (delim);
+  CHARACTER2 (pad);
+}
+st_parameter_open;
 
-/* Return values from library statements.  These are returned only if
-   the labels are specified in the statement itself and the condition
-   occurs.  In most cases, none of the labels are specified and the
-   return value does not have to be checked.  Must be consistent with
-   the front end.  */
+#define IOPARM_CLOSE_HAS_STATUS                (1 << 7)
 
-  enum
-  {
-    LIBRARY_OK = 0,
-    LIBRARY_ERROR,
-    LIBRARY_END,
-    LIBRARY_EOR
-  }
-  library_return;
+typedef struct
+{
+  st_parameter_common common;
+  CHARACTER1 (status);
+}
+st_parameter_close;
 
-  GFC_INTEGER_4 *iostat, *exist, *opened, *number, *named;
-  GFC_INTEGER_4 rec;
-  GFC_INTEGER_4 *nextrec, *size;
+typedef struct
+{
+  st_parameter_common common;
+}
+st_parameter_filepos;
+
+#define IOPARM_INQUIRE_HAS_EXIST       (1 << 7)
+#define IOPARM_INQUIRE_HAS_OPENED      (1 << 8)
+#define IOPARM_INQUIRE_HAS_NUMBER      (1 << 9)
+#define IOPARM_INQUIRE_HAS_NAMED       (1 << 10)
+#define IOPARM_INQUIRE_HAS_NEXTREC     (1 << 11)
+#define IOPARM_INQUIRE_HAS_RECL_OUT    (1 << 12)
+#define IOPARM_INQUIRE_HAS_FILE                (1 << 13)
+#define IOPARM_INQUIRE_HAS_ACCESS      (1 << 14)
+#define IOPARM_INQUIRE_HAS_FORM                (1 << 15)
+#define IOPARM_INQUIRE_HAS_BLANK       (1 << 16)
+#define IOPARM_INQUIRE_HAS_POSITION    (1 << 17)
+#define IOPARM_INQUIRE_HAS_ACTION      (1 << 18)
+#define IOPARM_INQUIRE_HAS_DELIM       (1 << 19)
+#define IOPARM_INQUIRE_HAS_PAD         (1 << 20)
+#define IOPARM_INQUIRE_HAS_NAME                (1 << 21)
+#define IOPARM_INQUIRE_HAS_SEQUENTIAL  (1 << 22)
+#define IOPARM_INQUIRE_HAS_DIRECT      (1 << 23)
+#define IOPARM_INQUIRE_HAS_FORMATTED   (1 << 24)
+#define IOPARM_INQUIRE_HAS_UNFORMATTED (1 << 25)
+#define IOPARM_INQUIRE_HAS_READ                (1 << 26)
+#define IOPARM_INQUIRE_HAS_WRITE       (1 << 27)
+#define IOPARM_INQUIRE_HAS_READWRITE   (1 << 28)
 
-  GFC_INTEGER_4 recl_in;
-  GFC_INTEGER_4 *recl_out;
-
-  GFC_INTEGER_4 *iolength;
-
-#define CHARACTER(name) \
-              char * name; \
-              gfc_charlen_type name ## _len
-  CHARACTER (file);
-  CHARACTER (status);
-  CHARACTER (access);
-  CHARACTER (form);
-  CHARACTER (blank);
-  CHARACTER (position);
-  CHARACTER (action);
-  CHARACTER (delim);
-  CHARACTER (pad);
-  CHARACTER (format);
-  CHARACTER (advance);
-  CHARACTER (name);
-  CHARACTER (internal_unit);
+typedef struct
+{
+  st_parameter_common common;
+  GFC_INTEGER_4 *exist, *opened, *number, *named;
+  GFC_INTEGER_4 *nextrec, *recl_out;
+  CHARACTER1 (file);
+  CHARACTER2 (access);
+  CHARACTER1 (form);
+  CHARACTER2 (blank);
+  CHARACTER1 (position);
+  CHARACTER2 (action);
+  CHARACTER1 (delim);
+  CHARACTER2 (pad);
+  CHARACTER1 (name);
+  CHARACTER2 (sequential);
+  CHARACTER1 (direct);
+  CHARACTER2 (formatted);
+  CHARACTER1 (unformatted);
+  CHARACTER2 (read);
+  CHARACTER1 (write);
+  CHARACTER2 (readwrite);
+}
+st_parameter_inquire;
+
+struct gfc_unit;
+struct format_data;
+
+#define IOPARM_DT_LIST_FORMAT                  (1 << 7)
+#define IOPARM_DT_NAMELIST_READ_MODE           (1 << 8)
+#define IOPARM_DT_HAS_REC                      (1 << 9)
+#define IOPARM_DT_HAS_SIZE                     (1 << 10)
+#define IOPARM_DT_HAS_IOLENGTH                 (1 << 11)
+#define IOPARM_DT_HAS_FORMAT                   (1 << 12)
+#define IOPARM_DT_HAS_ADVANCE                  (1 << 13)
+#define IOPARM_DT_HAS_INTERNAL_UNIT            (1 << 14)
+#define IOPARM_DT_HAS_NAMELIST_NAME            (1 << 15)
+/* Internal use bit.  */
+#define IOPARM_DT_IONML_SET                    (1 << 31)
+
+typedef struct st_parameter_dt
+{
+  st_parameter_common common;
+  GFC_INTEGER_4 rec;
+  GFC_INTEGER_4 *size, *iolength;
   gfc_array_char *internal_unit_desc;
-  CHARACTER (sequential);
-  CHARACTER (direct);
-  CHARACTER (formatted);
-  CHARACTER (unformatted);
-  CHARACTER (read);
-  CHARACTER (write);
-  CHARACTER (readwrite);
-
-/* namelist related data */
-  CHARACTER (namelist_name);
-  GFC_INTEGER_4 namelist_read_mode;
-
-  /* iomsg */
-  CHARACTER (iomsg);
-
-#undef CHARACTER
+  CHARACTER1 (format);
+  CHARACTER2 (advance);
+  CHARACTER1 (internal_unit);
+  CHARACTER2 (namelist_name);
+  /* Private part of the structure.  The compiler just needs
+     to reserve enough space.  */
+  union
+    {
+      struct
+       {
+         void (*transfer) (struct st_parameter_dt *, bt, void *, int,
+                           size_t, size_t);
+         struct gfc_unit *current_unit;
+         int item_count; /* Item number in a formatted data transfer.  */
+         unit_mode mode;
+         unit_blank blank_status;
+         enum {SIGN_S, SIGN_SS, SIGN_SP} sign_status;
+         int scale_factor;
+         int max_pos; /* Maximum righthand column written to.  */
+         /* Number of skips + spaces to be done for T and X-editing.  */
+         int skips;
+         /* Number of spaces to be done for T and X-editing.  */
+         int pending_spaces;
+         unit_advance advance_status;
+         char reversion_flag; /* Format reversion has occurred.  */
+         char first_item;
+         char seen_dollar;
+         char sf_seen_eor;
+         char eor_condition;
+         char no_leading_blank;
+         char nml_delim;
+         char char_flag;
+         char input_complete;
+         char at_eol;
+         char comma_flag;
+         char last_char;
+         /* A namelist specific flag used in the list directed library
+            to flag that calls are being made from namelist read (eg. to
+            ignore comments or to treat '/' as a terminator)  */
+         char namelist_mode;
+         /* A namelist specific flag used in the list directed library
+            to flag read errors and return, so that an attempt can be
+            made to read a new object name.  */
+         char nml_read_error;
+         /* Storage area for values except for strings.  Must be large
+            enough to hold a complex value (two reals) of the largest
+            kind.  */
+         char value[32];
+         int repeat_count;
+         int saved_length;
+         int saved_used;
+         bt saved_type;
+         char *saved_string;
+         char *scratch;
+         char *line_buffer;
+         struct format_data *fmt;
+         jmp_buf *eof_jump;
+         namelist_info *ionml;
+       } p;
+      char pad[16 * sizeof (char *) + 32 * sizeof (int)];
+    } u;
 }
-st_parameter;
+st_parameter_dt;
 
-extern st_parameter ioparm;
-iexport_data_proto(ioparm);
-
-extern namelist_info * ionml;
-internal_proto(ionml);
+#undef CHARACTER1
+#undef CHARACTER2
 
 typedef struct
 {
@@ -316,55 +453,36 @@ typedef struct gfc_unit
   { NO_ENDFILE, AT_ENDFILE, AFTER_ENDFILE }
   endfile;
 
-  unit_mode  mode;
+  unit_mode mode;
   unit_flags flags;
-  
+
   /* recl           -- Record length of the file.
      last_record    -- Last record number read or written
      maxrec         -- Maximum record number in a direct access file
      bytes_left     -- Bytes left in current record.  */
   gfc_offset recl, last_record, maxrec, bytes_left;
 
+  __gthread_mutex_t lock;
+  /* Number of threads waiting to acquire this unit's lock.
+     When non-zero, close_unit doesn't only removes the unit
+     from the UNIT_ROOT tree, but doesn't free it and the
+     last of the waiting threads will do that.
+     This must be either atomically increased/decreased, or
+     always guarded by UNIT_LOCK.  */
+  int waiting;
+  /* Flag set by close_unit if the unit as been closed.
+     Must be manipulated under unit's lock.  */
+  int closed;
+
   /* For traversing arrays */
   array_loop_spec *ls;
   int rank;
-  
-  /* Filename is allocated at the end of the structure.  */  
+
   int file_len;
-  char file[1];
+  char *file;
 }
 gfc_unit;
 
-/* Global variables.  Putting these in a structure makes it easier to
-   maintain, particularly with the constraint of a prefix.  */
-
-typedef struct
-{
-  int in_library;       /* Nonzero if a library call is being processed.  */
-  int size;    /* Bytes processed by the current data-transfer statement.  */
-  gfc_offset max_offset;       /* Maximum file offset.  */
-  int item_count;      /* Item number in a formatted data transfer.  */
-  int reversion_flag;  /* Format reversion has occurred.  */
-  int first_item;
-
-  gfc_unit *unit_root;
-  int seen_dollar;
-
-  unit_mode  mode;
-
-  unit_blank blank_status;
-  enum {SIGN_S, SIGN_SS, SIGN_SP} sign_status;
-  int scale_factor;
-  jmp_buf eof_jump;
-}
-global_t;
-
-extern global_t g;
-internal_proto(g);
-
-extern gfc_unit *current_unit;
-internal_proto(current_unit);
-
 /* Format tokens.  Only about half of these can be stored in the
    format nodes.  */
 
@@ -436,10 +554,7 @@ internal_proto(move_pos_offset);
 extern int compare_files (stream *, stream *);
 internal_proto(compare_files);
 
-extern stream *init_error_stream (void);
-internal_proto(init_error_stream);
-
-extern stream *open_external (unit_flags *);
+extern stream *open_external (st_parameter_open *, unit_flags *);
 internal_proto(open_external);
 
 extern stream *open_internal (char *, int);
@@ -457,9 +572,12 @@ internal_proto(error_stream);
 extern int compare_file_filename (gfc_unit *, const char *, int);
 internal_proto(compare_file_filename);
 
-extern gfc_unit *find_file (void);
+extern gfc_unit *find_file (const char *file, gfc_charlen_type file_len);
 internal_proto(find_file);
 
+extern void flush_all_units (void);
+internal_proto(flush_all_units);
+
 extern int stream_at_bof (stream *);
 internal_proto(stream_at_bof);
 
@@ -469,7 +587,7 @@ internal_proto(stream_at_eof);
 extern int delete_file (gfc_unit *);
 internal_proto(delete_file);
 
-extern int file_exists (void);
+extern int file_exists (const char *file, gfc_charlen_type file_len);
 internal_proto(file_exists);
 
 extern const char *inquire_sequential (const char *, int);
@@ -531,72 +649,83 @@ internal_proto(unpack_filename);
 
 /* unit.c */
 
-extern void insert_unit (gfc_unit *);
-internal_proto(insert_unit);
+/* Maximum file offset, computed at library initialization time.  */
+extern gfc_offset max_offset;
+internal_proto(max_offset);
+
+/* Unit tree root.  */
+extern gfc_unit *unit_root;
+internal_proto(unit_root);
+
+extern __gthread_mutex_t unit_lock;
+internal_proto(unit_lock);
 
 extern int close_unit (gfc_unit *);
 internal_proto(close_unit);
 
-extern int is_internal_unit (void);
+extern int is_internal_unit (st_parameter_dt *);
 internal_proto(is_internal_unit);
 
-extern int is_array_io (void);
+extern int is_array_io (st_parameter_dt *);
 internal_proto(is_array_io);
 
 extern gfc_unit *find_unit (int);
 internal_proto(find_unit);
 
-extern gfc_unit *get_unit (int);
+extern gfc_unit *find_or_create_unit (int);
+internal_proto(find_unit);
+
+extern gfc_unit *get_unit (st_parameter_dt *, int);
 internal_proto(get_unit);
 
+extern void unlock_unit (gfc_unit *);
+internal_proto(unlock_unit);
+
 /* open.c */
 
 extern void test_endfile (gfc_unit *);
 internal_proto(test_endfile);
 
-extern void new_unit (unit_flags *);
+extern gfc_unit *new_unit (st_parameter_open *, gfc_unit *, unit_flags *);
 internal_proto(new_unit);
 
 /* format.c */
 
-extern void parse_format (void);
+extern void parse_format (st_parameter_dt *);
 internal_proto(parse_format);
 
-extern fnode *next_format (void);
+extern const fnode *next_format (st_parameter_dt *);
 internal_proto(next_format);
 
-extern void unget_format (fnode *);
+extern void unget_format (st_parameter_dt *, const fnode *);
 internal_proto(unget_format);
 
-extern void format_error (fnode *, const char *);
+extern void format_error (st_parameter_dt *, const fnode *, const char *);
 internal_proto(format_error);
 
-extern void free_fnodes (void);
-internal_proto(free_fnodes);
+extern void free_format_data (st_parameter_dt *);
+internal_proto(free_format_data);
 
 /* transfer.c */
 
 #define SCRATCH_SIZE 300
 
-extern char scratch[];
-internal_proto(scratch);
-
 extern const char *type_name (bt);
 internal_proto(type_name);
 
-extern void *read_block (int *);
+extern void *read_block (st_parameter_dt *, int *);
 internal_proto(read_block);
 
-extern void *write_block (int);
+extern void *write_block (st_parameter_dt *, int);
 internal_proto(write_block);
 
-extern gfc_offset next_array_record (array_loop_spec *);
+extern gfc_offset next_array_record (st_parameter_dt *, array_loop_spec *);
 internal_proto(next_array_record);
 
-extern gfc_offset init_loop_spec (gfc_array_char *desc, array_loop_spec *ls);
+extern gfc_offset init_loop_spec (gfc_array_char *, array_loop_spec *);
 internal_proto(init_loop_spec);
 
-extern void next_record (int);
+extern void next_record (st_parameter_dt *, int);
 internal_proto(next_record);
 
 /* read.c */
@@ -607,83 +736,82 @@ internal_proto(set_integer);
 extern GFC_UINTEGER_LARGEST max_value (int, int);
 internal_proto(max_value);
 
-extern int convert_real (void *, const char *, int);
+extern int convert_real (st_parameter_dt *, void *, const char *, int);
 internal_proto(convert_real);
 
-extern void read_a (fnode *, char *, int);
+extern void read_a (st_parameter_dt *, const fnode *, char *, int);
 internal_proto(read_a);
 
-extern void read_f (fnode *, char *, int);
+extern void read_f (st_parameter_dt *, const fnode *, char *, int);
 internal_proto(read_f);
 
-extern void read_l (fnode *, char *, int);
+extern void read_l (st_parameter_dt *, const fnode *, char *, int);
 internal_proto(read_l);
 
-extern void read_x (int);
+extern void read_x (st_parameter_dt *, int);
 internal_proto(read_x);
 
-extern void read_radix (fnode *, char *, int, int);
+extern void read_radix (st_parameter_dt *, const fnode *, char *, int, int);
 internal_proto(read_radix);
 
-extern void read_decimal (fnode *, char *, int);
+extern void read_decimal (st_parameter_dt *, const fnode *, char *, int);
 internal_proto(read_decimal);
 
 /* list_read.c */
 
-extern void list_formatted_read (bt, void *, int, size_t, size_t);
+extern void list_formatted_read (st_parameter_dt *, bt, void *, int, size_t,
+                                size_t);
 internal_proto(list_formatted_read);
 
-extern void finish_list_read (void);
+extern void finish_list_read (st_parameter_dt *);
 internal_proto(finish_list_read);
 
-extern void init_at_eol (void);
-internal_proto(init_at_eol);
-
-extern void namelist_read (void);
+extern void namelist_read (st_parameter_dt *);
 internal_proto(namelist_read);
 
-extern void namelist_write (void);
+extern void namelist_write (st_parameter_dt *);
 internal_proto(namelist_write);
 
 /* write.c */
 
-extern void write_a (fnode *, const char *, int);
+extern void write_a (st_parameter_dt *, const fnode *, const char *, int);
 internal_proto(write_a);
 
-extern void write_b (fnode *, const char *, int);
+extern void write_b (st_parameter_dt *, const fnode *, const char *, int);
 internal_proto(write_b);
 
-extern void write_d (fnode *, const char *, int);
+extern void write_d (st_parameter_dt *, const fnode *, const char *, int);
 internal_proto(write_d);
 
-extern void write_e (fnode *, const char *, int);
+extern void write_e (st_parameter_dt *, const fnode *, const char *, int);
 internal_proto(write_e);
 
-extern void write_en (fnode *, const char *, int);
+extern void write_en (st_parameter_dt *, const fnode *, const char *, int);
 internal_proto(write_en);
 
-extern void write_es (fnode *, const char *, int);
+extern void write_es (st_parameter_dt *, const fnode *, const char *, int);
 internal_proto(write_es);
 
-extern void write_f (fnode *, const char *, int);
+extern void write_f (st_parameter_dt *, const fnode *, const char *, int);
 internal_proto(write_f);
 
-extern void write_i (fnode *, const char *, int);
+extern void write_i (st_parameter_dt *, const fnode *, const char *, int);
 internal_proto(write_i);
 
-extern void write_l (fnode *, char *, int);
+extern void write_l (st_parameter_dt *, const fnode *, char *, int);
 internal_proto(write_l);
 
-extern void write_o (fnode *, const char *, int);
+extern void write_o (st_parameter_dt *, const fnode *, const char *, int);
 internal_proto(write_o);
 
-extern void write_x (int, int);
+extern void write_x (st_parameter_dt *, int, int);
 internal_proto(write_x);
 
-extern void write_z (fnode *, const char *, int);
+extern void write_z (st_parameter_dt *, const fnode *, const char *, int);
 internal_proto(write_z);
 
-extern void list_formatted_write (bt, void *, int, size_t, size_t);
+extern void list_formatted_write (st_parameter_dt *, bt, void *, int, size_t,
+                                 size_t);
 internal_proto(list_formatted_write);
 
 /* error.c */
@@ -697,4 +825,40 @@ internal_proto(size_from_real_kind);
 extern size_t size_from_complex_kind (int);
 internal_proto(size_from_complex_kind);
 
+/* lock.c */
+extern void free_ionml (st_parameter_dt *);
+internal_proto(free_ionml);
+
+static inline void
+inc_waiting_locked (gfc_unit *u)
+{
+#ifdef HAVE_SYNC_FETCH_AND_ADD
+  (void) __sync_fetch_and_add (&u->waiting, 1);
+#else
+  u->waiting++;
+#endif
+}
+
+static inline int
+predec_waiting_locked (gfc_unit *u)
+{
+#ifdef HAVE_SYNC_FETCH_AND_ADD
+  return __sync_add_and_fetch (&u->waiting, -1);
+#else
+  return --u->waiting;
+#endif
+}
+
+static inline void
+dec_waiting_unlocked (gfc_unit *u)
+{
+#ifdef HAVE_SYNC_FETCH_AND_ADD
+  (void) __sync_fetch_and_add (&u->waiting, -1);
+#else
+  __gthread_mutex_lock (&unit_lock);
+  u->waiting--;
+  __gthread_mutex_unlock (&unit_lock);
+#endif
+}
+
 #endif
index 0d6fe47..be620ae 100644 (file)
@@ -48,30 +48,7 @@ Boston, MA 02110-1301, USA.  */
    the repeat count.  Since we can have a lot of potential leading
    zeros, we have to be able to back up by arbitrary amount.  Because
    the input might not be seekable, we have to buffer the data
-   ourselves.  Data is buffered in scratch[] until it becomes too
-   large, after which we start allocating memory on the heap.  */
-
-static int repeat_count, saved_length, saved_used;
-static int input_complete, at_eol, comma_flag;
-static char last_char, *saved_string;
-static bt saved_type;
-
-/* A namelist specific flag used in the list directed library
-   to flag that calls are being made from namelist read (eg. to ignore
-   comments or to treat '/' as a terminator)  */
-
-static int namelist_mode;
-
-/* A namelist specific flag used in the list directed library to flag
-   read errors and return, so that an attempt can be made to read a
-   new object name.  */
-
-static int nml_read_error;
-
-/* Storage area for values except for strings.  Must be large enough
-   to hold a complex value (two reals) of the largest kind.  */
-
-static char value[32];
+   ourselves.  */
 
 #define CASE_DIGITS   case '0': case '1': case '2': case '3': case '4': \
                       case '5': case '6': case '7': case '8': case '9'
@@ -92,72 +69,74 @@ static char value[32];
 /* Save a character to a string buffer, enlarging it as necessary.  */
 
 static void
-push_char (char c)
+push_char (st_parameter_dt *dtp, char c)
 {
   char *new;
 
-  if (saved_string == NULL)
+  if (dtp->u.p.saved_string == NULL)
     {
-      saved_string = scratch;
-      memset (saved_string,0,SCRATCH_SIZE);
-      saved_length = SCRATCH_SIZE;
-      saved_used = 0;
+      if (dtp->u.p.scratch == NULL)
+       dtp->u.p.scratch = get_mem (SCRATCH_SIZE);
+      dtp->u.p.saved_string = dtp->u.p.scratch;
+      memset (dtp->u.p.saved_string, 0, SCRATCH_SIZE);
+      dtp->u.p.saved_length = SCRATCH_SIZE;
+      dtp->u.p.saved_used = 0;
     }
 
-  if (saved_used >= saved_length)
+  if (dtp->u.p.saved_used >= dtp->u.p.saved_length)
     {
-      saved_length = 2 * saved_length;
-      new = get_mem (2 * saved_length);
+      dtp->u.p.saved_length = 2 * dtp->u.p.saved_length;
+      new = get_mem (2 * dtp->u.p.saved_length);
 
-      memset (new,0,2 * saved_length);
+      memset (new, 0, 2 * dtp->u.p.saved_length);
 
-      memcpy (new, saved_string, saved_used);
-      if (saved_string != scratch)
-       free_mem (saved_string);
+      memcpy (new, dtp->u.p.saved_string, dtp->u.p.saved_used);
+      if (dtp->u.p.saved_string != dtp->u.p.scratch)
+       free_mem (dtp->u.p.saved_string);
 
-      saved_string = new;
+      dtp->u.p.saved_string = new;
     }
 
-  saved_string[saved_used++] = c;
+  dtp->u.p.saved_string[dtp->u.p.saved_used++] = c;
 }
 
 
 /* Free the input buffer if necessary.  */
 
 static void
-free_saved (void)
+free_saved (st_parameter_dt *dtp)
 {
-  if (saved_string == NULL)
+  if (dtp->u.p.saved_string == NULL)
     return;
 
-  if (saved_string != scratch)
-    free_mem (saved_string);
+  if (dtp->u.p.saved_string != dtp->u.p.scratch)
+    free_mem (dtp->u.p.saved_string);
 
-  saved_string = NULL;
-  saved_used = 0;
+  dtp->u.p.saved_string = NULL;
+  dtp->u.p.saved_used = 0;
 }
 
 
 static char
-next_char (void)
+next_char (st_parameter_dt *dtp)
 {
   int length;
   char c, *p;
 
-  if (last_char != '\0')
+  if (dtp->u.p.last_char != '\0')
     {
-      at_eol = 0;
-      c = last_char;
-      last_char = '\0';
+      dtp->u.p.at_eol = 0;
+      c = dtp->u.p.last_char;
+      dtp->u.p.last_char = '\0';
       goto done;
     }
 
   length = 1;
 
-  p = salloc_r (current_unit->s, &length);
+  p = salloc_r (dtp->u.p.current_unit->s, &length);
   if (p == NULL)
     {
-      generate_error (ERROR_OS, NULL);
+      generate_error (&dtp->common, ERROR_OS, NULL);
       return '\0';
     }
 
@@ -166,16 +145,16 @@ next_char (void)
       /* For internal files return a newline instead of signalling EOF.  */
       /* ??? This isn't quite right, but we don't handle internal files
         with multiple records.  */
-      if (is_internal_unit ())
+      if (is_internal_unit (dtp))
        c = '\n';
       else
-       longjmp (g.eof_jump, 1);
+       longjmp (*dtp->u.p.eof_jump, 1);
     }
   else
     c = *p;
 
 done:
-  at_eol = (c == '\n' || c == '\r');
+  dtp->u.p.at_eol = (c == '\n' || c == '\r');
   return c;
 }
 
@@ -183,9 +162,9 @@ done:
 /* Push a character back onto the input.  */
 
 static void
-unget_char (char c)
+unget_char (st_parameter_dt *dtp, char c)
 {
-  last_char = c;
+  dtp->u.p.last_char = c;
 }
 
 
@@ -193,17 +172,17 @@ unget_char (char c)
    terminated the eating and also places it back on the input.  */
 
 static char
-eat_spaces (void)
+eat_spaces (st_parameter_dt *dtp)
 {
   char c;
 
   do
     {
-      c = next_char ();
+      c = next_char (dtp);
     }
   while (c == ' ' || c == '\t');
 
-  unget_char (c);
+  unget_char (dtp, c);
   return c;
 }
 
@@ -220,35 +199,35 @@ eat_spaces (void)
    of the separator.  */
 
 static void
-eat_separator (void)
+eat_separator (st_parameter_dt *dtp)
 {
   char c;
 
-  eat_spaces ();
-  comma_flag = 0;
+  eat_spaces (dtp);
+  dtp->u.p.comma_flag = 0;
 
-  c = next_char ();
+  c = next_char (dtp);
   switch (c)
     {
     case ',':
-      comma_flag = 1;
-      eat_spaces ();
+      dtp->u.p.comma_flag = 1;
+      eat_spaces (dtp);
       break;
 
     case '/':
-      input_complete = 1;
+      dtp->u.p.input_complete = 1;
       break;
 
     case '\n':
     case '\r':
-      at_eol = 1;
+      dtp->u.p.at_eol = 1;
       break;
 
     case '!':
-      if (namelist_mode)
+      if (dtp->u.p.namelist_mode)
        {                       /* Eat a namelist comment.  */
          do
-           c = next_char ();
+           c = next_char (dtp);
          while (c != '\n');
 
          break;
@@ -257,7 +236,7 @@ eat_separator (void)
       /* Fall Through...  */
 
     default:
-      unget_char (c);
+      unget_char (dtp, c);
       break;
     }
 }
@@ -268,22 +247,22 @@ eat_separator (void)
    we started on the previous line.  */
 
 static void
-finish_separator (void)
+finish_separator (st_parameter_dt *dtp)
 {
   char c;
 
  restart:
-  eat_spaces ();
+  eat_spaces (dtp);
 
-  c = next_char ();
+  c = next_char (dtp);
   switch (c)
     {
     case ',':
-      if (comma_flag)
-       unget_char (c);
+      if (dtp->u.p.comma_flag)
+       unget_char (dtp, c);
       else
        {
-         c = eat_spaces ();
+         c = eat_spaces (dtp);
          if (c == '\n')
            goto restart;
        }
@@ -291,8 +270,8 @@ finish_separator (void)
       break;
 
     case '/':
-      input_complete = 1;
-      if (!namelist_mode) next_record (0);
+      dtp->u.p.input_complete = 1;
+      if (!dtp->u.p.namelist_mode) next_record (dtp, 0);
       break;
 
     case '\n':
@@ -300,32 +279,32 @@ finish_separator (void)
       goto restart;
 
     case '!':
-      if (namelist_mode)
+      if (dtp->u.p.namelist_mode)
        {
          do
-           c = next_char ();
+           c = next_char (dtp);
          while (c != '\n');
 
          goto restart;
        }
 
     default:
-      unget_char (c);
+      unget_char (dtp, c);
       break;
     }
 }
 
 /* This function is needed to catch bad conversions so that namelist can
-   attempt to see if saved_string contains a new object name rather than
-   a bad value.  */
+   attempt to see if dtp->u.p.saved_string contains a new object name rather
+   than a bad value.  */
 
 static int
-nml_bad_return (char c)
+nml_bad_return (st_parameter_dt *dtp, char c)
 {
-  if (namelist_mode)
+  if (dtp->u.p.namelist_mode)
     {
-      nml_read_error = 1;
-      unget_char(c);
+      dtp->u.p.nml_read_error = 1;
+      unget_char (dtp, c);
       return 1;
     }
   return 0;
@@ -333,16 +312,16 @@ nml_bad_return (char c)
 
 /* Convert an unsigned string to an integer.  The length value is -1
    if we are working on a repeat count.  Returns nonzero if we have a
-   range problem.  As a side effect, frees the saved_string.  */
+   range problem.  As a side effect, frees the dtp->u.p.saved_string.  */
 
 static int
-convert_integer (int length, int negative)
+convert_integer (st_parameter_dt *dtp, int length, int negative)
 {
   char c, *buffer, message[100];
   int m;
   GFC_INTEGER_LARGEST v, max, max10;
 
-  buffer = saved_string;
+  buffer = dtp->u.p.saved_string;
   v = 0;
 
   max = (length == -1) ? MAX_REPEAT : max_value (length, 1);
@@ -370,35 +349,35 @@ convert_integer (int length, int negative)
     {
       if (negative)
        v = -v;
-      set_integer (value, v, length);
+      set_integer (dtp->u.p.value, v, length);
     }
   else
     {
-      repeat_count = v;
+      dtp->u.p.repeat_count = v;
 
-      if (repeat_count == 0)
+      if (dtp->u.p.repeat_count == 0)
        {
          st_sprintf (message, "Zero repeat count in item %d of list input",
-                     g.item_count);
+                     dtp->u.p.item_count);
 
-         generate_error (ERROR_READ_VALUE, message);
+         generate_error (&dtp->common, ERROR_READ_VALUE, message);
          m = 1;
        }
     }
 
-  free_saved ();
+  free_saved (dtp);
   return m;
 
  overflow:
   if (length == -1)
     st_sprintf (message, "Repeat count overflow in item %d of list input",
-               g.item_count);
+               dtp->u.p.item_count);
   else
     st_sprintf (message, "Integer overflow while reading item %d",
-               g.item_count);
+               dtp->u.p.item_count);
 
-  free_saved ();
-  generate_error (ERROR_READ_VALUE, message);
+  free_saved (dtp);
+  generate_error (&dtp->common, ERROR_READ_VALUE, message);
 
   return 1;
 }
@@ -409,12 +388,12 @@ convert_integer (int length, int negative)
    should continue on.  */
 
 static int
-parse_repeat (void)
+parse_repeat (st_parameter_dt *dtp)
 {
   char c, message[100];
   int repeat;
 
-  c = next_char ();
+  c = next_char (dtp);
   switch (c)
     {
     CASE_DIGITS:
@@ -422,18 +401,18 @@ parse_repeat (void)
       break;
 
     CASE_SEPARATORS:
-      unget_char (c);
-      eat_separator ();
+      unget_char (dtp, c);
+      eat_separator (dtp);
       return 1;
 
     default:
-      unget_char (c);
+      unget_char (dtp, c);
       return 0;
     }
 
   for (;;)
     {
-      c = next_char ();
+      c = next_char (dtp);
       switch (c)
        {
        CASE_DIGITS:
@@ -443,9 +422,9 @@ parse_repeat (void)
            {
              st_sprintf (message,
                          "Repeat count overflow in item %d of list input",
-                         g.item_count);
+                         dtp->u.p.item_count);
 
-             generate_error (ERROR_READ_VALUE, message);
+             generate_error (&dtp->common, ERROR_READ_VALUE, message);
              return 1;
            }
 
@@ -456,9 +435,9 @@ parse_repeat (void)
            {
              st_sprintf (message,
                          "Zero repeat count in item %d of list input",
-                         g.item_count);
+                         dtp->u.p.item_count);
 
-             generate_error (ERROR_READ_VALUE, message);
+             generate_error (&dtp->common, ERROR_READ_VALUE, message);
              return 1;
            }
 
@@ -470,14 +449,14 @@ parse_repeat (void)
     }
 
  done:
-  repeat_count = repeat;
+  dtp->u.p.repeat_count = repeat;
   return 0;
 
  bad_repeat:
   st_sprintf (message, "Bad repeat count in item %d of list input",
-             g.item_count);
+             dtp->u.p.item_count);
 
-  generate_error (ERROR_READ_VALUE, message);
+  generate_error (&dtp->common, ERROR_READ_VALUE, message);
   return 1;
 }
 
@@ -485,15 +464,15 @@ parse_repeat (void)
 /* Read a logical character on the input.  */
 
 static void
-read_logical (int length)
+read_logical (st_parameter_dt *dtp, int length)
 {
   char c, message[100];
   int v;
 
-  if (parse_repeat ())
+  if (parse_repeat (dtp))
     return;
 
-  c = next_char ();
+  c = next_char (dtp);
   switch (c)
     {
     case 't':
@@ -506,7 +485,7 @@ read_logical (int length)
       break;
 
     case '.':
-      c = next_char ();
+      c = next_char (dtp);
       switch (c)
        {
        case 't':
@@ -524,40 +503,40 @@ read_logical (int length)
       break;
 
     CASE_SEPARATORS:
-      unget_char (c);
-      eat_separator ();
+      unget_char (dtp, c);
+      eat_separator (dtp);
       return;                  /* Null value.  */
 
     default:
       goto bad_logical;
     }
 
-  saved_type = BT_LOGICAL;
-  saved_length = length;
+  dtp->u.p.saved_type = BT_LOGICAL;
+  dtp->u.p.saved_length = length;
 
   /* Eat trailing garbage.  */
   do
     {
-      c = next_char ();
+      c = next_char (dtp);
     }
   while (!is_separator (c));
 
-  unget_char (c);
-  eat_separator ();
-  free_saved ();
-  set_integer ((int *) value, v, length);
+  unget_char (dtp, c);
+  eat_separator (dtp);
+  free_saved (dtp);
+  set_integer ((int *) dtp->u.p.value, v, length);
 
   return;
 
  bad_logical:
 
-  if (nml_bad_return (c))
+  if (nml_bad_return (dtp, c))
     return;
 
   st_sprintf (message, "Bad logical value while reading item %d",
-             g.item_count);
+             dtp->u.p.item_count);
 
-  generate_error (ERROR_READ_VALUE, message);
+  generate_error (&dtp->common, ERROR_READ_VALUE, message);
 }
 
 
@@ -567,14 +546,14 @@ read_logical (int length)
    used for repeat counts.  */
 
 static void
-read_integer (int length)
+read_integer (st_parameter_dt *dtp, int length)
 {
   char c, message[100];
   int negative;
 
   negative = 0;
 
-  c = next_char ();
+  c = next_char (dtp);
   switch (c)
     {
     case '-':
@@ -582,16 +561,16 @@ read_integer (int length)
       /* Fall through...  */
 
     case '+':
-      c = next_char ();
+      c = next_char (dtp);
       goto get_integer;
 
     CASE_SEPARATORS:           /* Single null.  */
-      unget_char (c);
-      eat_separator ();
+      unget_char (dtp, c);
+      eat_separator (dtp);
       return;
 
     CASE_DIGITS:
-      push_char (c);
+      push_char (dtp, c);
       break;
 
     default:
@@ -602,15 +581,15 @@ read_integer (int length)
 
   for (;;)
     {
-      c = next_char ();
+      c = next_char (dtp);
       switch (c)
        {
        CASE_DIGITS:
-         push_char (c);
+         push_char (dtp, c);
          break;
 
        case '*':
-         push_char ('\0');
+         push_char (dtp, '\0');
          goto repeat;
 
        CASE_SEPARATORS:        /* Not a repeat count.  */
@@ -622,20 +601,20 @@ read_integer (int length)
     }
 
  repeat:
-  if (convert_integer (-1, 0))
+  if (convert_integer (dtp, -1, 0))
     return;
 
   /* Get the real integer.  */
 
-  c = next_char ();
+  c = next_char (dtp);
   switch (c)
     {
     CASE_DIGITS:
       break;
 
     CASE_SEPARATORS:
-      unget_char (c);
-      eat_separator ();
+      unget_char (dtp, c);
+      eat_separator (dtp);
       return;
 
     case '-':
@@ -643,22 +622,22 @@ read_integer (int length)
       /* Fall through...  */
 
     case '+':
-      c = next_char ();
+      c = next_char (dtp);
       break;
     }
 
  get_integer:
   if (!isdigit (c))
     goto bad_integer;
-  push_char (c);
+  push_char (dtp, c);
 
   for (;;)
     {
-      c = next_char ();
+      c = next_char (dtp);
       switch (c)
        {
        CASE_DIGITS:
-         push_char (c);
+         push_char (dtp, c);
          break;
 
        CASE_SEPARATORS:
@@ -671,51 +650,52 @@ read_integer (int length)
 
  bad_integer:
 
-  if (nml_bad_return (c))
+  if (nml_bad_return (dtp, c))
     return;
 
-  free_saved ();
+  free_saved (dtp);
 
-  st_sprintf (message, "Bad integer for item %d in list input", g.item_count);
-  generate_error (ERROR_READ_VALUE, message);
+  st_sprintf (message, "Bad integer for item %d in list input",
+             dtp->u.p.item_count);
+  generate_error (&dtp->common, ERROR_READ_VALUE, message);
 
   return;
 
  done:
-  unget_char (c);
-  eat_separator ();
+  unget_char (dtp, c);
+  eat_separator (dtp);
 
-  push_char ('\0');
-  if (convert_integer (length, negative))
+  push_char (dtp, '\0');
+  if (convert_integer (dtp, length, negative))
     {
-       free_saved ();
+       free_saved (dtp);
        return;
     }
 
-  free_saved ();
-  saved_type = BT_INTEGER;
+  free_saved (dtp);
+  dtp->u.p.saved_type = BT_INTEGER;
 }
 
 
 /* Read a character variable.  */
 
 static void
-read_character (int length __attribute__ ((unused)))
+read_character (st_parameter_dt *dtp, int length __attribute__ ((unused)))
 {
   char c, quote, message[100];
 
   quote = ' ';                 /* Space means no quote character.  */
 
-  c = next_char ();
+  c = next_char (dtp);
   switch (c)
     {
     CASE_DIGITS:
-      push_char (c);
+      push_char (dtp, c);
       break;
 
     CASE_SEPARATORS:
-      unget_char (c);          /* NULL value.  */
-      eat_separator ();
+      unget_char (dtp, c);             /* NULL value.  */
+      eat_separator (dtp);
       return;
 
     case '"':
@@ -724,7 +704,7 @@ read_character (int length __attribute__ ((unused)))
       goto get_string;
 
     default:
-      push_char (c);
+      push_char (dtp, c);
       goto get_string;
     }
 
@@ -732,39 +712,39 @@ read_character (int length __attribute__ ((unused)))
 
   for (;;)
     {
-      c = next_char ();
+      c = next_char (dtp);
       switch (c)
        {
        CASE_DIGITS:
-         push_char (c);
+         push_char (dtp, c);
          break;
 
        CASE_SEPARATORS:
-         unget_char (c);
+         unget_char (dtp, c);
          goto done;            /* String was only digits!  */
 
        case '*':
-         push_char ('\0');
+         push_char (dtp, '\0');
          goto got_repeat;
 
        default:
-         push_char (c);
+         push_char (dtp, c);
          goto get_string;      /* Not a repeat count after all.  */
        }
     }
 
  got_repeat:
-  if (convert_integer (-1, 0))
+  if (convert_integer (dtp, -1, 0))
     return;
 
   /* Now get the real string.  */
 
-  c = next_char ();
+  c = next_char (dtp);
   switch (c)
     {
     CASE_SEPARATORS:
-      unget_char (c);          /* Repeated NULL values.  */
-      eat_separator ();
+      unget_char (dtp, c);             /* Repeated NULL values.  */
+      eat_separator (dtp);
       return;
 
     case '"':
@@ -773,50 +753,50 @@ read_character (int length __attribute__ ((unused)))
       break;
 
     default:
-      push_char (c);
+      push_char (dtp, c);
       break;
     }
 
  get_string:
   for (;;)
     {
-      c = next_char ();
+      c = next_char (dtp);
       switch (c)
        {
        case '"':
        case '\'':
          if (c != quote)
            {
-             push_char (c);
+             push_char (dtp, c);
              break;
            }
 
          /* See if we have a doubled quote character or the end of
             the string.  */
 
-         c = next_char ();
+         c = next_char (dtp);
          if (c == quote)
            {
-             push_char (quote);
+             push_char (dtp, quote);
              break;
            }
 
-         unget_char (c);
+         unget_char (dtp, c);
          goto done;
 
        CASE_SEPARATORS:
          if (quote == ' ')
            {
-             unget_char (c);
+             unget_char (dtp, c);
              goto done;
            }
 
          if (c != '\n')
-           push_char (c);
+           push_char (dtp, c);
          break;
 
        default:
-         push_char (c);
+         push_char (dtp, c);
          break;
        }
     }
@@ -824,18 +804,19 @@ read_character (int length __attribute__ ((unused)))
   /* At this point, we have to have a separator, or else the string is
      invalid.  */
  done:
-  c = next_char ();
+  c = next_char (dtp);
   if (is_separator (c))
     {
-      unget_char (c);
-      eat_separator ();
-      saved_type = BT_CHARACTER;
+      unget_char (dtp, c);
+      eat_separator (dtp);
+      dtp->u.p.saved_type = BT_CHARACTER;
     }
   else
     {
-      free_saved ();
-      st_sprintf (message, "Invalid string input in item %d", g.item_count);
-      generate_error (ERROR_READ_VALUE, message);
+      free_saved (dtp);
+      st_sprintf (message, "Invalid string input in item %d",
+                 dtp->u.p.item_count);
+      generate_error (&dtp->common, ERROR_READ_VALUE, message);
     }
 }
 
@@ -844,32 +825,32 @@ read_character (int length __attribute__ ((unused)))
    are sure is already there.  This is a straight real number parser.  */
 
 static int
-parse_real (void *buffer, int length)
+parse_real (st_parameter_dt *dtp, void *buffer, int length)
 {
   char c, message[100];
   int m, seen_dp;
 
-  c = next_char ();
+  c = next_char (dtp);
   if (c == '-' || c == '+')
     {
-      push_char (c);
-      c = next_char ();
+      push_char (dtp, c);
+      c = next_char (dtp);
     }
 
   if (!isdigit (c) && c != '.')
     goto bad;
 
-  push_char (c);
+  push_char (dtp, c);
 
   seen_dp = (c == '.') ? 1 : 0;
 
   for (;;)
     {
-      c = next_char ();
+      c = next_char (dtp);
       switch (c)
        {
        CASE_DIGITS:
-         push_char (c);
+         push_char (dtp, c);
          break;
 
        case '.':
@@ -877,25 +858,25 @@ parse_real (void *buffer, int length)
            goto bad;
 
          seen_dp = 1;
-         push_char (c);
+         push_char (dtp, c);
          break;
 
        case 'e':
        case 'E':
        case 'd':
        case 'D':
-         push_char ('e');
+         push_char (dtp, 'e');
          goto exp1;
 
        case '-':
        case '+':
-         push_char ('e');
-         push_char (c);
-         c = next_char ();
+         push_char (dtp, 'e');
+         push_char (dtp, c);
+         c = next_char (dtp);
          goto exp2;
 
        CASE_SEPARATORS:
-         unget_char (c);
+         unget_char (dtp, c);
          goto done;
 
        default:
@@ -904,31 +885,31 @@ parse_real (void *buffer, int length)
     }
 
  exp1:
-  c = next_char ();
+  c = next_char (dtp);
   if (c != '-' && c != '+')
-    push_char ('+');
+    push_char (dtp, '+');
   else
     {
-      push_char (c);
-      c = next_char ();
+      push_char (dtp, c);
+      c = next_char (dtp);
     }
 
  exp2:
   if (!isdigit (c))
     goto bad;
-  push_char (c);
+  push_char (dtp, c);
 
   for (;;)
     {
-      c = next_char ();
+      c = next_char (dtp);
       switch (c)
        {
        CASE_DIGITS:
-         push_char (c);
+         push_char (dtp, c);
          break;
 
        CASE_SEPARATORS:
-         unget_char (c);
+         unget_char (dtp, c);
          goto done;
 
        default:
@@ -937,18 +918,19 @@ parse_real (void *buffer, int length)
     }
 
  done:
-  unget_char (c);
-  push_char ('\0');
+  unget_char (dtp, c);
+  push_char (dtp, '\0');
 
-  m = convert_real (buffer, saved_string, length);
-  free_saved ();
+  m = convert_real (dtp, buffer, dtp->u.p.saved_string, length);
+  free_saved (dtp);
 
   return m;
 
  bad:
-  free_saved ();
-  st_sprintf (message, "Bad floating point number for item %d", g.item_count);
-  generate_error (ERROR_READ_VALUE, message);
+  free_saved (dtp);
+  st_sprintf (message, "Bad floating point number for item %d",
+             dtp->u.p.item_count);
+  generate_error (&dtp->common, ERROR_READ_VALUE, message);
 
   return 1;
 }
@@ -958,101 +940,101 @@ parse_real (void *buffer, int length)
    what it is right away.  */
 
 static void
-read_complex (int kind, size_t size)
+read_complex (st_parameter_dt *dtp, int kind, size_t size)
 {
   char message[100];
   char c;
 
-  if (parse_repeat ())
+  if (parse_repeat (dtp))
     return;
 
-  c = next_char ();
+  c = next_char (dtp);
   switch (c)
     {
     case '(':
       break;
 
     CASE_SEPARATORS:
-      unget_char (c);
-      eat_separator ();
+      unget_char (dtp, c);
+      eat_separator (dtp);
       return;
 
     default:
       goto bad_complex;
     }
 
-  eat_spaces ();
-  if (parse_real (value, kind))
+  eat_spaces (dtp);
+  if (parse_real (dtp, dtp->u.p.value, kind))
     return;
 
 eol_1:
-  eat_spaces ();
-  c = next_char ();
+  eat_spaces (dtp);
+  c = next_char (dtp);
   if (c == '\n' || c== '\r')
     goto eol_1;
   else
-    unget_char (c);
+    unget_char (dtp, c);
 
-  if (next_char () != ',')
+  if (next_char (dtp) != ',')
     goto bad_complex;
 
 eol_2:
-  eat_spaces ();
-  c = next_char ();
+  eat_spaces (dtp);
+  c = next_char (dtp);
   if (c == '\n' || c== '\r')
     goto eol_2;
   else
-    unget_char (c);
+    unget_char (dtp, c);
 
-  if (parse_real (value + size / 2, kind))
+  if (parse_real (dtp, dtp->u.p.value + size / 2, kind))
     return;
 
-  eat_spaces ();
-  if (next_char () != ')')
+  eat_spaces (dtp);
+  if (next_char (dtp) != ')')
     goto bad_complex;
 
-  c = next_char ();
+  c = next_char (dtp);
   if (!is_separator (c))
     goto bad_complex;
 
-  unget_char (c);
-  eat_separator ();
+  unget_char (dtp, c);
+  eat_separator (dtp);
 
-  free_saved ();
-  saved_type = BT_COMPLEX;
+  free_saved (dtp);
+  dtp->u.p.saved_type = BT_COMPLEX;
   return;
 
  bad_complex:
 
-  if (nml_bad_return (c))
+  if (nml_bad_return (dtp, c))
     return;
 
   st_sprintf (message, "Bad complex value in item %d of list input",
-             g.item_count);
+             dtp->u.p.item_count);
 
-  generate_error (ERROR_READ_VALUE, message);
+  generate_error (&dtp->common, ERROR_READ_VALUE, message);
 }
 
 
 /* Parse a real number with a possible repeat count.  */
 
 static void
-read_real (int length)
+read_real (st_parameter_dt *dtp, int length)
 {
   char c, message[100];
   int seen_dp;
 
   seen_dp = 0;
 
-  c = next_char ();
+  c = next_char (dtp);
   switch (c)
     {
     CASE_DIGITS:
-      push_char (c);
+      push_char (dtp, c);
       break;
 
     case '.':
-      push_char (c);
+      push_char (dtp, c);
       seen_dp = 1;
       break;
 
@@ -1061,8 +1043,8 @@ read_real (int length)
       goto got_sign;
 
     CASE_SEPARATORS:
-      unget_char (c);          /* Single null.  */
-      eat_separator ();
+      unget_char (dtp, c);             /* Single null.  */
+      eat_separator (dtp);
       return;
 
     default:
@@ -1073,11 +1055,11 @@ read_real (int length)
 
   for (;;)
     {
-      c = next_char ();
+      c = next_char (dtp);
       switch (c)
        {
        CASE_DIGITS:
-         push_char (c);
+         push_char (dtp, c);
          break;
 
        case '.':
@@ -1085,7 +1067,7 @@ read_real (int length)
             goto bad_real;
 
          seen_dp = 1;
-         push_char (c);
+         push_char (dtp, c);
          goto real_loop;
 
        case 'E':
@@ -1096,18 +1078,18 @@ read_real (int length)
 
        case '+':
        case '-':
-         push_char ('e');
-         push_char (c);
-         c = next_char ();
+         push_char (dtp, 'e');
+         push_char (dtp, c);
+         c = next_char (dtp);
          goto exp2;
 
        case '*':
-         push_char ('\0');
+         push_char (dtp, '\0');
          goto got_repeat;
 
        CASE_SEPARATORS:
           if (c != '\n' &&  c != ',' && c != '\r')
-            unget_char (c);
+           unget_char (dtp, c);
          goto done;
 
        default:
@@ -1116,26 +1098,26 @@ read_real (int length)
     }
 
  got_repeat:
-  if (convert_integer (-1, 0))
+  if (convert_integer (dtp, -1, 0))
     return;
 
   /* Now get the number itself.  */
 
-  c = next_char ();
+  c = next_char (dtp);
   if (is_separator (c))
     {                          /* Repeated null value.  */
-      unget_char (c);
-      eat_separator ();
+      unget_char (dtp, c);
+      eat_separator (dtp);
       return;
     }
 
   if (c != '-' && c != '+')
-    push_char ('+');
+    push_char (dtp, '+');
   else
     {
     got_sign:
-      push_char (c);
-      c = next_char ();
+      push_char (dtp, c);
+      c = next_char (dtp);
     }
 
   if (!isdigit (c) && c != '.')
@@ -1149,16 +1131,16 @@ read_real (int length)
         seen_dp = 1;
     }
 
-  push_char (c);
+  push_char (dtp, c);
 
  real_loop:
   for (;;)
     {
-      c = next_char ();
+      c = next_char (dtp);
       switch (c)
        {
        CASE_DIGITS:
-         push_char (c);
+         push_char (dtp, c);
          break;
 
        CASE_SEPARATORS:
@@ -1169,7 +1151,7 @@ read_real (int length)
            goto bad_real;
 
          seen_dp = 1;
-         push_char (c);
+         push_char (dtp, c);
          break;
 
        case 'E':
@@ -1180,9 +1162,9 @@ read_real (int length)
 
        case '+':
        case '-':
-         push_char ('e');
-         push_char (c);
-         c = next_char ();
+         push_char (dtp, 'e');
+         push_char (dtp, c);
+         c = next_char (dtp);
          goto exp2;
 
        default:
@@ -1191,30 +1173,30 @@ read_real (int length)
     }
 
  exp1:
-  push_char ('e');
+  push_char (dtp, 'e');
 
-  c = next_char ();
+  c = next_char (dtp);
   if (c != '+' && c != '-')
-    push_char ('+');
+    push_char (dtp, '+');
   else
     {
-      push_char (c);
-      c = next_char ();
+      push_char (dtp, c);
+      c = next_char (dtp);
     }
 
  exp2:
   if (!isdigit (c))
     goto bad_real;
-  push_char (c);
+  push_char (dtp, c);
 
   for (;;)
     {
-      c = next_char ();
+      c = next_char (dtp);
 
       switch (c)
        {
        CASE_DIGITS:
-         push_char (c);
+         push_char (dtp, c);
          break;
 
        CASE_SEPARATORS:
@@ -1226,25 +1208,25 @@ read_real (int length)
     }
 
  done:
-  unget_char (c);
-  eat_separator ();
-  push_char ('\0');
-  if (convert_real (value, saved_string, length))
+  unget_char (dtp, c);
+  eat_separator (dtp);
+  push_char (dtp, '\0');
+  if (convert_real (dtp, dtp->u.p.value, dtp->u.p.saved_string, length))
     return;
 
-  free_saved ();
-  saved_type = BT_REAL;
+  free_saved (dtp);
+  dtp->u.p.saved_type = BT_REAL;
   return;
 
  bad_real:
 
-  if (nml_bad_return (c))
+  if (nml_bad_return (dtp, c))
     return;
 
   st_sprintf (message, "Bad real number in item %d of list input",
-             g.item_count);
+             dtp->u.p.item_count);
 
-  generate_error (ERROR_READ_VALUE, message);
+  generate_error (&dtp->common, ERROR_READ_VALUE, message);
 }
 
 
@@ -1252,28 +1234,30 @@ read_real (int length)
    compatible.  Returns nonzero if incompatible.  */
 
 static int
-check_type (bt type, int len)
+check_type (st_parameter_dt *dtp, bt type, int len)
 {
   char message[100];
 
-  if (saved_type != BT_NULL && saved_type != type)
+  if (dtp->u.p.saved_type != BT_NULL && dtp->u.p.saved_type != type)
     {
       st_sprintf (message, "Read type %s where %s was expected for item %d",
-                 type_name (saved_type), type_name (type), g.item_count);
+                 type_name (dtp->u.p.saved_type), type_name (type),
+                 dtp->u.p.item_count);
 
-      generate_error (ERROR_READ_VALUE, message);
+      generate_error (&dtp->common, ERROR_READ_VALUE, message);
       return 1;
     }
 
-  if (saved_type == BT_NULL || saved_type == BT_CHARACTER)
+  if (dtp->u.p.saved_type == BT_NULL || dtp->u.p.saved_type == BT_CHARACTER)
     return 0;
 
-  if (saved_length != len)
+  if (dtp->u.p.saved_length != len)
     {
       st_sprintf (message,
                  "Read kind %d %s where kind %d is required for item %d",
-                 saved_length, type_name (saved_type), len, g.item_count);
-      generate_error (ERROR_READ_VALUE, message);
+                 dtp->u.p.saved_length, type_name (dtp->u.p.saved_type), len,
+                 dtp->u.p.item_count);
+      generate_error (&dtp->common, ERROR_READ_VALUE, message);
       return 1;
     }
 
@@ -1283,110 +1267,114 @@ check_type (bt type, int len)
 
 /* Top level data transfer subroutine for list reads.  Because we have
    to deal with repeat counts, the data item is always saved after
-   reading, usually in the value[] array.  If a repeat count is
+   reading, usually in the dtp->u.p.value[] array.  If a repeat count is
    greater than one, we copy the data item multiple times.  */
 
 static void
-list_formatted_read_scalar (bt type, void *p, int kind, size_t size)
+list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
+                           size_t size)
 {
   char c;
   int m;
+  jmp_buf eof_jump;
 
-  namelist_mode = 0;
+  dtp->u.p.namelist_mode = 0;
 
-  if (setjmp (g.eof_jump))
+  dtp->u.p.eof_jump = &eof_jump;
+  if (setjmp (eof_jump))
     {
-      generate_error (ERROR_END, NULL);
-      return;
+      generate_error (&dtp->common, ERROR_END, NULL);
+      goto cleanup;
     }
 
-  if (g.first_item)
+  if (dtp->u.p.first_item)
     {
-      g.first_item = 0;
-      input_complete = 0;
-      repeat_count = 1;
-      at_eol = 0;
+      dtp->u.p.first_item = 0;
+      dtp->u.p.input_complete = 0;
+      dtp->u.p.repeat_count = 1;
+      dtp->u.p.at_eol = 0;
 
-      c = eat_spaces ();
+      c = eat_spaces (dtp);
       if (is_separator (c))
        {                       /* Found a null value.  */
-         eat_separator ();
-         repeat_count = 0;
-         if (at_eol)
-            finish_separator ();
+         eat_separator (dtp);
+         dtp->u.p.repeat_count = 0;
+         if (dtp->u.p.at_eol)
+           finish_separator (dtp);
           else
-            return;
+           goto cleanup;
        }
 
     }
   else
     {
-      if (input_complete)
-       return;
+      if (dtp->u.p.input_complete)
+       goto cleanup;
 
-      if (repeat_count > 0)
+      if (dtp->u.p.repeat_count > 0)
        {
-         if (check_type (type, kind))
+         if (check_type (dtp, type, kind))
            return;
          goto set_value;
        }
 
-      if (at_eol)
-        finish_separator ();
+      if (dtp->u.p.at_eol)
+       finish_separator (dtp);
       else
         {
-          eat_spaces ();
+         eat_spaces (dtp);
           /* trailing spaces prior to end of line */
-          if (at_eol)
-            finish_separator ();
+         if (dtp->u.p.at_eol)
+           finish_separator (dtp);
         }
 
-      saved_type = BT_NULL;
-      repeat_count = 1;
+      dtp->u.p.saved_type = BT_NULL;
+      dtp->u.p.repeat_count = 1;
     }
 
   switch (type)
     {
     case BT_INTEGER:
-      read_integer (kind);
+      read_integer (dtp, kind);
       break;
     case BT_LOGICAL:
-      read_logical (kind);
+      read_logical (dtp, kind);
       break;
     case BT_CHARACTER:
-      read_character (kind);
+      read_character (dtp, kind);
       break;
     case BT_REAL:
-      read_real (kind);
+      read_real (dtp, kind);
       break;
     case BT_COMPLEX:
-      read_complex (kind, size);
+      read_complex (dtp, kind, size);
       break;
     default:
-      internal_error ("Bad type for list read");
+      internal_error (&dtp->common, "Bad type for list read");
     }
 
-  if (saved_type != BT_CHARACTER && saved_type != BT_NULL)
-    saved_length = size;
+  if (dtp->u.p.saved_type != BT_CHARACTER && dtp->u.p.saved_type != BT_NULL)
+    dtp->u.p.saved_length = size;
 
-  if (ioparm.library_return != LIBRARY_OK)
-    return;
+  if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
+    goto cleanup;
 
  set_value:
-  switch (saved_type)
+  switch (dtp->u.p.saved_type)
     {
     case BT_COMPLEX:
     case BT_INTEGER:
     case BT_REAL:
     case BT_LOGICAL:
-      memcpy (p, value, size);
+      memcpy (p, dtp->u.p.value, size);
       break;
 
     case BT_CHARACTER:
-      if (saved_string)
+      if (dtp->u.p.saved_string)
        {
-          m = ((int) size < saved_used) ? (int) size : saved_used;
-          memcpy (p, saved_string, m);
+         m = ((int) size < dtp->u.p.saved_used)
+             ? (int) size : dtp->u.p.saved_used;
+         memcpy (p, dtp->u.p.saved_string, m);
        }
       else
        /* Just delimiters encountered, nothing to copy but SPACE.  */
@@ -1400,13 +1388,17 @@ list_formatted_read_scalar (bt type, void *p, int kind, size_t size)
       break;
     }
 
-  if (--repeat_count <= 0)
-    free_saved ();
+  if (--dtp->u.p.repeat_count <= 0)
+    free_saved (dtp);
+
+cleanup:
+  dtp->u.p.eof_jump = NULL;
 }
 
 
 void
-list_formatted_read  (bt type, void *p, int kind, size_t size, size_t nelems)
+list_formatted_read (st_parameter_dt *dtp, bt type, void *p, int kind,
+                    size_t size, size_t nelems)
 {
   size_t elem;
   char *tmp;
@@ -1416,83 +1408,61 @@ list_formatted_read  (bt type, void *p, int kind, size_t size, size_t nelems)
   /* Big loop over all the elements.  */
   for (elem = 0; elem < nelems; elem++)
     {
-      g.item_count++;
-      list_formatted_read_scalar (type, tmp + size*elem, kind, size);
+      dtp->u.p.item_count++;
+      list_formatted_read_scalar (dtp, type, tmp + size*elem, kind, size);
     }
 }
 
 
-void
-init_at_eol(void)
-{
-  at_eol = 0;
-}
-
 /* Finish a list read.  */
 
 void
-finish_list_read (void)
+finish_list_read (st_parameter_dt *dtp)
 {
   char c;
 
-  free_saved ();
+  free_saved (dtp);
 
-  if (at_eol)
+  if (dtp->u.p.at_eol)
     {
-      at_eol = 0;
+      dtp->u.p.at_eol = 0;
       return;
     }
 
   do
     {
-      c = next_char ();
+      c = next_char (dtp);
     }
   while (c != '\n');
 }
 
 /*                     NAMELIST INPUT
 
-void namelist_read (void)
+void namelist_read (st_parameter_dt *dtp)
 calls:
    static void nml_match_name (char *name, int len)
-   static int nml_query (void)
-   static int nml_get_obj_data (void)
+   static int nml_query (st_parameter_dt *dtp)
+   static int nml_get_obj_data (st_parameter_dt *dtp,
+                               namelist_info **prev_nl, char *)
 calls:
-      static void nml_untouch_nodes (void)
-      static namelist_info * find_nml_node (char * var_name)
+      static void nml_untouch_nodes (st_parameter_dt *dtp)
+      static namelist_info * find_nml_node (st_parameter_dt *dtp,
+                                           char * var_name)
       static int nml_parse_qualifier(descriptor_dimension * ad,
-                                    array_loop_spec * ls, int rank)
+                                    array_loop_spec * ls, int rank, char *)
       static void nml_touch_nodes (namelist_info * nl)
-      static int nml_read_obj (namelist_info * nl, index_type offset)
+      static int nml_read_obj (namelist_info *nl, index_type offset,
+                              namelist_info **prev_nl, char *,
+                              index_type clow, index_type chigh)
 calls:
       -itself-  */
 
-/* Carries error messages from the qualifier parser.  */
-static char parse_err_msg[30];
-
-/* Carries error messages for error returns.  */
-static char nml_err_msg[100];
-
-/* Pointer to the previously read object, in case attempt is made to read
-   new object name.  Should this fail, error message can give previous
-   name.  */
-
-static namelist_info * prev_nl;
-
-/* Lower index for substring qualifier.  */
-
-static index_type clow;
-
-/* Upper index for substring qualifier.  */
-
-static index_type chigh;
-
 /* Inputs a rank-dimensional qualifier, which can contain
    singlets, doublets, triplets or ':' with the standard meanings.  */
 
 static try
-nml_parse_qualifier(descriptor_dimension * ad,
-                   array_loop_spec * ls, int rank)
+nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad,
+                    array_loop_spec *ls, int rank, char *parse_err_msg)
 {
   int dim;
   int indx;
@@ -1502,7 +1472,7 @@ nml_parse_qualifier(descriptor_dimension * ad,
 
   /* The next character in the stream should be the '('.  */
 
-  c = next_char ();
+  c = next_char (dtp);
 
   /* Process the qualifier, by dimension and triplet.  */
 
@@ -1510,13 +1480,13 @@ nml_parse_qualifier(descriptor_dimension * ad,
     {
       for (indx=0; indx<3; indx++)
        {
-         free_saved ();
-         eat_spaces ();
+         free_saved (dtp);
+         eat_spaces (dtp);
          neg = 0;
 
          /*process a potential sign.  */
 
-         c = next_char ();
+         c = next_char (dtp);
          switch (c)
            {
            case '-':
@@ -1527,7 +1497,7 @@ nml_parse_qualifier(descriptor_dimension * ad,
              break;
 
            default:
-             unget_char (c);
+             unget_char (dtp, c);
              break;
            }
 
@@ -1535,7 +1505,7 @@ nml_parse_qualifier(descriptor_dimension * ad,
 
          for (;;)
            {
-             c = next_char ();
+             c = next_char (dtp);
 
              switch (c)
                {
@@ -1553,12 +1523,12 @@ nml_parse_qualifier(descriptor_dimension * ad,
                  break;
 
                CASE_DIGITS:
-                 push_char (c);
+                 push_char (dtp, c);
                  continue;
 
                case ' ': case '\t':
-                 eat_spaces ();
-                 c = next_char ();
+                 eat_spaces (dtp);
+                 c = next_char (dtp);
                  break;
 
                default:
@@ -1566,14 +1536,15 @@ nml_parse_qualifier(descriptor_dimension * ad,
                  goto err_ret;
                }
 
-             if (( c==',' || c==')') && indx==0 && saved_string == 0 )
+             if ((c == ',' || c == ')') && indx == 0
+                 && dtp->u.p.saved_string == 0)
                {
                  st_sprintf (parse_err_msg, "Null index field");
                  goto err_ret;
                }
 
-             if ( ( c==':' && indx==1 && saved_string == 0)
-               || (indx==2 && saved_string == 0))
+             if ((c == ':' && indx == 1 && dtp->u.p.saved_string == 0)
+               || (indx == 2 && dtp->u.p.saved_string == 0))
                {
                  st_sprintf(parse_err_msg, "Bad index triplet");
                  goto err_ret;
@@ -1581,8 +1552,8 @@ nml_parse_qualifier(descriptor_dimension * ad,
 
              /* If '( : ? )' or '( ? : )' break and flag read failure.  */
              null_flag = 0;
-             if ( (c==':'  && indx==0 && saved_string == 0)
-               || (indx==1 && saved_string == 0))
+             if ((c == ':' && indx == 0 && dtp->u.p.saved_string == 0)
+               || (indx==1 && dtp->u.p.saved_string == 0))
                {
                  null_flag = 1;
                  break;
@@ -1590,7 +1561,7 @@ nml_parse_qualifier(descriptor_dimension * ad,
 
              /* Now read the index.  */
 
-             if (convert_integer (sizeof(int),neg))
+             if (convert_integer (dtp, sizeof(int), neg))
                {
                  st_sprintf (parse_err_msg, "Bad integer in index");
                  goto err_ret;
@@ -1603,11 +1574,11 @@ nml_parse_qualifier(descriptor_dimension * ad,
          if (!null_flag)
            {
              if (indx == 0)
-               ls[dim].start = *(int *)value;
+               ls[dim].start = *(int *)dtp->u.p.value;
              if (indx == 1)
-               ls[dim].end   = *(int *)value;
+               ls[dim].end   = *(int *)dtp->u.p.value;
              if (indx == 2)
-               ls[dim].step  = *(int *)value;
+               ls[dim].step  = *(int *)dtp->u.p.value;
            }
 
          /*singlet or doublet indices  */
@@ -1616,8 +1587,8 @@ nml_parse_qualifier(descriptor_dimension * ad,
            {
              if (indx == 0)
                {
-                 ls[dim].start = *(int *)value;
-                 ls[dim].end = *(int *)value;
+                 ls[dim].start = *(int *)dtp->u.p.value;
+                 ls[dim].end = *(int *)dtp->u.p.value;
                }
              break;
            }
@@ -1645,7 +1616,7 @@ nml_parse_qualifier(descriptor_dimension * ad,
       ls[dim].idx = ls[dim].start;
 
     }
-  eat_spaces ();
+  eat_spaces (dtp);
   return SUCCESS;
 
 err_ret:
@@ -1654,12 +1625,12 @@ err_ret:
 }
 
 static namelist_info *
-find_nml_node (char * var_name)
+find_nml_node (st_parameter_dt *dtp, char * var_name)
 {
-  namelist_info * t = ionml;
+  namelist_info * t = dtp->u.p.ionml;
   while (t != NULL)
     {
-      if (strcmp (var_name,t->var_name) == 0)
+      if (strcmp (var_name, t->var_name) == 0)
        {
          t->touched = 1;
          return t;
@@ -1706,29 +1677,29 @@ nml_touch_nodes (namelist_info * nl)
    new object.  */
 
 static void
-nml_untouch_nodes (void)
+nml_untouch_nodes (st_parameter_dt *dtp)
 {
   namelist_info * t;
-  for (t = ionml; t; t = t->next)
+  for (t = dtp->u.p.ionml; t; t = t->next)
     t->touched = 0;
   return;
 }
 
-/* Attempts to input name to namelist name.  Returns nml_read_error = 1
-   on no match.  */
+/* Attempts to input name to namelist name.  Returns
+   dtp->u.p.nml_read_error = 1 on no match.  */
 
 static void
-nml_match_name (const char *name, index_type len)
+nml_match_name (st_parameter_dt *dtp, const char *name, index_type len)
 {
   index_type i;
   char c;
-  nml_read_error = 0;
+  dtp->u.p.nml_read_error = 0;
   for (i = 0; i < len; i++)
     {
-      c = next_char ();
+      c = next_char (dtp);
       if (tolower (c) != tolower (name[i]))
        {
-         nml_read_error = 1;
+         dtp->u.p.nml_read_error = 1;
          break;
        }
     }
@@ -1740,30 +1711,30 @@ nml_match_name (const char *name, index_type len)
    the names alone are printed.  */
 
 static void
-nml_query (char c)
+nml_query (st_parameter_dt *dtp, char c)
 {
   gfc_unit * temp_unit;
   namelist_info * nl;
   index_type len;
   char * p;
 
-  if (current_unit->unit_number != options.stdin_unit)
+  if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
     return;
 
   /* Store the current unit and transfer to stdout.  */
 
-  temp_unit = current_unit;
-  current_unit = find_unit (options.stdout_unit);
+  temp_unit = dtp->u.p.current_unit;
+  dtp->u.p.current_unit = find_unit (options.stdout_unit);
 
-  if (current_unit)
+  if (dtp->u.p.current_unit)
     {
-      g.mode =WRITING;
-      next_record (0);
+      dtp->u.p.mode = WRITING;
+      next_record (dtp, 0);
 
       /* Write the namelist in its entirety.  */
 
       if (c == '=')
-       namelist_write ();
+       namelist_write (dtp);
 
       /* Or write the list of names.  */
 
@@ -1772,20 +1743,20 @@ nml_query (char c)
 
          /* "&namelist_name\n"  */
 
-         len = ioparm.namelist_name_len;
-         p = write_block (len + 2);
+         len = dtp->namelist_name_len;
+         p = write_block (dtp, len + 2);
          if (!p)
            goto query_return;
          memcpy (p, "&", 1);
-         memcpy ((char*)(p + 1), ioparm.namelist_name, len);
+         memcpy ((char*)(p + 1), dtp->namelist_name, len);
          memcpy ((char*)(p + len + 1), "\n", 1);
-         for (nl =ionml; nl; nl = nl->next)
+         for (nl = dtp->u.p.ionml; nl; nl = nl->next)
            {
 
              /* " var_name\n"  */
 
              len = strlen (nl->var_name);
-             p = write_block (len + 2);
+             p = write_block (dtp, len + 2);
              if (!p)
                goto query_return;
              memcpy (p, " ", 1);
@@ -1795,7 +1766,7 @@ nml_query (char c)
 
          /* "&end\n"  */
 
-         p = write_block (5);
+         p = write_block (dtp, 5);
          if (!p)
            goto query_return;
          memcpy (p, "&end\n", 5);
@@ -1803,15 +1774,16 @@ nml_query (char c)
 
       /* Flush the stream to force immediate output.  */
 
-      flush (current_unit->s);
+      flush (dtp->u.p.current_unit->s);
+      unlock_unit (dtp->u.p.current_unit);
     }
 
 query_return:
 
   /* Restore the current unit.  */
 
-  current_unit = temp_unit;
-  g.mode = READING;
+  dtp->u.p.current_unit = temp_unit;
+  dtp->u.p.mode = READING;
   return;
 }
 
@@ -1826,7 +1798,9 @@ query_return:
    error.  */
 
 static try
-nml_read_obj (namelist_info * nl, index_type offset)
+nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset,
+             namelist_info **pprev_nl, char *nml_err_msg,
+             index_type clow, index_type chigh)
 {
 
   namelist_info * cmp;
@@ -1844,8 +1818,8 @@ nml_read_obj (namelist_info * nl, index_type offset)
   if (!nl->touched)
     return SUCCESS;
 
-  repeat_count = 0;
-  eat_spaces();
+  dtp->u.p.repeat_count = 0;
+  eat_spaces (dtp);
 
   len = nl->len;
   switch (nl->type)
@@ -1883,45 +1857,45 @@ nml_read_obj (namelist_info * nl, index_type offset)
                 nl->dim[dim].stride * nl->size);
 
       /* Reset the error flag and try to read next value, if
-        repeat_count=0  */
+        dtp->u.p.repeat_count=0  */
 
-      nml_read_error = 0;
+      dtp->u.p.nml_read_error = 0;
       nml_carry = 0;
-      if (--repeat_count <= 0)
+      if (--dtp->u.p.repeat_count <= 0)
        {
-         if (input_complete)
+         if (dtp->u.p.input_complete)
            return SUCCESS;
-         if (at_eol)
-           finish_separator ();
-         if (input_complete)
+         if (dtp->u.p.at_eol)
+           finish_separator (dtp);
+         if (dtp->u.p.input_complete)
            return SUCCESS;
 
          /* GFC_TYPE_UNKNOWN through for nulls and is detected
             after the switch block.  */
 
-         saved_type = GFC_DTYPE_UNKNOWN;
-         free_saved ();
+         dtp->u.p.saved_type = GFC_DTYPE_UNKNOWN;
+         free_saved (dtp);
 
           switch (nl->type)
          {
          case GFC_DTYPE_INTEGER:
-              read_integer (len);
+             read_integer (dtp, len);
               break;
 
          case GFC_DTYPE_LOGICAL:
-              read_logical (len);
+             read_logical (dtp, len);
               break;
 
          case GFC_DTYPE_CHARACTER:
-              read_character (len);
+             read_character (dtp, len);
               break;
 
          case GFC_DTYPE_REAL:
-              read_real (len);
+             read_real (dtp, len);
               break;
 
          case GFC_DTYPE_COMPLEX:
-              read_complex (len, dlen);
+              read_complex (dtp, len, dlen);
               break;
 
          case GFC_DTYPE_DERIVED:
@@ -1942,13 +1916,15 @@ nml_read_obj (namelist_info * nl, index_type offset)
                 cmp = cmp->next)
              {
 
-               if (nml_read_obj (cmp, (index_type)(pdata - nl->mem_pos)) == FAILURE)
+               if (nml_read_obj (dtp, cmp, (index_type)(pdata - nl->mem_pos),
+                                 pprev_nl, nml_err_msg, clow, chigh)
+                   == FAILURE)
                  {
                    free_mem (obj_name);
                    return FAILURE;
                  }
 
-               if (input_complete)
+               if (dtp->u.p.input_complete)
                  {
                    free_mem (obj_name);
                    return SUCCESS;
@@ -1960,42 +1936,42 @@ nml_read_obj (namelist_info * nl, index_type offset)
 
           default:
            st_sprintf (nml_err_msg, "Bad type for namelist object %s",
-                       nl->var_name );
-           internal_error (nml_err_msg);
+                       nl->var_name);
+           internal_error (&dtp->common, nml_err_msg);
            goto nml_err_ret;
           }
         }
 
       /* The standard permits array data to stop short of the number of
         elements specified in the loop specification.  In this case, we
-        should be here with nml_read_error != 0.  Control returns to
+        should be here with dtp->u.p.nml_read_error != 0.  Control returns to
         nml_get_obj_data and an attempt is made to read object name.  */
 
-      prev_nl = nl;
-      if (nml_read_error)
+      *pprev_nl = nl;
+      if (dtp->u.p.nml_read_error)
        return SUCCESS;
 
-      if (saved_type == GFC_DTYPE_UNKNOWN)
+      if (dtp->u.p.saved_type == GFC_DTYPE_UNKNOWN)
        goto incr_idx;
 
 
       /* Note the switch from GFC_DTYPE_type to BT_type at this point.
         This comes about because the read functions return BT_types.  */
 
-      switch (saved_type)
+      switch (dtp->u.p.saved_type)
       {
 
        case BT_COMPLEX:
        case BT_REAL:
        case BT_INTEGER:
        case BT_LOGICAL:
-         memcpy (pdata, value, dlen);
+         memcpy (pdata, dtp->u.p.value, dlen);
          break;
 
        case BT_CHARACTER:
-         m = (dlen < saved_used) ? dlen : saved_used;
+         m = (dlen < dtp->u.p.saved_used) ? dlen : dtp->u.p.saved_used;
          pdata = (void*)( pdata + clow - 1 );
-         memcpy (pdata, saved_string, m);
+         memcpy (pdata, dtp->u.p.saved_string, m);
          if (m < dlen)
            memset ((void*)( pdata + m ), ' ', dlen - m);
        break;
@@ -2028,7 +2004,7 @@ incr_idx:
         }
     } while (!nml_carry);
 
-  if (repeat_count > 1)
+  if (dtp->u.p.repeat_count > 1)
     {
        st_sprintf (nml_err_msg, "Repeat count too large for namelist object %s" ,
                   nl->var_name );
@@ -2049,55 +2025,57 @@ nml_err_ret:
    the manner specified by the object name.  */
 
 static try
-nml_get_obj_data (void)
+nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl,
+                 char *nml_err_msg)
 {
   char c;
-  char * ext_name;
   namelist_info * nl;
   namelist_info * first_nl = NULL;
   namelist_info * root_nl = NULL;
   int dim;
   int component_flag;
+  char parse_err_msg[30];
+  index_type clow, chigh;
 
   /* Look for end of input or object name.  If '?' or '=?' are encountered
      in stdin, print the node names or the namelist to stdout.  */
 
-  eat_separator ();
-  if (input_complete)
+  eat_separator (dtp);
+  if (dtp->u.p.input_complete)
     return SUCCESS;
 
-  if ( at_eol )
-    finish_separator ();
-  if (input_complete)
+  if (dtp->u.p.at_eol)
+    finish_separator (dtp);
+  if (dtp->u.p.input_complete)
     return SUCCESS;
 
-  c = next_char ();
+  c = next_char (dtp);
   switch (c)
     {
     case '=':
-      c = next_char ();
+      c = next_char (dtp);
       if (c != '?')
        {
          st_sprintf (nml_err_msg, "namelist read: missplaced = sign");
          goto nml_err_ret;
        }
-      nml_query ('=');
+      nml_query (dtp, '=');
       return SUCCESS;
 
     case '?':
-      nml_query ('?');
+      nml_query (dtp, '?');
       return SUCCESS;
 
     case '$':
     case '&':
-      nml_match_name ("end", 3);
-      if (nml_read_error)
+      nml_match_name (dtp, "end", 3);
+      if (dtp->u.p.nml_read_error)
        {
          st_sprintf (nml_err_msg, "namelist not terminated with / or &end");
          goto nml_err_ret;
        }
     case '/':
-      input_complete = 1;
+      dtp->u.p.input_complete = 1;
       return SUCCESS;
 
     default :
@@ -2107,22 +2085,22 @@ nml_get_obj_data (void)
   /* Untouch all nodes of the namelist and reset the flag that is set for
      derived type components.  */
 
-  nml_untouch_nodes();
+  nml_untouch_nodes (dtp);
   component_flag = 0;
 
   /* Get the object name - should '!' and '\n' be permitted separators?  */
 
 get_name:
 
-  free_saved ();
+  free_saved (dtp);
 
   do
     {
-      push_char(tolower(c));
-      c = next_char ();
+      push_char (dtp, tolower(c));
+      c = next_char (dtp);
     } while (!( c=='=' || c==' ' || c=='\t' || c =='(' || c =='%' ));
 
-  unget_char (c);
+  unget_char (dtp, c);
 
   /* Check that the name is in the namelist and get pointer to object.
      Three error conditions exist: (i) An attempt is being made to
@@ -2131,30 +2109,33 @@ get_name:
      are present for an object.  (iii) gives the same error message
      as (i)  */
 
-  push_char ('\0');
+  push_char (dtp, '\0');
 
   if (component_flag)
     {
-      ext_name = (char*)get_mem (strlen (root_nl->var_name)
-                                 + (saved_string ? strlen (saved_string) : 0)
-                                 + 1);
-      strcpy (ext_name, root_nl->var_name);
-      strcat (ext_name, saved_string);
-      nl = find_nml_node (ext_name);
-      free_mem (ext_name);
+      size_t var_len = strlen (root_nl->var_name);
+      size_t saved_len
+       = dtp->u.p.saved_string ? strlen (dtp->u.p.saved_string) : 0;
+      char ext_name[var_len + saved_len + 1];
+
+      memcpy (ext_name, root_nl->var_name, var_len);
+      if (dtp->u.p.saved_string)
+       memcpy (ext_name + var_len, dtp->u.p.saved_string, saved_len);
+      ext_name[var_len + saved_len] = '\0';
+      nl = find_nml_node (dtp, ext_name);
     }
   else
-    nl = find_nml_node (saved_string);
+    nl = find_nml_node (dtp, dtp->u.p.saved_string);
 
   if (nl == NULL)
     {
-      if (nml_read_error && prev_nl)
+      if (dtp->u.p.nml_read_error && *pprev_nl)
        st_sprintf (nml_err_msg, "Bad data for namelist object %s",
-                   prev_nl->var_name);
+                   (*pprev_nl)->var_name);
 
       else
        st_sprintf (nml_err_msg, "Cannot match namelist object name %s",
-                   saved_string);
+                   dtp->u.p.saved_string);
 
       goto nml_err_ret;
     }
@@ -2174,14 +2155,15 @@ get_name:
 
   if (c == '(' && nl->var_rank)
     {
-      if (nml_parse_qualifier (nl->dim, nl->ls, nl->var_rank) == FAILURE)
+      if (nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank,
+                              parse_err_msg) == FAILURE)
        {
          st_sprintf (nml_err_msg, "%s for namelist variable %s",
                      parse_err_msg, nl->var_name);
          goto nml_err_ret;
        }
-      c = next_char ();
-      unget_char (c);
+      c = next_char (dtp);
+      unget_char (dtp, c);
     }
 
   /* Now parse a derived type component. The root namelist_info address
@@ -2203,7 +2185,7 @@ get_name:
 
       root_nl = nl;
       component_flag = 1;
-      c = next_char ();
+      c = next_char (dtp);
       goto get_name;
 
     }
@@ -2219,7 +2201,7 @@ get_name:
       descriptor_dimension chd[1] = { {1, clow, nl->string_length} };
       array_loop_spec ind[1] = { {1, clow, nl->string_length, 1} };
 
-      if (nml_parse_qualifier (chd, ind, 1) == FAILURE)
+      if (nml_parse_qualifier (dtp, chd, ind, 1, parse_err_msg) == FAILURE)
        {
          st_sprintf (nml_err_msg, "%s for namelist variable %s",
                      parse_err_msg, nl->var_name);
@@ -2237,8 +2219,8 @@ get_name:
          goto nml_err_ret;
        }
 
-      c = next_char ();
-      unget_char (c);
+      c = next_char (dtp);
+      unget_char (dtp, c);
     }
 
   /* If a derived type touch its components and restore the root
@@ -2261,20 +2243,20 @@ get_name:
 
 /* According to the standard, an equal sign MUST follow an object name. The
    following is possibly lax - it allows comments, blank lines and so on to
-   intervene.  eat_spaces (); c = next_char (); would be compliant*/
+   intervene.  eat_spaces (dtp); c = next_char (dtp); would be compliant*/
 
-  free_saved ();
+  free_saved (dtp);
 
-  eat_separator ();
-  if (input_complete)
+  eat_separator (dtp);
+  if (dtp->u.p.input_complete)
     return SUCCESS;
 
-  if (at_eol)
-    finish_separator ();
-  if (input_complete)
+  if (dtp->u.p.at_eol)
+    finish_separator (dtp);
+  if (dtp->u.p.input_complete)
     return SUCCESS;
 
-  c = next_char ();
+  c = next_char (dtp);
 
   if (c != '=')
     {
@@ -2283,7 +2265,7 @@ get_name:
       goto nml_err_ret;
     }
 
-  if (nml_read_obj (nl, 0) == FAILURE)
+  if (nml_read_obj (dtp, nl, 0, pprev_nl, nml_err_msg, clow, chigh) == FAILURE)
     goto nml_err_ret;
 
   return SUCCESS;
@@ -2298,16 +2280,24 @@ nml_err_ret:
   completed or there is an error.  */
 
 void
-namelist_read (void)
+namelist_read (st_parameter_dt *dtp)
 {
   char c;
+  jmp_buf eof_jump;
+  char nml_err_msg[100];
+  /* Pointer to the previously read object, in case attempt is made to read
+     new object name.  Should this fail, error message can give previous
+     name.  */
+  namelist_info *prev_nl = NULL;
 
-  namelist_mode = 1;
-  input_complete = 0;
+  dtp->u.p.namelist_mode = 1;
+  dtp->u.p.input_complete = 0;
 
-  if (setjmp (g.eof_jump))
+  dtp->u.p.eof_jump = &eof_jump;
+  if (setjmp (eof_jump))
     {
-      generate_error (ERROR_END, NULL);
+      dtp->u.p.eof_jump = NULL;
+      generate_error (&dtp->common, ERROR_END, NULL);
       return;
     }
 
@@ -2316,22 +2306,22 @@ namelist_read (void)
      node names or namelist on stdout.  */
 
 find_nml_name:
-  switch (c = next_char ())
+  switch (c = next_char (dtp))
     {
     case '$':
     case '&':
           break;
 
     case '=':
-      c = next_char ();
+      c = next_char (dtp);
       if (c == '?')
-       nml_query ('=');
+       nml_query (dtp, '=');
       else
-       unget_char (c);
+       unget_char (dtp, c);
       goto find_nml_name;
 
     case '?':
-      nml_query ('?');
+      nml_query (dtp, '?');
 
     default:
       goto find_nml_name;
@@ -2339,34 +2329,44 @@ find_nml_name:
 
   /* Match the name of the namelist.  */
 
-  nml_match_name (ioparm.namelist_name, ioparm.namelist_name_len);
+  nml_match_name (dtp, dtp->namelist_name, dtp->namelist_name_len);
 
-  if (nml_read_error)
+  if (dtp->u.p.nml_read_error)
     goto find_nml_name;
 
   /* Ready to read namelist objects.  If there is an error in input
      from stdin, output the error message and continue.  */
 
-  while (!input_complete)
+  while (!dtp->u.p.input_complete)
     {
-      if (nml_get_obj_data ( == FAILURE)
+      if (nml_get_obj_data (dtp, &prev_nl, nml_err_msg) == FAILURE)
        {
-         if (current_unit->unit_number != options.stdin_unit)
+         gfc_unit *u;
+
+         if (dtp->u.p.current_unit->unit_number != options.stdin_unit)
            goto nml_err_ret;
 
+         u = find_unit (options.stderr_unit);
          st_printf ("%s\n", nml_err_msg);
-         flush (find_unit (options.stderr_unit)->s);
+         if (u != NULL)
+           {
+             flush (u->s);
+             unlock_unit (u);
+           }
         }
 
    }
-  free_saved ();
+
+  dtp->u.p.eof_jump = NULL;
+  free_saved (dtp);
   return;
 
   /* All namelist error calls return from here */
 
 nml_err_ret:
 
-  free_saved ();
-  generate_error (ERROR_READ_VALUE , nml_err_msg);
+  dtp->u.p.eof_jump = NULL;
+  free_saved (dtp);
+  generate_error (&dtp->common, ERROR_READ_VALUE, nml_err_msg);
   return;
 }
index 7dc08e1..c39188f 100644 (file)
@@ -33,53 +33,28 @@ Boston, MA 02110-1301, USA.  */
 #include "libgfortran.h"
 #include "io.h"
 
-st_parameter ioparm;
-iexport_data(ioparm);
-
-namelist_info *ionml;
-global_t g;
-
-
 /* library_start()-- Called with a library call is entered.  */
 
 void
-library_start (void)
+library_start (st_parameter_common *cmp)
 {
-  if (g.in_library)
-    internal_error ("Recursive library calls not allowed");
-
-  /* The in_library flag indicates whether we're currently processing a
-     library call.  Some calls leave immediately, but READ and WRITE
-     processing return control to the caller but are still considered to
-     stay within the library. */
-  g.in_library = 1;
+  if ((cmp->flags & IOPARM_HAS_IOSTAT) != 0)
+    *cmp->iostat = ERROR_OK;
 
-  if (ioparm.iostat != NULL)
-    *ioparm.iostat = ERROR_OK;
-
-  ioparm.library_return = LIBRARY_OK;
+  cmp->flags &= ~IOPARM_LIBRETURN_MASK;
 }
 
 
-/* library_end()-- Called when a library call is complete in order to
-   clean up for the next call. */
-
 void
-library_end (void)
+free_ionml (st_parameter_dt *dtp)
 {
-  int t;
   namelist_info * t1, *t2;
 
-  g.in_library = 0;
-  filename = NULL;
-  line = 0;
-  t = ioparm.library_return;
-
   /* Delete the namelist, if it exists.  */
 
-  if (ionml != NULL)
+  if (dtp->u.p.ionml != NULL)
     {
-      t1 = ionml;
+      t1 = dtp->u.p.ionml;
       while (t1 != NULL)
        {
          t2 = t1;
@@ -93,8 +68,5 @@ library_end (void)
          free_mem (t2);
        }
     }
-  ionml = NULL;
-
-  memset (&ioparm, '\0', sizeof (ioparm));
-  ioparm.library_return = t;
+  dtp->u.p.ionml = NULL;
 }
index c3b5dde..a1bc99b 100644 (file)
@@ -116,56 +116,57 @@ test_endfile (gfc_unit * u)
    changed.  */
 
 static void
-edit_modes (gfc_unit * u, unit_flags * flags)
+edit_modes (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
 {
   /* Complain about attempts to change the unchangeable.  */
 
   if (flags->status != STATUS_UNSPECIFIED &&
       u->flags.status != flags->status)
-    generate_error (ERROR_BAD_OPTION,
+    generate_error (&opp->common, ERROR_BAD_OPTION,
                    "Cannot change STATUS parameter in OPEN statement");
 
   if (flags->access != ACCESS_UNSPECIFIED && u->flags.access != flags->access)
-    generate_error (ERROR_BAD_OPTION,
+    generate_error (&opp->common, ERROR_BAD_OPTION,
                    "Cannot change ACCESS parameter in OPEN statement");
 
   if (flags->form != FORM_UNSPECIFIED && u->flags.form != flags->form)
-    generate_error (ERROR_BAD_OPTION,
+    generate_error (&opp->common, ERROR_BAD_OPTION,
                    "Cannot change FORM parameter in OPEN statement");
 
-  if (ioparm.recl_in != 0 && ioparm.recl_in != u->recl)
-    generate_error (ERROR_BAD_OPTION,
+  if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN)
+      && opp->recl_in != u->recl)
+    generate_error (&opp->common, ERROR_BAD_OPTION,
                    "Cannot change RECL parameter in OPEN statement");
 
   if (flags->action != ACTION_UNSPECIFIED && u->flags.access != flags->access)
-    generate_error (ERROR_BAD_OPTION,
+    generate_error (&opp->common, ERROR_BAD_OPTION,
                    "Cannot change ACTION parameter in OPEN statement");
 
   /* Status must be OLD if present.  */
 
   if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD)
-    generate_error (ERROR_BAD_OPTION,
+    generate_error (&opp->common, ERROR_BAD_OPTION,
                    "OPEN statement must have a STATUS of OLD");
 
   if (u->flags.form == FORM_UNFORMATTED)
     {
       if (flags->delim != DELIM_UNSPECIFIED)
-       generate_error (ERROR_OPTION_CONFLICT,
+       generate_error (&opp->common, ERROR_OPTION_CONFLICT,
                        "DELIM parameter conflicts with UNFORMATTED form in "
                        "OPEN statement");
 
       if (flags->blank != BLANK_UNSPECIFIED)
-       generate_error (ERROR_OPTION_CONFLICT,
+       generate_error (&opp->common, ERROR_OPTION_CONFLICT,
                        "BLANK parameter conflicts with UNFORMATTED form in "
                        "OPEN statement");
 
       if (flags->pad != PAD_UNSPECIFIED)
-       generate_error (ERROR_OPTION_CONFLICT,
+       generate_error (&opp->common, ERROR_OPTION_CONFLICT,
                        "PAD paramter conflicts with UNFORMATTED form in "
                        "OPEN statement");
     }
 
-  if (ioparm.library_return == LIBRARY_OK)
+  if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
     {
       /* Change the changeable:  */
       if (flags->blank != BLANK_UNSPECIFIED)
@@ -203,18 +204,20 @@ edit_modes (gfc_unit * u, unit_flags * flags)
       break;
 
     seek_error:
-      generate_error (ERROR_OS, NULL);
+      generate_error (&opp->common, ERROR_OS, NULL);
       break;
     }
+
+  unlock_unit (u);
 }
 
 
 /* Open an unused unit.  */
 
-void
-new_unit (unit_flags * flags)
+gfc_unit *
+new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
 {
-  gfc_unit *u;
+  gfc_unit *u2;
   stream *s;
   char tmpname[5 /* fort. */ + 10 /* digits of unit number */ + 1 /* 0 */];
 
@@ -236,10 +239,10 @@ new_unit (unit_flags * flags)
     {
       if (flags->form == FORM_UNFORMATTED)
        {
-         generate_error (ERROR_OPTION_CONFLICT,
+         generate_error (&opp->common, ERROR_OPTION_CONFLICT,
                          "DELIM parameter conflicts with UNFORMATTED form in "
                          "OPEN statement");
-         goto cleanup;
+         goto fail;
        }
     }
 
@@ -249,10 +252,10 @@ new_unit (unit_flags * flags)
     {
       if (flags->form == FORM_UNFORMATTED)
        {
-         generate_error (ERROR_OPTION_CONFLICT,
+         generate_error (&opp->common, ERROR_OPTION_CONFLICT,
                          "BLANK parameter conflicts with UNFORMATTED form in "
                          "OPEN statement");
-         goto cleanup;
+         goto fail;
        }
     }
 
@@ -262,19 +265,19 @@ new_unit (unit_flags * flags)
     {
       if (flags->form == FORM_UNFORMATTED)
        {
-         generate_error (ERROR_OPTION_CONFLICT,
+         generate_error (&opp->common, ERROR_OPTION_CONFLICT,
                          "PAD paramter conflicts with UNFORMATTED form in "
                          "OPEN statement");
-         goto cleanup;
+         goto fail;
        }
     }
 
   if (flags->position != POSITION_ASIS && flags->access == ACCESS_DIRECT)
    {
-     generate_error (ERROR_OPTION_CONFLICT,
+     generate_error (&opp->common, ERROR_OPTION_CONFLICT,
                      "ACCESS parameter conflicts with SEQUENTIAL access in "
                      "OPEN statement");
-     goto cleanup;
+     goto fail;
    }
   else
    if (flags->position == POSITION_UNSPECIFIED)
@@ -286,64 +289,74 @@ new_unit (unit_flags * flags)
 
   /* Checks.  */
 
-  if (flags->access == ACCESS_DIRECT && ioparm.recl_in == 0)
+  if (flags->access == ACCESS_DIRECT
+      && (opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) == 0)
     {
-      generate_error (ERROR_MISSING_OPTION,
+      generate_error (&opp->common, ERROR_MISSING_OPTION,
                      "Missing RECL parameter in OPEN statement");
-      goto cleanup;
+      goto fail;
     }
 
-  if (ioparm.recl_in != 0 && ioparm.recl_in <= 0)
+  if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) && opp->recl_in <= 0)
     {
-      generate_error (ERROR_BAD_OPTION,
+      generate_error (&opp->common, ERROR_BAD_OPTION,
                      "RECL parameter is non-positive in OPEN statement");
-      goto cleanup;
+      goto fail;
     }
 
   switch (flags->status)
     {
     case STATUS_SCRATCH:
-      if (ioparm.file == NULL)
-       break;
+      if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
+       {
+         opp->file = NULL;
+         break;
+       }
 
-      generate_error (ERROR_BAD_OPTION,
+      generate_error (&opp->common, ERROR_BAD_OPTION,
                      "FILE parameter must not be present in OPEN statement");
-      return;
+      goto fail;
 
     case STATUS_OLD:
     case STATUS_NEW:
     case STATUS_REPLACE:
     case STATUS_UNKNOWN:
-      if (ioparm.file != NULL)
+      if ((opp->common.flags & IOPARM_OPEN_HAS_FILE))
        break;
 
-      ioparm.file = tmpname;
-      ioparm.file_len = sprintf(ioparm.file, "fort.%d", ioparm.unit);
+      opp->file = tmpname;
+      opp->file_len = sprintf(opp->file, "fort.%d", opp->common.unit);
       break;
 
     default:
-      internal_error ("new_unit(): Bad status");
+      internal_error (&opp->common, "new_unit(): Bad status");
     }
 
   /* Make sure the file isn't already open someplace else.
      Do not error if opening file preconnected to stdin, stdout, stderr.  */
 
-  u = find_file ();
-  if (u != NULL
+  u2 = NULL;
+  if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) != 0)
+    u2 = find_file (opp->file, opp->file_len);
+  if (u2 != NULL
       && (options.stdin_unit < 0 || u->unit_number != options.stdin_unit)
       && (options.stdout_unit < 0 || u->unit_number != options.stdout_unit)
       && (options.stderr_unit < 0 || u->unit_number != options.stderr_unit))
     {
-      generate_error (ERROR_ALREADY_OPEN, NULL);
+      unlock_unit (u2);
+      generate_error (&opp->common, ERROR_ALREADY_OPEN, NULL);
       goto cleanup;
     }
 
+  if (u2 != NULL)
+    unlock_unit (u2);
+
   /* Open file.  */
 
-  s = open_external (flags);
+  s = open_external (opp, flags);
   if (s == NULL)
     {
-      generate_error (ERROR_OS, NULL);
+      generate_error (&opp->common, ERROR_OS, NULL);
       goto cleanup;
     }
 
@@ -352,52 +365,65 @@ new_unit (unit_flags * flags)
 
   /* Create the unit structure.  */
 
-  u = get_mem (sizeof (gfc_unit) + ioparm.file_len);
-  memset (u, '\0', sizeof (gfc_unit) + ioparm.file_len);
-
-  u->unit_number = ioparm.unit;
+  u->file = get_mem (opp->file_len);
+  if (u->unit_number != opp->common.unit)
+    internal_error (&opp->common, "Unit number changed");
   u->s = s;
   u->flags = *flags;
+  u->read_bad = 0;
+  u->endfile = NO_ENDFILE;
+  u->last_record = 0;
+  u->current_record = 0;
+  u->mode = READING;
+  u->maxrec = 0;
+  u->bytes_left = 0;
 
   if (flags->position == POSITION_APPEND)
-  {
-    if (sseek (u->s, file_length (u->s)) == FAILURE)
-      generate_error (ERROR_OS, NULL);
-    u->endfile = AT_ENDFILE;
-  }
+    {
+      if (sseek (u->s, file_length (u->s)) == FAILURE)
+       generate_error (&opp->common, ERROR_OS, NULL);
+      u->endfile = AT_ENDFILE;
+    }
 
   /* Unspecified recl ends up with a processor dependent value.  */
 
-  u->recl = (ioparm.recl_in != 0) ? ioparm.recl_in : g.max_offset;
-  u->last_record = 0;
-  u->current_record = 0;
+  if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
+    u->recl = opp->recl_in;
+  else
+    u->recl = max_offset;
 
   /* If the file is direct access, calculate the maximum record number
      via a division now instead of letting the multiplication overflow
      later.  */
 
   if (flags->access == ACCESS_DIRECT)
-    u->maxrec = g.max_offset / u->recl;
-
-  memmove (u->file, ioparm.file, ioparm.file_len);
-  u->file_len = ioparm.file_len;
+    u->maxrec = max_offset / u->recl;
 
-  insert_unit (u);
+  memmove (u->file, opp->file, opp->file_len);
+  u->file_len = opp->file_len;
 
-  /* The file is now connected.  Errors after this point leave the
-     file connected.  Curiously, the standard requires that the
+  /* Curiously, the standard requires that the
      position specifier be ignored for new files so a newly connected
      file starts out that the initial point.  We still need to figure
      out if the file is at the end or not.  */
 
   test_endfile (u);
 
+  if (flags->status == STATUS_SCRATCH && opp->file != NULL)
+    free_mem (opp->file);
+  return u;
+
  cleanup:
 
   /* Free memory associated with a temporary filename.  */
 
-  if (flags->status == STATUS_SCRATCH)
-    free_mem (ioparm.file);
+  if (flags->status == STATUS_SCRATCH && opp->file != NULL)
+    free_mem (opp->file);
+
+ fail:
+
+  close_unit (u);
+  return NULL;
 }
 
 
@@ -405,95 +431,122 @@ new_unit (unit_flags * flags)
    modes or closing what is there now and opening the new file.  */
 
 static void
-already_open (gfc_unit * u, unit_flags * flags)
+already_open (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
 {
-  if (ioparm.file == NULL)
+  if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
     {
-      edit_modes (u, flags);
+      edit_modes (opp, u, flags);
       return;
     }
 
   /* If the file is connected to something else, close it and open a
      new unit.  */
 
-  if (!compare_file_filename (u, ioparm.file, ioparm.file_len))
+  if (!compare_file_filename (u, opp->file, opp->file_len))
     {
-      if (close_unit (u))
+#if !HAVE_UNLINK_OPEN_FILE
+      char *path = NULL;
+      if (u->file && u->flags.status == STATUS_SCRATCH)
        {
-         generate_error (ERROR_OS, "Error closing file in OPEN statement");
+         path = (char *) gfc_alloca (u->file_len + 1);
+         unpack_filename (path, u->file, u->file_len);
+       }
+#endif
+
+      if (sclose (u->s) == FAILURE)
+       {
+         unlock_unit (u);
+         generate_error (&opp->common, ERROR_OS,
+                         "Error closing file in OPEN statement");
          return;
        }
 
-      new_unit (flags);
+      u->s = NULL;
+      if (u->file)
+       free_mem (u->file);
+      u->file = NULL;
+      u->file_len = 0;
+
+#if !HAVE_UNLINK_OPEN_FILE
+      if (path != NULL)
+       unlink (path);
+#endif
+
+      u = new_unit (opp, u, flags);
+      if (u != NULL)
+       unlock_unit (u);
       return;
     }
 
-  edit_modes (u, flags);
+  edit_modes (opp, u, flags);
 }
 
 
 /* Open file.  */
 
-extern void st_open (void);
+extern void st_open (st_parameter_open *opp);
 export_proto(st_open);
 
 void
-st_open (void)
+st_open (st_parameter_open *opp)
 {
   unit_flags flags;
   gfc_unit *u = NULL;
+  GFC_INTEGER_4 cf = opp->common.flags;
  
-  library_start ();
+  library_start (&opp->common);
 
   /* Decode options.  */
 
-  flags.access = (ioparm.access == NULL) ? ACCESS_UNSPECIFIED :
-    find_option (ioparm.access, ioparm.access_len, access_opt,
-                "Bad ACCESS parameter in OPEN statement");
+  flags.access = !(cf & IOPARM_OPEN_HAS_ACCESS) ? ACCESS_UNSPECIFIED :
+    find_option (&opp->common, opp->access, opp->access_len,
+                access_opt, "Bad ACCESS parameter in OPEN statement");
 
-  flags.action = (ioparm.action == NULL) ? ACTION_UNSPECIFIED :
-    find_option (ioparm.action, ioparm.action_len, action_opt,
-                "Bad ACTION parameter in OPEN statement");
+  flags.action = !(cf & IOPARM_OPEN_HAS_ACTION) ? ACTION_UNSPECIFIED :
+    find_option (&opp->common, opp->action, opp->action_len,
+  &