re PR fortran/14943 (read/write code generation is not thread safe)

gcc/fortran/
	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.

From-SVN: r107328

1 files changed, 156 insertions, 161 deletions

diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c
index 1197ac0..fb91639 100644
--- a/libgfortran/io/write.c
+++ b/libgfortran/io/write.c
@@ -46,17 +46,15 @@ typedef enum
 sign_t;
 
 
-static int no_leading_blank = 0 ;
-
 void
-write_a (fnode * f, const char *source, int len)
+write_a (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
 {
   int wlen;
   char *p;
 
   wlen = f->u.string.length < 0 ? len : f->u.string.length;
 
-  p = write_block (wlen);
+  p = write_block (dtp, wlen);
   if (p == NULL)
     return;
 
@@ -117,7 +115,7 @@ extract_int (const void *p, int len)
       break;
 #endif
     default:
-      internal_error ("bad integer kind");
+      internal_error (NULL, "bad integer kind");
     }
 
   return i;
@@ -171,7 +169,7 @@ extract_uint (const void *p, int len)
       break;
 #endif
     default:
-      internal_error ("bad integer kind");
+      internal_error (NULL, "bad integer kind");
     }
 
   return i;
@@ -216,7 +214,7 @@ extract_real (const void *p, int len)
       break;
 #endif
     default:
-      internal_error ("bad real kind");
+      internal_error (NULL, "bad real kind");
     }
   return i;
 }
@@ -226,14 +224,14 @@ extract_real (const void *p, int len)
    sign_t that gives the sign that we need to produce.  */
 
 static sign_t
-calculate_sign (int negative_flag)
+calculate_sign (st_parameter_dt *dtp, int negative_flag)
 {
   sign_t s = SIGN_NONE;
 
   if (negative_flag)
     s = SIGN_MINUS;
   else
-    switch (g.sign_status)
+    switch (dtp->u.p.sign_status)
       {
       case SIGN_SP:
 	s = SIGN_PLUS;
@@ -285,7 +283,8 @@ calculate_exp (int d)
           for Gw.dEe, n' ' means e+2 blanks  */
 
 static fnode *
-calculate_G_format (fnode *f, GFC_REAL_LARGEST value, int *num_blank)
+calculate_G_format (st_parameter_dt *dtp, const fnode *f,
+		    GFC_REAL_LARGEST value, int *num_blank)
 {
   int e = f->u.real.e;
   int d = f->u.real.d;
@@ -366,7 +365,7 @@ calculate_G_format (fnode *f, GFC_REAL_LARGEST value, int *num_blank)
     newf->u.real.d = - (mid - d - 1);
 
   /* For F editing, the scale factor is ignored.  */
-  g.scale_factor = 0;
+  dtp->u.p.scale_factor = 0;
   return newf;
 }
 
@@ -374,7 +373,7 @@ calculate_G_format (fnode *f, GFC_REAL_LARGEST value, int *num_blank)
 /* Output a real number according to its format which is FMT_G free.  */
 
 static void
-output_float (fnode *f, GFC_REAL_LARGEST value)
+output_float (st_parameter_dt *dtp, const fnode *f, GFC_REAL_LARGEST value)
 {
   /* This must be large enough to accurately hold any value.  */
   char buffer[32];
@@ -410,12 +409,12 @@ output_float (fnode *f, GFC_REAL_LARGEST value)
 
   /* We should always know the field width and precision.  */
   if (d < 0)
-    internal_error ("Unspecified precision");
+    internal_error (&dtp->common, "Unspecified precision");
 
   /* Use sprintf to print the number in the format +D.DDDDe+ddd
      For an N digit exponent, this gives us (32-6)-N digits after the
      decimal point, plus another one before the decimal point.  */
-  sign = calculate_sign (value < 0.0);
+  sign = calculate_sign (dtp, value < 0.0);
   if (value < 0)
     value = -value;
 
@@ -436,7 +435,7 @@ output_float (fnode *f, GFC_REAL_LARGEST value)
     }
 
   if (ft == FMT_F || ft == FMT_EN
-      || ((ft == FMT_D || ft == FMT_E) && g.scale_factor != 0))
+      || ((ft == FMT_D || ft == FMT_E) && dtp->u.p.scale_factor != 0))
     {
       /* Always convert at full precision to avoid double rounding.  */
       ndigits = 27 - edigits;
@@ -474,7 +473,7 @@ output_float (fnode *f, GFC_REAL_LARGEST value)
 
   /* Check the resulting string has punctuation in the correct places.  */
   if (buffer[2] != '.' || buffer[ndigits + 2] != 'e')
-      internal_error ("printf is broken");
+      internal_error (&dtp->common, "printf is broken");
 
   /* Read the exponent back in.  */
   e = atoi (&buffer[ndigits + 3]) + 1;
@@ -491,7 +490,7 @@ output_float (fnode *f, GFC_REAL_LARGEST value)
   switch (ft)
     {
     case FMT_F:
-      nbefore = e + g.scale_factor;
+      nbefore = e + dtp->u.p.scale_factor;
       if (nbefore < 0)
 	{
 	  nzero = -nbefore;
@@ -511,7 +510,7 @@ output_float (fnode *f, GFC_REAL_LARGEST value)
 
     case FMT_E:
     case FMT_D:
-      i = g.scale_factor;
+      i = dtp->u.p.scale_factor;
       if (value != 0.0)
 	e -= i;
       if (i < 0)
@@ -570,7 +569,7 @@ output_float (fnode *f, GFC_REAL_LARGEST value)
 
     default:
       /* Should never happen.  */
-      internal_error ("Unexpected format token");
+      internal_error (&dtp->common, "Unexpected format token");
     }
 
   /* Round the value.  */
@@ -671,7 +670,7 @@ output_float (fnode *f, GFC_REAL_LARGEST value)
     w = nbefore + nzero + nafter + (sign != SIGN_NONE ? 2 : 1);
 
   /* Create the ouput buffer.  */
-  out = write_block (w);
+  out = write_block (dtp, w);
   if (out == NULL)
     return;
 
@@ -683,7 +682,7 @@ output_float (fnode *f, GFC_REAL_LARGEST value)
 	break;
     }
   if (i == ndigits)
-    sign = calculate_sign (0);
+    sign = calculate_sign (dtp, 0);
 
   /* Work out how much padding is needed.  */
   nblanks = w - (nbefore + nzero + nafter + edigits + 1);
@@ -709,7 +708,7 @@ output_float (fnode *f, GFC_REAL_LARGEST value)
   /* Pad to full field width.  */
 
 
-  if ( ( nblanks > 0 ) && !no_leading_blank )
+  if ( ( nblanks > 0 ) && !dtp->u.p.no_leading_blank)
     {
       memset (out, ' ', nblanks);
       out += nblanks;
@@ -784,22 +783,22 @@ output_float (fnode *f, GFC_REAL_LARGEST value)
       memcpy (out, buffer, edigits);
     }
 
-  if ( no_leading_blank )
+  if (dtp->u.p.no_leading_blank)
     {
       out += edigits;
       memset( out , ' ' , nblanks );
-      no_leading_blank = 0;
+      dtp->u.p.no_leading_blank = 0;
     }
 }
 
 
 void
-write_l (fnode * f, char *source, int len)
+write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len)
 {
   char *p;
   GFC_INTEGER_LARGEST n;
 
-  p = write_block (f->u.w);
+  p = write_block (dtp, f->u.w);
   if (p == NULL)
     return;
 
@@ -811,7 +810,7 @@ write_l (fnode * f, char *source, int len)
 /* Output a real number according to its format.  */
 
 static void
-write_float (fnode *f, const char *source, int len)
+write_float (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
 {
   GFC_REAL_LARGEST n;
   int nb =0, res, save_scale_factor;
@@ -831,7 +830,7 @@ write_float (fnode *f, const char *source, int len)
 	     not zero.  4 is chosen to allow output of '-Inf' or '+Inf' */
 	     
 	  if (nb == 0) nb = 4;
-	  p = write_block (nb);
+	  p = write_block (dtp, nb);
           if (p == NULL)
             return;
 	  if (nb < 3)
@@ -890,21 +889,19 @@ write_float (fnode *f, const char *source, int len)
     }
 
   if (f->format != FMT_G)
-    {
-      output_float (f, n);
-    }
+    output_float (dtp, f, n);
   else
     {
-      save_scale_factor = g.scale_factor;
-      f2 = calculate_G_format(f, n, &nb);
-      output_float (f2, n);
-      g.scale_factor = save_scale_factor;
+      save_scale_factor = dtp->u.p.scale_factor;
+      f2 = calculate_G_format (dtp, f, n, &nb);
+      output_float (dtp, f2, n);
+      dtp->u.p.scale_factor = save_scale_factor;
       if (f2 != NULL)
         free_mem(f2);
 
       if (nb > 0)
         {
-          p = write_block (nb);
+	  p = write_block (dtp, nb);
           if (p == NULL)
             return;
           memset (p, ' ', nb);
@@ -914,7 +911,7 @@ write_float (fnode *f, const char *source, int len)
 
 
 static void
-write_int (fnode *f, const char *source, int len,
+write_int (st_parameter_dt *dtp, const fnode *f, const char *source, int len,
            const char *(*conv) (GFC_UINTEGER_LARGEST, char *, size_t))
 {
   GFC_UINTEGER_LARGEST n = 0;
@@ -935,7 +932,7 @@ write_int (fnode *f, const char *source, int len,
       if (w == 0)
         w = 1;
 
-      p = write_block (w);
+      p = write_block (dtp, w);
       if (p == NULL)
         return;
 
@@ -952,7 +949,7 @@ write_int (fnode *f, const char *source, int len,
   if (w == 0)
     w = ((digits < m) ? m : digits);
 
-  p = write_block (w);
+  p = write_block (dtp, w);
   if (p == NULL)
     return;
 
@@ -971,13 +968,13 @@ write_int (fnode *f, const char *source, int len,
     }
 
 
-  if (!no_leading_blank)
+  if (!dtp->u.p.no_leading_blank)
     {
-  memset (p, ' ', nblank);
-  p += nblank;
-  memset (p, '0', nzero);
-  p += nzero;
-  memcpy (p, q, digits);
+      memset (p, ' ', nblank);
+      p += nblank;
+      memset (p, '0', nzero);
+      p += nzero;
+      memcpy (p, q, digits);
     }
   else
     {
@@ -986,7 +983,7 @@ write_int (fnode *f, const char *source, int len,
       memcpy (p, q, digits);
       p += digits;
       memset (p, ' ', nblank);
-      no_leading_blank = 0;
+      dtp->u.p.no_leading_blank = 0;
     }
 
  done:
@@ -994,7 +991,8 @@ write_int (fnode *f, const char *source, int len,
 }
 
 static void
-write_decimal (fnode *f, const char *source, int len,
+write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source,
+	       int len,
                const char *(*conv) (GFC_INTEGER_LARGEST, char *, size_t))
 {
   GFC_INTEGER_LARGEST n = 0;
@@ -1016,7 +1014,7 @@ write_decimal (fnode *f, const char *source, int len,
       if (w == 0)
         w = 1;
 
-      p = write_block (w);
+      p = write_block (dtp, w);
       if (p == NULL)
         return;
 
@@ -1024,7 +1022,7 @@ write_decimal (fnode *f, const char *source, int len,
       goto done;
     }
 
-  sign = calculate_sign (n < 0);
+  sign = calculate_sign (dtp, n < 0);
   if (n < 0)
     n = -n;
 
@@ -1039,7 +1037,7 @@ write_decimal (fnode *f, const char *source, int len,
   if (w == 0)
     w = ((digits < m) ? m : digits) + nsign;
 
-  p = write_block (w);
+  p = write_block (dtp, w);
   if (p == NULL)
     return;
 
@@ -1133,75 +1131,75 @@ btoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
 
 
 void
-write_i (fnode * f, const char *p, int len)
+write_i (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 {
-  write_decimal (f, p, len, (void *) gfc_itoa);
+  write_decimal (dtp, f, p, len, (void *) gfc_itoa);
 }
 
 
 void
-write_b (fnode * f, const char *p, int len)
+write_b (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 {
-  write_int (f, p, len, btoa);
+  write_int (dtp, f, p, len, btoa);
 }
 
 
 void
-write_o (fnode * f, const char *p, int len)
+write_o (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 {
-  write_int (f, p, len, otoa);
+  write_int (dtp, f, p, len, otoa);
 }
 
 void
-write_z (fnode * f, const char *p, int len)
+write_z (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 {
-  write_int (f, p, len, xtoa);
+  write_int (dtp, f, p, len, xtoa);
 }
 
 
 void
-write_d (fnode *f, const char *p, int len)
+write_d (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 {
-  write_float (f, p, len);
+  write_float (dtp, f, p, len);
 }
 
 
 void
-write_e (fnode *f, const char *p, int len)
+write_e (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 {
-  write_float (f, p, len);
+  write_float (dtp, f, p, len);
 }
 
 
 void
-write_f (fnode *f, const char *p, int len)
+write_f (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 {
-  write_float (f, p, len);
+  write_float (dtp, f, p, len);
 }
 
 
 void
-write_en (fnode *f, const char *p, int len)
+write_en (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 {
-  write_float (f, p, len);
+  write_float (dtp, f, p, len);
 }
 
 
 void
-write_es (fnode *f, const char *p, int len)
+write_es (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
 {
-  write_float (f, p, len);
+  write_float (dtp, f, p, len);
 }
 
 
 /* Take care of the X/TR descriptor.  */
 
 void
-write_x (int len, int nspaces)
+write_x (st_parameter_dt *dtp, int len, int nspaces)
 {
   char *p;
 
-  p = write_block (len);
+  p = write_block (dtp, len);
   if (p == NULL)
     return;
 
@@ -1217,11 +1215,11 @@ write_x (int len, int nspaces)
    something goes wrong.  */
 
 static int
-write_char (char c)
+write_char (st_parameter_dt *dtp, char c)
 {
   char *p;
 
-  p = write_block (1);
+  p = write_block (dtp, 1);
   if (p == NULL)
     return 1;
 
@@ -1234,16 +1232,16 @@ write_char (char c)
 /* Write a list-directed logical value.  */
 
 static void
-write_logical (const char *source, int length)
+write_logical (st_parameter_dt *dtp, const char *source, int length)
 {
-  write_char (extract_int (source, length) ? 'T' : 'F');
+  write_char (dtp, extract_int (source, length) ? 'T' : 'F');
 }
 
 
 /* Write a list-directed integer value.  */
 
 static void
-write_integer (const char *source, int length)
+write_integer (st_parameter_dt *dtp, const char *source, int length)
 {
   char *p;
   const char *q;
@@ -1278,19 +1276,19 @@ write_integer (const char *source, int length)
 
   digits = strlen (q);
 
-  if(width < digits )
-    width = digits ;
-  p = write_block (width) ;
+  if (width < digits)
+    width = digits;
+  p = write_block (dtp, width);
   if (p == NULL)
     return;
-  if (no_leading_blank)
+  if (dtp->u.p.no_leading_blank)
     {
       memcpy (p, q, digits);
-      memset(p + digits ,' ', width - digits) ;
+      memset (p + digits, ' ', width - digits);
     }
   else
     {
-      memset(p ,' ', width - digits) ;
+      memset (p, ' ', width - digits);
       memcpy (p + width - digits, q, digits);
     }
 }
@@ -1300,12 +1298,12 @@ write_integer (const char *source, int length)
    the strings if the file has been opened in that mode.  */
 
 static void
-write_character (const char *source, int length)
+write_character (st_parameter_dt *dtp, const char *source, int length)
 {
   int i, extra;
   char *p, d;
 
-  switch (current_unit->flags.delim)
+  switch (dtp->u.p.current_unit->flags.delim)
     {
     case DELIM_APOSTROPHE:
       d = '\'';
@@ -1329,7 +1327,7 @@ write_character (const char *source, int length)
 	  extra++;
     }
 
-  p = write_block (length + extra);
+  p = write_block (dtp, length + extra);
   if (p == NULL)
     return;
 
@@ -1356,12 +1354,12 @@ write_character (const char *source, int length)
    1PG24.15E4 for REAL(10) and 1PG40.31E4 for REAL(16).  */
 
 static void
-write_real (const char *source, int length)
+write_real (st_parameter_dt *dtp, const char *source, int length)
 {
   fnode f ;
-  int org_scale = g.scale_factor;
+  int org_scale = dtp->u.p.scale_factor;
   f.format = FMT_G;
-  g.scale_factor = 1;
+  dtp->u.p.scale_factor = 1;
   switch (length)
     {
     case 4:
@@ -1385,37 +1383,37 @@ write_real (const char *source, int length)
       f.u.real.e = 4;
       break;
     default:
-      internal_error ("bad real kind");
+      internal_error (&dtp->common, "bad real kind");
       break;
     }
-  write_float (&f, source , length);
-  g.scale_factor = org_scale;
+  write_float (dtp, &f, source , length);
+  dtp->u.p.scale_factor = org_scale;
 }
 
 
 static void
-write_complex (const char *source, int kind, size_t size)
+write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
 {
-  if (write_char ('('))
+  if (write_char (dtp, '('))
     return;
-  write_real (source, kind);
+  write_real (dtp, source, kind);
 
-  if (write_char (','))
+  if (write_char (dtp, ','))
     return;
-  write_real (source + size / 2, kind);
+  write_real (dtp, source + size / 2, kind);
 
-  write_char (')');
+  write_char (dtp, ')');
 }
 
 
 /* Write the separator between items.  */
 
 static void
-write_separator (void)
+write_separator (st_parameter_dt *dtp)
 {
   char *p;
 
-  p = write_block (options.separator_len);
+  p = write_block (dtp, options.separator_len);
   if (p == NULL)
     return;
 
@@ -1428,53 +1426,52 @@ write_separator (void)
    with strings.  */
 
 static void
-list_formatted_write_scalar (bt type, void *p, int kind, size_t size)
+list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
+			     size_t size)
 {
-  static int char_flag;
-
-  if (current_unit == NULL)
+  if (dtp->u.p.current_unit == NULL)
     return;
 
-  if (g.first_item)
+  if (dtp->u.p.first_item)
     {
-      g.first_item = 0;
-      char_flag = 0;
-      write_char (' ');
+      dtp->u.p.first_item = 0;
+      write_char (dtp, ' ');
     }
   else
     {
-      if (type != BT_CHARACTER || !char_flag ||
-	  current_unit->flags.delim != DELIM_NONE)
-	write_separator ();
+      if (type != BT_CHARACTER || !dtp->u.p.char_flag ||
+	  dtp->u.p.current_unit->flags.delim != DELIM_NONE)
+	write_separator (dtp);
     }
 
   switch (type)
     {
     case BT_INTEGER:
-      write_integer (p, kind);
+      write_integer (dtp, p, kind);
       break;
     case BT_LOGICAL:
-      write_logical (p, kind);
+      write_logical (dtp, p, kind);
       break;
     case BT_CHARACTER:
-      write_character (p, kind);
+      write_character (dtp, p, kind);
       break;
     case BT_REAL:
-      write_real (p, kind);
+      write_real (dtp, p, kind);
       break;
     case BT_COMPLEX:
-      write_complex (p, kind, size);
+      write_complex (dtp, p, kind, size);
       break;
     default:
-      internal_error ("list_formatted_write(): Bad type");
+      internal_error (&dtp->common, "list_formatted_write(): Bad type");
     }
 
-  char_flag = (type == BT_CHARACTER);
+  dtp->u.p.char_flag = (type == BT_CHARACTER);
 }
 
 
 void
-list_formatted_write (bt type, void *p, int kind, size_t size, size_t nelems)
+list_formatted_write (st_parameter_dt *dtp, bt type, void *p, int kind,
+		      size_t size, size_t nelems)
 {
   size_t elem;
   char *tmp;
@@ -1484,8 +1481,8 @@ list_formatted_write (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_write_scalar (type, tmp + size*elem, kind, size);
+      dtp->u.p.item_count++;
+      list_formatted_write_scalar (dtp, type, tmp + size*elem, kind, size);
     }
 }
 
@@ -1512,12 +1509,8 @@ list_formatted_write (bt type, void *p, int kind, size_t size, size_t nelems)
 
 #define NML_DIGITS 20
 
-/* Stores the delimiter to be used for character objects.  */
-
-static const char * nml_delim;
-
 static namelist_info *
-nml_write_obj (namelist_info * obj, index_type offset,
+nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
 	       namelist_info * base, char * base_name)
 {
   int rep_ctr;
@@ -1543,7 +1536,7 @@ nml_write_obj (namelist_info * obj, index_type offset,
 
   if (obj->type != GFC_DTYPE_DERIVED)
     {
-      write_character ("\n ", 2);
+      write_character (dtp, "\n ", 2);
       len = 0;
       if (base)
 	{
@@ -1551,15 +1544,15 @@ nml_write_obj (namelist_info * obj, index_type offset,
 	  for (dim_i = 0; dim_i < (index_type) strlen (base_name); dim_i++)
             {
 	      cup = toupper (base_name[dim_i]);
-	      write_character (&cup, 1);
+	      write_character (dtp, &cup, 1);
             }
 	}
       for (dim_i =len; dim_i < (index_type) strlen (obj->var_name); dim_i++)
 	{
 	  cup = toupper (obj->var_name[dim_i]);
-	  write_character (&cup, 1);
+	  write_character (dtp, &cup, 1);
 	}
-      write_character ("=", 1);
+      write_character (dtp, "=", 1);
     }
 
   /* Counts the number of data output on a line, including names.  */
@@ -1629,8 +1622,8 @@ nml_write_obj (namelist_info * obj, index_type offset,
 	  if (rep_ctr > 1)
 	    {
 	      st_sprintf(rep_buff, " %d*", rep_ctr);
-	      write_character (rep_buff, strlen (rep_buff));
-	      no_leading_blank = 1;
+	      write_character (dtp, rep_buff, strlen (rep_buff));
+	      dtp->u.p.no_leading_blank = 1;
 	    }
 	  num++;
 
@@ -1641,29 +1634,29 @@ nml_write_obj (namelist_info * obj, index_type offset,
 	    {
 
 	    case GFC_DTYPE_INTEGER:
-              write_integer (p, len);
+	      write_integer (dtp, p, len);
               break;
 
 	    case GFC_DTYPE_LOGICAL:
-              write_logical (p, len);
+	      write_logical (dtp, p, len);
               break;
 
 	    case GFC_DTYPE_CHARACTER:
-	      if (nml_delim)
-		write_character (nml_delim, 1);
-	      write_character (p, obj->string_length);
-	      if (nml_delim)
-		write_character (nml_delim, 1);
+	      if (dtp->u.p.nml_delim)
+		write_character (dtp, &dtp->u.p.nml_delim, 1);
+	      write_character (dtp, p, obj->string_length);
+	      if (dtp->u.p.nml_delim)
+		write_character (dtp, &dtp->u.p.nml_delim, 1);
               break;
 
 	    case GFC_DTYPE_REAL:
-              write_real (p, len);
+	      write_real (dtp, p, len);
               break;
 
 	    case GFC_DTYPE_COMPLEX:
-	      no_leading_blank = 0;
+	      dtp->u.p.no_leading_blank = 0;
 	      num++;
-              write_complex (p, len, obj_size);
+              write_complex (dtp, p, len, obj_size);
               break;
 
 	    case GFC_DTYPE_DERIVED:
@@ -1713,7 +1706,8 @@ nml_write_obj (namelist_info * obj, index_type offset,
 		   cmp && !strncmp (cmp->var_name, obj_name, obj_name_len);
 		   cmp = retval)
 		{
-		  retval = nml_write_obj (cmp, (index_type)(p - obj->mem_pos),
+		  retval = nml_write_obj (dtp, cmp,
+					  (index_type)(p - obj->mem_pos),
 					  obj, ext_name);
 		}
 
@@ -1722,19 +1716,19 @@ nml_write_obj (namelist_info * obj, index_type offset,
 	      goto obj_loop;
 
             default:
-              internal_error ("Bad type for namelist write");
+	      internal_error (&dtp->common, "Bad type for namelist write");
             }
 
 	  /* Reset the leading blank suppression, write a comma and, if 5
 	     values have been output, write a newline and advance to column
 	     2. Reset the repeat counter.  */
 
-	  no_leading_blank = 0;
-	  write_character (",", 1);
+	  dtp->u.p.no_leading_blank = 0;
+	  write_character (dtp, ",", 1);
 	  if (num > 5)
 	    {
 	      num = 0;
-	      write_character ("\n ", 2);
+	      write_character (dtp, "\n ", 2);
 	    }
 	  rep_ctr = 1;
 	}
@@ -1767,7 +1761,7 @@ obj_loop:
    the treatment of derived types.  */
 
 void
-namelist_write (void)
+namelist_write (st_parameter_dt *dtp)
 {
   namelist_info * t1, *t2, *dummy = NULL;
   index_type i;
@@ -1778,46 +1772,47 @@ namelist_write (void)
 
   /* Set the delimiter for namelist output.  */
 
-  tmp_delim = current_unit->flags.delim;
-  current_unit->flags.delim = DELIM_NONE;
+  tmp_delim = dtp->u.p.current_unit->flags.delim;
+  dtp->u.p.current_unit->flags.delim = DELIM_NONE;
   switch (tmp_delim)
     {
     case (DELIM_QUOTE):
-      nml_delim = "\"";
+      dtp->u.p.nml_delim = '"';
       break;
 
     case (DELIM_APOSTROPHE):
-      nml_delim = "'";
+      dtp->u.p.nml_delim = '\'';
       break;
 
     default:
-      nml_delim = NULL;
+      dtp->u.p.nml_delim = '\0';
+      break;
     }
 
-  write_character ("&",1);
+  write_character (dtp, "&", 1);
 
   /* Write namelist name in upper case - f95 std.  */
 
-  for (i = 0 ;i < ioparm.namelist_name_len ;i++ )
+  for (i = 0 ;i < dtp->namelist_name_len ;i++ )
     {
-      c = toupper (ioparm.namelist_name[i]);
-      write_character (&c ,1);
-	    }
+      c = toupper (dtp->namelist_name[i]);
+      write_character (dtp, &c ,1);
+    }
 
-  if (ionml != NULL)
+  if (dtp->u.p.ionml != NULL)
     {
-      t1 = ionml;
+      t1 = dtp->u.p.ionml;
       while (t1 != NULL)
 	{
 	  t2 = t1;
-	  t1 = nml_write_obj (t2, dummy_offset, dummy, dummy_name);
+	  t1 = nml_write_obj (dtp, t2, dummy_offset, dummy, dummy_name);
 	}
     }
-  write_character ("  /\n", 4);
+  write_character (dtp, "  /\n", 4);
 
   /* Recover the original delimiter.  */
 
-  current_unit->flags.delim = tmp_delim;
+  dtp->u.p.current_unit->flags.delim = tmp_delim;
 }
 
 #undef NML_DIGITS