mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-01-19 13:14:52 +08:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source 
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
This commit is contained in:
Jakub Jelinek 2005-11-21 23:03:56 +01:00 committed by Jakub Jelinek
parent 9b92bf04bf
commit 5e805e44c0
43 changed files with 4203 additions and 2826 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

85
gcc/fortran/ChangeLog
View 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

3
gcc/fortran/Make-lang.in
View 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

7
gcc/fortran/dump-parse-tree.c
View 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 ");

13
gcc/fortran/io.c
View 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;
}

67
gcc/fortran/ioparm.def Normal file
View File

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

3
gcc/fortran/resolve.c
View 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:

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

File diff suppressed because it is too large Load Diff

8
gcc/testsuite/ChangeLog
View 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

24
gcc/testsuite/gfortran.dg/inquire_9.f90 Normal file
View File

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

32
gcc/testsuite/gfortran.fortran-torture/execute/inquire_5.f90 Normal file
View File

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

235
libgfortran/ChangeLog
View 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

4
libgfortran/Makefile.am
View 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 \

5
libgfortran/Makefile.in
View 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 \

38
libgfortran/acinclude.m4
View 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],

9
libgfortran/config.h.in
View File

@ -363,6 +363,9 @@
/* 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
@ -462,6 +465,9 @@
/* 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
@ -558,6 +564,9 @@
/* 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

160
libgfortran/configure vendored
View File

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

9
libgfortran/configure.ac
View 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

37
libgfortran/intrinsics/flush.c
View 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);
}
}
}

25
libgfortran/intrinsics/rand.c
View 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;
return (GFC_INTEGER_4) rand_seed;
__gthread_mutex_unlock (&rand_seed_lock);
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

73
libgfortran/intrinsics/random.c
View 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

131
libgfortran/intrinsics/system_clock.c
View 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

19
libgfortran/intrinsics/tty.c
View 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);
}
}

18
libgfortran/io/close.c
View 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);

96
libgfortran/io/file_pos.c
View 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 ();

484
libgfortran/io/format.c
View File

File diff suppressed because it is too large Load Diff

232
libgfortran/io/inquire.c
View 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 ();
}

480
libgfortran/io/io.h
View 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. */
/* 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. */
enum
{
LIBRARY_OK = 0,
LIBRARY_ERROR,
LIBRARY_END,
LIBRARY_EOR
}
library_return;
GFC_INTEGER_4 *iostat, *exist, *opened, *number, *named;
GFC_INTEGER_4 rec;
GFC_INTEGER_4 *nextrec, *size;
st_parameter_common common;
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);
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
CHARACTER2 (file);
CHARACTER1 (status);
CHARACTER2 (access);
CHARACTER1 (form);
CHARACTER2 (blank);
CHARACTER1 (position);
CHARACTER2 (action);
CHARACTER1 (delim);
CHARACTER2 (pad);
}
st_parameter;
st_parameter_open;
extern st_parameter ioparm;
iexport_data_proto(ioparm);
#define IOPARM_CLOSE_HAS_STATUS (1 << 7)
extern namelist_info * ionml;
internal_proto(ionml);
typedef struct
{
st_parameter_common common;
CHARACTER1 (status);
}
st_parameter_close;
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)
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;
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_dt;
#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

1056
libgfortran/io/list_read.c
View File

File diff suppressed because it is too large Load Diff

44
libgfortran/io/lock.c
View 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");
if ((cmp->flags & IOPARM_HAS_IOSTAT) != 0)
*cmp->iostat = ERROR_OK;
/* 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 (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;
}

286
libgfortran/io/open.c
View 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;
u->maxrec = max_offset / u->recl;
memmove (u->file, ioparm.file, ioparm.file_len);
u->file_len = ioparm.file_len;
memmove (u->file, opp->file, opp->file_len);
u->file_len = opp->file_len;
insert_unit (u);
/* 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,
action_opt, "Bad ACTION parameter in OPEN statement");
flags.blank = (ioparm.blank == NULL) ? BLANK_UNSPECIFIED :
find_option (ioparm.blank, ioparm.blank_len, blank_opt,
"Bad BLANK parameter in OPEN statement");
flags.blank = !(cf & IOPARM_OPEN_HAS_BLANK) ? BLANK_UNSPECIFIED :
find_option (&opp->common, opp->blank, opp->blank_len,
blank_opt, "Bad BLANK parameter in OPEN statement");
flags.delim = (ioparm.delim == NULL) ? DELIM_UNSPECIFIED :
find_option (ioparm.delim, ioparm.delim_len, delim_opt,
"Bad DELIM parameter in OPEN statement");
flags.delim = !(cf & IOPARM_OPEN_HAS_DELIM) ? DELIM_UNSPECIFIED :
find_option (&opp->common, opp->delim, opp->delim_len,
delim_opt, "Bad DELIM parameter in OPEN statement");
flags.pad = (ioparm.pad == NULL) ? PAD_UNSPECIFIED :
find_option (ioparm.pad, ioparm.pad_len, pad_opt,
"Bad PAD parameter in OPEN statement");
flags.pad = !(cf & IOPARM_OPEN_HAS_PAD) ? PAD_UNSPECIFIED :
find_option (&opp->common, opp->pad, opp->pad_len,
pad_opt, "Bad PAD parameter in OPEN statement");
flags.form = (ioparm.form == NULL) ? FORM_UNSPECIFIED :
find_option (ioparm.form, ioparm.form_len, form_opt,
"Bad FORM parameter in OPEN statement");
flags.form = !(cf & IOPARM_OPEN_HAS_FORM) ? FORM_UNSPECIFIED :
find_option (&opp->common, opp->form, opp->form_len,
form_opt, "Bad FORM parameter in OPEN statement");
flags.position = (ioparm.position == NULL) ? POSITION_UNSPECIFIED :
find_option (ioparm.position, ioparm.position_len, position_opt,
"Bad POSITION parameter in OPEN statement");
flags.position = !(cf & IOPARM_OPEN_HAS_POSITION) ? POSITION_UNSPECIFIED :
find_option (&opp->common, opp->position, opp->position_len,
position_opt, "Bad POSITION parameter in OPEN statement");
flags.status = (ioparm.status == NULL) ? STATUS_UNSPECIFIED :
find_option (ioparm.status, ioparm.status_len, status_opt,
"Bad STATUS parameter in OPEN statement");
flags.status = !(cf & IOPARM_OPEN_HAS_STATUS) ? STATUS_UNSPECIFIED :
find_option (&opp->common, opp->status, opp->status_len,
status_opt, "Bad STATUS parameter in OPEN statement");
if (ioparm.unit < 0)
generate_error (ERROR_BAD_OPTION, "Bad unit number in OPEN statement");
if (opp->common.unit < 0)
generate_error (&opp->common, ERROR_BAD_OPTION,
"Bad unit number in OPEN statement");
if (flags.position != POSITION_UNSPECIFIED
&& flags.access == ACCESS_DIRECT)
generate_error (ERROR_BAD_OPTION,
generate_error (&opp->common, ERROR_BAD_OPTION,
"Cannot use POSITION with direct access files");
if (flags.access == ACCESS_APPEND)
{
if (flags.position != POSITION_UNSPECIFIED
&& flags.position != POSITION_APPEND)
generate_error (ERROR_BAD_OPTION, "Conflicting ACCESS and POSITION "
"flags in OPEN statement");
generate_error (&opp->common, ERROR_BAD_OPTION,
"Conflicting ACCESS and POSITION flags in"
" OPEN statement");
notify_std (GFC_STD_GNU,
"Extension: APPEND as a value for ACCESS in OPEN statement");
flags.access = ACCESS_SEQUENTIAL;
@ -503,18 +556,19 @@ st_open (void)
if (flags.position == POSITION_UNSPECIFIED)
flags.position = POSITION_ASIS;
if (ioparm.library_return != LIBRARY_OK)
{
library_end ();
return;
}
if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
{
u = find_or_create_unit (opp->common.unit);
u = find_unit (ioparm.unit);
if (u == NULL)
new_unit (&flags);
else
already_open (u, &flags);
if (u->s == NULL)
{
u = new_unit (opp, u, &flags);
if (u != NULL)
unlock_unit (u);
}
else
already_open (opp, u, &flags);
}
library_end ();
}

92
libgfortran/io/read.c
View 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).
@ -80,7 +80,7 @@ set_integer (void *dest, GFC_INTEGER_LARGEST value, int length)
}
break;
default:
internal_error ("Bad integer kind");
internal_error (NULL, "Bad integer kind");
}
}
@ -119,7 +119,7 @@ max_value (int length, int signed_flag)
value = signed_flag ? 0x7f : 0xff;
break;
default:
internal_error ("Bad integer kind");
internal_error (NULL, "Bad integer kind");
}
return value;
@ -132,7 +132,7 @@ max_value (int length, int signed_flag)
* infinities. */
int
convert_real (void *dest, const char *buffer, int length)
convert_real (st_parameter_dt *dtp, void *dest, const char *buffer, int length)
{
errno = 0;
@ -172,12 +172,12 @@ convert_real (void *dest, const char *buffer, int length)
break;
#endif
default:
internal_error ("Unsupported real kind during IO");
internal_error (&dtp->common, "Unsupported real kind during IO");
}
if (errno != 0 && errno != EINVAL)
{
generate_error (ERROR_READ_VALUE,
generate_error (&dtp->common, ERROR_READ_VALUE,
"Range error during floating point read");
return 1;
}
@ -189,13 +189,13 @@ convert_real (void *dest, const char *buffer, int length)
/* read_l()-- Read a logical value */
void
read_l (fnode * f, char *dest, int length)
read_l (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
{
char *p;
int w;
w = f->u.w;
p = read_block (&w);
p = read_block (dtp, &w);
if (p == NULL)
return;
@ -225,7 +225,8 @@ read_l (fnode * f, char *dest, int length)
break;
default:
bad:
generate_error (ERROR_READ_VALUE, "Bad value on logical read");
generate_error (&dtp->common, ERROR_READ_VALUE,
"Bad value on logical read");
break;
}
}
@ -234,7 +235,7 @@ read_l (fnode * f, char *dest, int length)
/* read_a()-- Read a character record. This one is pretty easy. */
void
read_a (fnode * f, char *p, int length)
read_a (st_parameter_dt *dtp, const fnode *f, char *p, int length)
{
char *source;
int w, m, n;
@ -243,7 +244,7 @@ read_a (fnode * f, char *p, int length)
if (w == -1) /* '(A)' edit descriptor */
w = length;
source = read_block (&w);
source = read_block (dtp, &w);
if (source == NULL)
return;
if (w > length)
@ -278,7 +279,7 @@ eat_leading_spaces (int *width, char *p)
static char
next_char (char **p, int *w)
next_char (st_parameter_dt *dtp, char **p, int *w)
{
char c, *q;
@ -293,7 +294,7 @@ next_char (char **p, int *w)
if (c != ' ')
return c;
if (g.blank_status != BLANK_UNSPECIFIED)
if (dtp->u.p.blank_status != BLANK_UNSPECIFIED)
return ' '; /* return a blank to signal a null */
/* At this point, the rest of the field has to be trailing blanks */
@ -314,7 +315,7 @@ next_char (char **p, int *w)
* signed values. */
void
read_decimal (fnode * f, char *dest, int length)
read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
{
GFC_UINTEGER_LARGEST value, maxv, maxv_10;
GFC_INTEGER_LARGEST v;
@ -322,7 +323,7 @@ read_decimal (fnode * f, char *dest, int length)
char c, *p;
w = f->u.w;
p = read_block (&w);
p = read_block (dtp, &w);
if (p == NULL)
return;
@ -360,14 +361,14 @@ read_decimal (fnode * f, char *dest, int length)
for (;;)
{
c = next_char (&p, &w);
c = next_char (dtp, &p, &w);
if (c == '\0')
break;
if (c == ' ')
{
if (g.blank_status == BLANK_NULL) continue;
if (g.blank_status == BLANK_ZERO) c = '0';
if (dtp->u.p.blank_status == BLANK_NULL) continue;
if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
}
if (c < '0' || c > '9')
@ -392,11 +393,12 @@ read_decimal (fnode * f, char *dest, int length)
return;
bad:
generate_error (ERROR_READ_VALUE, "Bad value during integer read");
generate_error (&dtp->common, ERROR_READ_VALUE,
"Bad value during integer read");
return;
overflow:
generate_error (ERROR_READ_OVERFLOW,
generate_error (&dtp->common, ERROR_READ_OVERFLOW,
"Value overflowed during integer read");
return;
}
@ -408,7 +410,8 @@ read_decimal (fnode * f, char *dest, int length)
* the top bit is set, the value will be incorrect. */
void
read_radix (fnode * f, char *dest, int length, int radix)
read_radix (st_parameter_dt *dtp, const fnode *f, char *dest, int length,
int radix)
{
GFC_UINTEGER_LARGEST value, maxv, maxv_r;
GFC_INTEGER_LARGEST v;
@ -416,7 +419,7 @@ read_radix (fnode * f, char *dest, int length, int radix)
char c, *p;
w = f->u.w;
p = read_block (&w);
p = read_block (dtp, &w);
if (p == NULL)
return;
@ -454,13 +457,13 @@ read_radix (fnode * f, char *dest, int length, int radix)
for (;;)
{
c = next_char (&p, &w);
c = next_char (dtp, &p, &w);
if (c == '\0')
break;
if (c == ' ')
{
if (g.blank_status == BLANK_NULL) continue;
if (g.blank_status == BLANK_ZERO) c = '0';
if (dtp->u.p.blank_status == BLANK_NULL) continue;
if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
}
switch (radix)
@ -534,11 +537,12 @@ read_radix (fnode * f, char *dest, int length, int radix)
return;
bad:
generate_error (ERROR_READ_VALUE, "Bad value during integer read");
generate_error (&dtp->common, ERROR_READ_VALUE,
"Bad value during integer read");
return;
overflow:
generate_error (ERROR_READ_OVERFLOW,
generate_error (&dtp->common, ERROR_READ_OVERFLOW,
"Value overflowed during integer read");
return;
}
@ -551,7 +555,7 @@ read_radix (fnode * f, char *dest, int length, int radix)
the input. */
void
read_f (fnode * f, char *dest, int length)
read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
{
int w, seen_dp, exponent;
int exponent_sign, val_sign;
@ -560,11 +564,12 @@ read_f (fnode * f, char *dest, int length)
int i;
char *p, *buffer;
char *digits;
char scratch[SCRATCH_SIZE];
val_sign = 1;
seen_dp = 0;
w = f->u.w;
p = read_block (&w);
p = read_block (dtp, &w);
if (p == NULL)
return;
@ -648,11 +653,12 @@ read_f (fnode * f, char *dest, int length)
}
/* No exponent has been seen, so we use the current scale factor */
exponent = -g.scale_factor;
exponent = -dtp->u.p.scale_factor;
goto done;
bad_float:
generate_error (ERROR_READ_VALUE, "Bad value during floating point read");
generate_error (&dtp->common, ERROR_READ_VALUE,
"Bad value during floating point read");
return;
/* The value read is zero */
@ -680,7 +686,7 @@ read_f (fnode * f, char *dest, int length)
#endif
default:
internal_error ("Unsupported real kind during IO");
internal_error (&dtp->common, "Unsupported real kind during IO");
}
return;
@ -718,7 +724,7 @@ read_f (fnode * f, char *dest, int length)
p++;
w--;
if (g.blank_status == BLANK_UNSPECIFIED) /* Normal processing of exponent */
if (dtp->u.p.blank_status == BLANK_UNSPECIFIED) /* Normal processing of exponent */
{
while (w > 0 && isdigit (*p))
{
@ -743,8 +749,8 @@ read_f (fnode * f, char *dest, int length)
{
if (*p == ' ')
{
if (g.blank_status == BLANK_ZERO) *p = '0';
if (g.blank_status == BLANK_NULL)
if (dtp->u.p.blank_status == BLANK_ZERO) *p = '0';
if (dtp->u.p.blank_status == BLANK_NULL)
{
p++;
w--;
@ -803,8 +809,8 @@ read_f (fnode * f, char *dest, int length)
{
if (*digits == ' ')
{
if (g.blank_status == BLANK_ZERO) *digits = '0';
if (g.blank_status == BLANK_NULL)
if (dtp->u.p.blank_status == BLANK_ZERO) *digits = '0';
if (dtp->u.p.blank_status == BLANK_NULL)
{
digits++;
continue;
@ -818,7 +824,7 @@ read_f (fnode * f, char *dest, int length)
sprintf (p, "%d", exponent);
/* Do the actual conversion. */
convert_real (dest, buffer, length);
convert_real (dtp, dest, buffer, length);
if (buffer != scratch)
free_mem (buffer);
@ -831,12 +837,12 @@ read_f (fnode * f, char *dest, int length)
* and never look at it. */
void
read_x (int n)
read_x (st_parameter_dt *dtp, int n)
{
if ((current_unit->flags.pad == PAD_NO || is_internal_unit ())
&& current_unit->bytes_left < n)
n = current_unit->bytes_left;
if ((dtp->u.p.current_unit->flags.pad == PAD_NO || is_internal_unit (dtp))
&& dtp->u.p.current_unit->bytes_left < n)
n = dtp->u.p.current_unit->bytes_left;
if (n > 0)
read_block (&n);
read_block (dtp, &n);
}

1135
libgfortran/io/transfer.c
View File

File diff suppressed because it is too large Load Diff

287
libgfortran/io/unit.c
View File

@ -34,12 +34,55 @@ Boston, MA 02110-1301, USA. */
#include "io.h"
/* IO locking rules:
UNIT_LOCK is a master lock, protecting UNIT_ROOT tree and UNIT_CACHE.
Concurrent use of different units should be supported, so
each unit has its own lock, LOCK.
Open should be atomic with its reopening of units and list_read.c
in several places needs find_unit another unit while holding stdin
unit's lock, so it must be possible to acquire UNIT_LOCK while holding
some unit's lock. Therefore to avoid deadlocks, it is forbidden
to acquire unit's private locks while holding UNIT_LOCK, except
for freshly created units (where no other thread can get at their
address yet) or when using just trylock rather than lock operation.
In addition to unit's private lock each unit has a WAITERS counter
and CLOSED flag. WAITERS counter must be either only
atomically incremented/decremented in all places (if atomic builtins
are supported), or protected by UNIT_LOCK in all places (otherwise).
CLOSED flag must be always protected by unit's LOCK.
After finding a unit in UNIT_CACHE or UNIT_ROOT with UNIT_LOCK held,
WAITERS must be incremented to avoid concurrent close from freeing
the unit between unlocking UNIT_LOCK and acquiring unit's LOCK.
Unit freeing is always done under UNIT_LOCK. If close_unit sees any
WAITERS, it doesn't free the unit but instead sets the CLOSED flag
and the thread that decrements WAITERS to zero while CLOSED flag is
set is responsible for freeing it (while holding UNIT_LOCK).
flush_all_units operation is iterating over the unit tree with
increasing UNIT_NUMBER while holding UNIT_LOCK and attempting to
flush each unit (and therefore needs the unit's LOCK held as well).
To avoid deadlocks, it just trylocks the LOCK and if unsuccessful,
remembers the current unit's UNIT_NUMBER, unlocks UNIT_LOCK, acquires
unit's LOCK and after flushing reacquires UNIT_LOCK and restarts with
the smallest UNIT_NUMBER above the last one flushed.
If find_unit/find_or_create_unit/find_file/get_unit routines return
non-NULL, the returned unit has its private lock locked and when the
caller is done with it, it must call either unlock_unit or close_unit
on it. unlock_unit or close_unit must be always called only with the
private lock held. */
/* Subroutines related to units */
#define CACHE_SIZE 3
static gfc_unit internal_unit, *unit_cache[CACHE_SIZE];
gfc_offset max_offset;
gfc_unit *unit_root;
#ifdef __GTHREAD_MUTEX_INIT
__gthread_mutex_t unit_lock = __GTHREAD_MUTEX_INIT;
#else
__gthread_mutex_t unit_lock;
#endif
/* This implementation is based on Stefan Nilsson's article in the
* July 1997 Doctor Dobb's Journal, "Treaps in Java". */
@ -104,7 +147,7 @@ compare (int a, int b)
/* insert()-- Recursive insertion function. Returns the updated treap. */
static gfc_unit *
insert (gfc_unit * new, gfc_unit * t)
insert (gfc_unit *new, gfc_unit *t)
{
int c;
@ -128,20 +171,32 @@ insert (gfc_unit * new, gfc_unit * t)
}
if (c == 0)
internal_error ("insert(): Duplicate key found!");
internal_error (NULL, "insert(): Duplicate key found!");
return t;
}
/* insert_unit()-- Given a new node, insert it into the treap. It is
* an error to insert a key that already exists. */
/* insert_unit()-- Create a new node, insert it into the treap. */
void
insert_unit (gfc_unit * new)
static gfc_unit *
insert_unit (int n)
{
new->priority = pseudo_random ();
g.unit_root = insert (new, g.unit_root);
gfc_unit *u = get_mem (sizeof (gfc_unit));
memset (u, '\0', sizeof (gfc_unit));
u->unit_number = n;
#ifdef __GTHREAD_MUTEX_INIT
{
__gthread_mutex_t tmp = __GTHREAD_MUTEX_INIT;
u->lock = tmp;
}
#else
__GTHREAD_MUTEX_INIT_FUNCTION (&u->lock);
#endif
__gthread_mutex_lock (&u->lock);
u->priority = pseudo_random ();
unit_root = insert (u, unit_root);
return u;
}
@ -201,27 +256,30 @@ delete_treap (gfc_unit * old, gfc_unit * t)
static void
delete_unit (gfc_unit * old)
{
g.unit_root = delete_treap (old, g.unit_root);
unit_root = delete_treap (old, unit_root);
}
/* find_unit()-- Given an integer, return a pointer to the unit
* structure. Returns NULL if the unit does not exist. */
* structure. Returns NULL if the unit does not exist,
* otherwise returns a locked unit. */
gfc_unit *
find_unit (int n)
static gfc_unit *
find_unit_1 (int n, int do_create)
{
gfc_unit *p;
int c;
int c, created = 0;
__gthread_mutex_lock (&unit_lock);
retry:
for (c = 0; c < CACHE_SIZE; c++)
if (unit_cache[c] != NULL && unit_cache[c]->unit_number == n)
{
p = unit_cache[c];
return p;
goto found;
}
p = g.unit_root;
p = unit_root;
while (p != NULL)
{
c = compare (n, p->unit_number);
@ -233,6 +291,12 @@ find_unit (int n)
break;
}
if (p == NULL && do_create)
{
p = insert_unit (n);
created = 1;
}
if (p != NULL)
{
for (c = 0; c < CACHE_SIZE - 1; c++)
@ -241,35 +305,86 @@ find_unit (int n)
unit_cache[CACHE_SIZE - 1] = p;
}
if (created)
{
/* Newly created units have their lock held already
from insert_unit. Just unlock UNIT_LOCK and return. */
__gthread_mutex_unlock (&unit_lock);
return p;
}
found:
if (p != NULL)
{
/* Fast path. */
if (! __gthread_mutex_trylock (&p->lock))
{
/* assert (p->closed == 0); */
__gthread_mutex_unlock (&unit_lock);
return p;
}
inc_waiting_locked (p);
}
__gthread_mutex_unlock (&unit_lock);
if (p != NULL)
{
__gthread_mutex_lock (&p->lock);
if (p->closed)
{
__gthread_mutex_lock (&unit_lock);
__gthread_mutex_unlock (&p->lock);
if (predec_waiting_locked (p) == 0)
free_mem (p);
goto retry;
}
dec_waiting_unlocked (p);
}
return p;
}
gfc_unit *
find_unit (int n)
{
return find_unit_1 (n, 0);
}
gfc_unit *
find_or_create_unit (int n)
{
return find_unit_1 (n, 1);
}
/* get_unit()-- Returns the unit structure associated with the integer
* unit or the internal file. */
gfc_unit *
get_unit (int read_flag __attribute__ ((unused)))
get_unit (st_parameter_dt *dtp, int do_create)
{
if (ioparm.internal_unit != NULL)
if ((dtp->common.flags & IOPARM_DT_HAS_INTERNAL_UNIT) != 0)
{
internal_unit.recl = ioparm.internal_unit_len;
if (is_array_io())
{
internal_unit.rank = GFC_DESCRIPTOR_RANK(ioparm.internal_unit_desc);
internal_unit.ls = (array_loop_spec*)
get_mem (internal_unit.rank * sizeof (array_loop_spec));
ioparm.internal_unit_len *=
init_loop_spec (ioparm.internal_unit_desc, internal_unit.ls);
}
__gthread_mutex_lock (&internal_unit.lock);
internal_unit.recl = dtp->internal_unit_len;
if (is_array_io (dtp))
{
internal_unit.rank = GFC_DESCRIPTOR_RANK (dtp->internal_unit_desc);
internal_unit.ls = (array_loop_spec *)
get_mem (internal_unit.rank * sizeof (array_loop_spec));
dtp->internal_unit_len *=
init_loop_spec (dtp->internal_unit_desc, internal_unit.ls);
}
internal_unit.s =
open_internal (ioparm.internal_unit, ioparm.internal_unit_len);
open_internal (dtp->internal_unit, dtp->internal_unit_len);
internal_unit.bytes_left = internal_unit.recl;
internal_unit.last_record=0;
internal_unit.maxrec=0;
internal_unit.current_record=0;
if (g.mode==WRITING && !is_array_io())
if (dtp->u.p.mode==WRITING && !is_array_io (dtp))
empty_internal_buffer (internal_unit.s);
/* Set flags for the internal unit */
@ -284,25 +399,25 @@ get_unit (int read_flag __attribute__ ((unused)))
/* Has to be an external unit */
return find_unit (ioparm.unit);
return find_unit_1 (dtp->common.unit, do_create);
}
/* is_internal_unit()-- Determine if the current unit is internal or not */
int
is_internal_unit (void)
is_internal_unit (st_parameter_dt *dtp)
{
return current_unit == &internal_unit;
return dtp->u.p.current_unit == &internal_unit;
}
/* is_array_io ()-- Determine if the I/O is to/from an array */
int
is_array_io (void)
is_array_io (st_parameter_dt *dtp)
{
return (ioparm.internal_unit_desc != NULL);
return dtp->internal_unit_desc != NULL;
}
@ -315,12 +430,22 @@ init_units (void)
gfc_unit *u;
unsigned int i;
#ifndef __GTHREAD_MUTEX_INIT
__GTHREAD_MUTEX_INIT_FUNCTION (&unit_lock);
#endif
#ifdef __GTHREAD_MUTEX_INIT
{
__gthread_mutex_t tmp = __GTHREAD_MUTEX_INIT;
internal_unit.lock = tmp;
}
#else
__GTHREAD_MUTEX_INIT_FUNCTION (&internal_unit.lock);
#endif
if (options.stdin_unit >= 0)
{ /* STDIN */
u = get_mem (sizeof (gfc_unit));
memset (u, '\0', sizeof (gfc_unit));
u->unit_number = options.stdin_unit;
u = insert_unit (options.stdin_unit);
u->s = input_stream ();
u->flags.action = ACTION_READ;
@ -334,15 +459,12 @@ init_units (void)
u->recl = options.default_recl;
u->endfile = NO_ENDFILE;
insert_unit (u);
__gthread_mutex_unlock (&u->lock);
}
if (options.stdout_unit >= 0)
{ /* STDOUT */
u = get_mem (sizeof (gfc_unit));
memset (u, '\0', sizeof (gfc_unit));
u->unit_number = options.stdout_unit;
u = insert_unit (options.stdout_unit);
u->s = output_stream ();
u->flags.action = ACTION_WRITE;
@ -356,15 +478,12 @@ init_units (void)
u->recl = options.default_recl;
u->endfile = AT_ENDFILE;
insert_unit (u);
__gthread_mutex_unlock (&u->lock);
}
if (options.stderr_unit >= 0)
{ /* STDERR */
u = get_mem (sizeof (gfc_unit));
memset (u, '\0', sizeof (gfc_unit));
u->unit_number = options.stderr_unit;
u = insert_unit (options.stderr_unit);
u->s = error_stream ();
u->flags.action = ACTION_WRITE;
@ -378,7 +497,7 @@ init_units (void)
u->recl = options.default_recl;
u->endfile = AT_ENDFILE;
insert_unit (u);
__gthread_mutex_unlock (&u->lock);
}
/* Calculate the maximum file offset in a portable manner.
@ -386,40 +505,78 @@ init_units (void)
*
* set a 1 in the LSB and keep a running sum, stopping at MSB-1 bit. */
g.max_offset = 0;
for (i = 0; i < sizeof (g.max_offset) * 8 - 1; i++)
g.max_offset = g.max_offset + ((gfc_offset) 1 << i);
max_offset = 0;
for (i = 0; i < sizeof (max_offset) * 8 - 1; i++)
max_offset = max_offset + ((gfc_offset) 1 << i);
}
/* close_unit()-- Close a unit. The stream is closed, and any memory
* associated with the stream is freed. Returns nonzero on I/O error. */
int
close_unit (gfc_unit * u)
static int
close_unit_1 (gfc_unit *u, int locked)
{
int i, rc;
rc = (u->s == NULL) ? 0 : sclose (u->s) == FAILURE;
u->closed = 1;
if (!locked)
__gthread_mutex_lock (&unit_lock);
for (i = 0; i < CACHE_SIZE; i++)
if (unit_cache[i] == u)
unit_cache[i] = NULL;
rc = (u->s == NULL) ? 0 : sclose (u->s) == FAILURE;
delete_unit (u);
free_mem (u);
if (u->file)
free_mem (u->file);
u->file = NULL;
u->file_len = 0;
if (!locked)
__gthread_mutex_unlock (&u->lock);
/* If there are any threads waiting in find_unit for this unit,
avoid freeing the memory, the last such thread will free it
instead. */
if (u->waiting == 0)
free_mem (u);
if (!locked)
__gthread_mutex_unlock (&unit_lock);
return rc;
}
void
unlock_unit (gfc_unit *u)
{
__gthread_mutex_unlock (&u->lock);
}
/* close_unit()-- Close a unit. The stream is closed, and any memory
* associated with the stream is freed. Returns nonzero on I/O error.
* Should be called with the u->lock locked. */
int
close_unit (gfc_unit *u)
{
return close_unit_1 (u, 0);
}
/* close_units()-- Delete units on completion. We just keep deleting
* the root of the treap until there is nothing left. */
* the root of the treap until there is nothing left.
* Not sure what to do with locking here. Some other thread might be
* holding some unit's lock and perhaps hold it indefinitely
* (e.g. waiting for input from some pipe) and close_units shouldn't
* delay the program too much. */
void
close_units (void)
{
while (g.unit_root != NULL)
close_unit (g.unit_root);
__gthread_mutex_lock (&unit_lock);
while (unit_root != NULL)
close_unit_1 (unit_root, 1);
__gthread_mutex_unlock (&unit_lock);
}

215
libgfortran/io/unix.c
View File

@ -45,6 +45,7 @@ Boston, MA 02110-1301, USA. */
#include "libgfortran.h"
#include "io.h"
#include "unix.h"
#ifndef SSIZE_MAX
#define SSIZE_MAX SHRT_MAX
@ -116,35 +117,6 @@ Boston, MA 02110-1301, USA. */
* 'where' parameter and use the current file pointer. */
#define BUFFER_SIZE 8192
typedef struct
{
stream st;
int fd;
gfc_offset buffer_offset; /* File offset of the start of the buffer */
gfc_offset physical_offset; /* Current physical file offset */
gfc_offset logical_offset; /* Current logical file offset */
gfc_offset dirty_offset; /* Start of modified bytes in buffer */
gfc_offset file_length; /* Length of the file, -1 if not seekable. */
char *buffer;
int len; /* Physical length of the current buffer */
int active; /* Length of valid bytes in the buffer */
int prot;
int ndirty; /* Dirty bytes starting at dirty_offset */
int special_file; /* =1 if the fd refers to a special file */
unsigned unbuffered:1;
char small_buffer[BUFFER_SIZE];
}
unix_stream;
/*move_pos_offset()-- Move the record pointer right or left
*relative to current position */
@ -998,15 +970,18 @@ fd_to_stream (int fd, int prot)
/* Given the Fortran unit number, convert it to a C file descriptor. */
int
unit_to_fd(int unit)
unit_to_fd (int unit)
{
gfc_unit *us;
int fd;
us = find_unit(unit);
us = find_unit (unit);
if (us == NULL)
return -1;
return ((unix_stream *) us->s)->fd;
fd = ((unix_stream *) us->s)->fd;
unlock_unit (us);
return fd;
}
@ -1032,11 +1007,11 @@ unpack_filename (char *cstring, const char *fstring, int len)
* open it. mkstemp() opens the file for reading and writing, but the
* library mode prevents anything that is not allowed. The descriptor
* is returned, which is -1 on error. The template is pointed to by
* ioparm.file, which is copied into the unit structure
* opp->file, which is copied into the unit structure
* and freed later. */
static int
tempfile (void)
tempfile (st_parameter_open *opp)
{
const char *tempdir;
char *template;
@ -1078,8 +1053,8 @@ tempfile (void)
free_mem (template);
else
{
ioparm.file = template;
ioparm.file_len = strlen (template); /* Don't include trailing nul */
opp->file = template;
opp->file_len = strlen (template); /* Don't include trailing nul */
}
return fd;
@ -1092,7 +1067,7 @@ tempfile (void)
* Returns the descriptor, which is less than zero on error. */
static int
regular_file (unit_flags *flags)
regular_file (st_parameter_open *opp, unit_flags *flags)
{
char path[PATH_MAX + 1];
int mode;
@ -1100,7 +1075,7 @@ regular_file (unit_flags *flags)
int crflag;
int fd;
if (unpack_filename (path, ioparm.file, ioparm.file_len))
if (unpack_filename (path, opp->file, opp->file_len))
{
errno = ENOENT; /* Fake an OS error */
return -1;
@ -1124,7 +1099,7 @@ regular_file (unit_flags *flags)
break;
default:
internal_error ("regular_file(): Bad action");
internal_error (&opp->common, "regular_file(): Bad action");
}
switch (flags->status)
@ -1147,7 +1122,7 @@ regular_file (unit_flags *flags)
break;
default:
internal_error ("regular_file(): Bad status");
internal_error (&opp->common, "regular_file(): Bad status");
}
/* rwflag |= O_LARGEFILE; */
@ -1198,26 +1173,27 @@ regular_file (unit_flags *flags)
* Returns NULL on operating system error. */
stream *
open_external (unit_flags *flags)
open_external (st_parameter_open *opp, unit_flags *flags)
{
int fd, prot;
if (flags->status == STATUS_SCRATCH)
{
fd = tempfile ();
fd = tempfile (opp);
if (flags->action == ACTION_UNSPECIFIED)
flags->action = ACTION_READWRITE;
#if HAVE_UNLINK_OPEN_FILE
/* We can unlink scratch files now and it will go away when closed. */
unlink (ioparm.file);
if (fd >= 0)
unlink (opp->file);
#endif
}
else
{
/* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
* if it succeeds */
fd = regular_file (flags);
fd = regular_file (opp, flags);
}
if (fd < 0)
@ -1239,7 +1215,7 @@ open_external (unit_flags *flags)
break;
default:
internal_error ("open_external(): Bad action");
internal_error (&opp->common, "open_external(): Bad action");
}
return fd_to_stream (fd, prot);
@ -1281,21 +1257,19 @@ error_stream (void)
* corrupted. */
stream *
init_error_stream (void)
init_error_stream (unix_stream *error)
{
static unix_stream error;
memset (error, '\0', sizeof (*error));
memset (&error, '\0', sizeof (error));
error->fd = options.use_stderr ? STDERR_FILENO : STDOUT_FILENO;
error.fd = options.use_stderr ? STDERR_FILENO : STDOUT_FILENO;
error->st.alloc_w_at = (void *) fd_alloc_w_at;
error->st.sfree = (void *) fd_sfree;
error.st.alloc_w_at = (void *) fd_alloc_w_at;
error.st.sfree = (void *) fd_sfree;
error->unbuffered = 1;
error->buffer = error->small_buffer;
error.unbuffered = 1;
error.buffer = error.small_buffer;
return (stream *) & error;
return (stream *) error;
}
@ -1332,33 +1306,39 @@ compare_file_filename (gfc_unit *u, const char *name, int len)
}
#ifdef HAVE_WORKING_STAT
# define FIND_FILE0_DECL struct stat *st
# define FIND_FILE0_ARGS st
#else
# define FIND_FILE0_DECL const char *file, gfc_charlen_type file_len
# define FIND_FILE0_ARGS file, file_len
#endif
/* find_file0()-- Recursive work function for find_file() */
static gfc_unit *
find_file0 (gfc_unit * u, struct stat *st1)
find_file0 (gfc_unit *u, FIND_FILE0_DECL)
{
#ifdef HAVE_WORKING_STAT
struct stat st2;
#endif
gfc_unit *v;
if (u == NULL)
return NULL;
#ifdef HAVE_WORKING_STAT
if (fstat (((unix_stream *) u->s)->fd, &st2) >= 0 &&
st1->st_dev == st2.st_dev && st1->st_ino == st2.st_ino)
if (u->s != NULL
&& fstat (((unix_stream *) u->s)->fd, &st[1]) >= 0 &&
st[0].st_dev == st[1].st_dev && st[0].st_ino == st[1].st_ino)
return u;
#else
if (compare_string(u->file_len, u->file, ioparm.file_len, ioparm.file) == 0)
if (compare_string (u->file_len, u->file, file_len, file) == 0)
return u;
#endif
v = find_file0 (u->left, st1);
v = find_file0 (u->left, FIND_FILE0_ARGS);
if (v != NULL)
return v;
v = find_file0 (u->right, st1);
v = find_file0 (u->right, FIND_FILE0_ARGS);
if (v != NULL)
return v;
@ -1370,18 +1350,111 @@ find_file0 (gfc_unit * u, struct stat *st1)
* that has the file already open. Returns a pointer to the unit if so. */
gfc_unit *
find_file (void)
find_file (const char *file, gfc_charlen_type file_len)
{
char path[PATH_MAX + 1];
struct stat statbuf;
struct stat st[2];
gfc_unit *u;
if (unpack_filename (path, ioparm.file, ioparm.file_len))
if (unpack_filename (path, file, file_len))
return NULL;
if (stat (path, &statbuf) < 0)
if (stat (path, &st[0]) < 0)
return NULL;
return find_file0 (g.unit_root, &statbuf);
__gthread_mutex_lock (&unit_lock);
retry:
u = find_file0 (unit_root, FIND_FILE0_ARGS);
if (u != NULL)
{
/* Fast path. */
if (! __gthread_mutex_trylock (&u->lock))
{
/* assert (u->closed == 0); */
__gthread_mutex_unlock (&unit_lock);
return u;
}
inc_waiting_locked (u);
}
__gthread_mutex_unlock (&unit_lock);
if (u != NULL)
{
__gthread_mutex_lock (&u->lock);
if (u->closed)
{
__gthread_mutex_lock (&unit_lock);
__gthread_mutex_unlock (&u->lock);
if (predec_waiting_locked (u) == 0)
free_mem (u);
goto retry;
}
dec_waiting_unlocked (u);
}
return u;
}
static gfc_unit *
flush_all_units_1 (gfc_unit *u, int min_unit)
{
while (u != NULL)
{
if (u->unit_number > min_unit)
{
gfc_unit *r = flush_all_units_1 (u->left, min_unit);
if (r != NULL)
return r;
}
if (u->unit_number >= min_unit)
{
if (__gthread_mutex_trylock (&u->lock))
return u;
if (u->s)
flush (u->s);
__gthread_mutex_unlock (&u->lock);
}
u = u->right;
}
return NULL;
}
void
flush_all_units (void)
{
gfc_unit *u;
int min_unit = 0;
__gthread_mutex_lock (&unit_lock);
do
{
u = flush_all_units_1 (unit_root, min_unit);
if (u != NULL)
inc_waiting_locked (u);
__gthread_mutex_unlock (&unit_lock);
if (u == NULL)
return;
__gthread_mutex_lock (&u->lock);
min_unit = u->unit_number + 1;
if (u->closed == 0)
{
flush (u->s);
__gthread_mutex_lock (&unit_lock);
__gthread_mutex_unlock (&u->lock);
(void) predec_waiting_locked (u);
}
else
{
__gthread_mutex_lock (&unit_lock);
__gthread_mutex_unlock (&u->lock);
if (predec_waiting_locked (u) == 0)
free_mem (u);
}
}
while (1);
}
@ -1441,12 +1514,12 @@ delete_file (gfc_unit * u)
* the system */
int
file_exists (void)
file_exists (const char *file, gfc_charlen_type file_len)
{
char path[PATH_MAX + 1];
struct stat statbuf;
if (unpack_filename (path, ioparm.file, ioparm.file_len))
if (unpack_filename (path, file, file_len))
return 0;
if (stat (path, &statbuf) < 0)

63
libgfortran/io/unix.h Normal file
View File

@ -0,0 +1,63 @@
/* Copyright (C) 2002, 2003, 2004, 2005
Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of the GNU Fortran 95 runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file. (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with Libgfortran; see the file COPYING. If not, write to
the Free Software Foundation, 51 Franklin Street, Fifth Floor,
Boston, MA 02110-1301, USA. */
/* Unix stream I/O module */
#define BUFFER_SIZE 8192
typedef struct
{
stream st;
int fd;
gfc_offset buffer_offset; /* File offset of the start of the buffer */
gfc_offset physical_offset; /* Current physical file offset */
gfc_offset logical_offset; /* Current logical file offset */
gfc_offset dirty_offset; /* Start of modified bytes in buffer */
gfc_offset file_length; /* Length of the file, -1 if not seekable. */
char *buffer;
int len; /* Physical length of the current buffer */
int active; /* Length of valid bytes in the buffer */
int prot;
int ndirty; /* Dirty bytes starting at dirty_offset */
int special_file; /* =1 if the fd refers to a special file */
unsigned unbuffered:1;
char small_buffer[BUFFER_SIZE];
}
unix_stream;
extern stream *init_error_stream (unix_stream *);
internal_proto(init_error_stream);

317
libgfortran/io/write.c
View File

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

16
libgfortran/libgfortran.h
View File

@ -437,11 +437,11 @@ iexport_data_proto(filename);
extern void stupid_function_name_for_static_linking (void);
internal_proto(stupid_function_name_for_static_linking);
extern void library_start (void);
struct st_parameter_common;
extern void library_start (struct st_parameter_common *);
internal_proto(library_start);
extern void library_end (void);
internal_proto(library_end);
#define library_end()
extern void set_args (int, char **);
export_proto(set_args);
@ -465,13 +465,14 @@ internal_proto(xtoa);
extern void os_error (const char *) __attribute__ ((noreturn));
internal_proto(os_error);
extern void show_locus (void);
extern void show_locus (struct st_parameter_common *);
internal_proto(show_locus);
extern void runtime_error (const char *) __attribute__ ((noreturn));
iexport_proto(runtime_error);
extern void internal_error (const char *) __attribute__ ((noreturn));
extern void internal_error (struct st_parameter_common *, const char *)
__attribute__ ((noreturn));
internal_proto(internal_error);
extern const char *get_oserror (void);
@ -491,7 +492,7 @@ internal_proto(st_sprintf);
extern const char *translate_error (int);
internal_proto(translate_error);
extern void generate_error (int, const char *);
extern void generate_error (struct st_parameter_common *, int, const char *);
internal_proto(generate_error);
/* fpu.c */
@ -526,7 +527,8 @@ internal_proto(show_variables);
/* string.c */
extern int find_option (const char *, int, const st_option *, const char *);
extern int find_option (struct st_parameter_common *, const char *, int,
const st_option *, const char *);
internal_proto(find_option);
extern int fstrlen (const char *, int);

2
libgfortran/libtool-version
View File

@ -3,4 +3,4 @@
# This is a separate file so that version updates don't involve re-running
# automake.
# CURRENT:REVISION:AGE
0:0:0
1:0:0

58
libgfortran/runtime/error.c
View File

@ -37,6 +37,7 @@ Boston, MA 02110-1301, USA. */
#include "libgfortran.h"
#include "../io/io.h"
#include "../io/unix.h"
/* Error conditions. The tricky part here is printing a message when
* it is the I/O subsystem that is severely wounded. Our goal is to
@ -53,17 +54,6 @@ Boston, MA 02110-1301, USA. */
* Other error returns are reserved for the STOP statement with a numeric code.
*/
/* locus variables. These are optionally set by a caller before a
* library subroutine is called. They are always cleared on exit so
* that files that report loci and those that do not can be linked
* together without reporting an erroneous position. */
char *filename = 0;
iexport_data(filename);
unsigned line = 0;
iexport_data(line);
/* gfc_itoa()-- Integer to decimal conversion. */
const char *
@ -145,9 +135,10 @@ st_printf (const char *format, ...)
const char *q;
stream *s;
char itoa_buf[GFC_ITOA_BUF_SIZE];
unix_stream err_stream;
total = 0;
s = init_error_stream ();
s = init_error_stream (&err_stream);
va_start (arg, format);
for (;;)
@ -288,12 +279,12 @@ st_sprintf (char *buffer, const char *format, ...)
* something went wrong */
void
show_locus (void)
show_locus (st_parameter_common *cmp)
{
if (!options.locus || filename == NULL)
if (!options.locus || cmp == NULL || cmp->filename == NULL)
return;
st_printf ("At line %d of file %s\n", line, filename);
st_printf ("At line %d of file %s\n", cmp->line, cmp->filename);
}
@ -324,7 +315,6 @@ void
os_error (const char *message)
{
recursion_check ();
show_locus ();
st_printf ("Operating system error: %s\n%s\n", get_oserror (), message);
sys_exit (1);
}
@ -337,7 +327,6 @@ void
runtime_error (const char *message)
{
recursion_check ();
show_locus ();
st_printf ("Fortran runtime error: %s\n", message);
sys_exit (2);
}
@ -348,10 +337,10 @@ iexport(runtime_error);
* that indicate something deeply wrong. */
void
internal_error (const char *message)
internal_error (st_parameter_common *cmp, const char *message)
{
recursion_check ();
show_locus ();
show_locus (cmp);
st_printf ("Internal Error: %s\n", message);
/* This function call is here to get the main.o object file included
@ -452,48 +441,52 @@ translate_error (int code)
* the most recent operating system error is used. */
void
generate_error (int family, const char *message)
generate_error (st_parameter_common *cmp, int family, const char *message)
{
/* Set the error status. */
if (ioparm.iostat != NULL)
*ioparm.iostat = family;
if ((cmp->flags & IOPARM_HAS_IOSTAT))
*cmp->iostat = family;
if (message == NULL)
message =
(family == ERROR_OS) ? get_oserror () : translate_error (family);
if (ioparm.iomsg)
cf_strcpy (ioparm.iomsg, ioparm.iomsg_len, message);
if (cmp->flags & IOPARM_HAS_IOMSG)
cf_strcpy (cmp->iomsg, cmp->iomsg_len, message);
/* Report status back to the compiler. */
cmp->flags &= ~IOPARM_LIBRETURN_MASK;
switch (family)
{
case ERROR_EOR:
ioparm.library_return = LIBRARY_EOR;
if (ioparm.eor != 0)
cmp->flags |= IOPARM_LIBRETURN_EOR;
if ((cmp->flags & IOPARM_EOR))
return;
break;
case ERROR_END:
ioparm.library_return = LIBRARY_END;
if (ioparm.end != 0)
cmp->flags |= IOPARM_LIBRETURN_END;
if ((cmp->flags & IOPARM_END))
return;
break;
default:
ioparm.library_return = LIBRARY_ERROR;
if (ioparm.err != 0)
cmp->flags |= IOPARM_LIBRETURN_ERROR;
if ((cmp->flags & IOPARM_ERR))
return;
break;
}
/* Return if the user supplied an iostat variable. */
if (ioparm.iostat != NULL)
if ((cmp->flags & IOPARM_HAS_IOSTAT))
return;
/* Terminate the program */
runtime_error (message);
recursion_check ();
show_locus (cmp);
st_printf ("Fortran runtime error: %s\n", message);
sys_exit (2);
}
@ -511,7 +504,6 @@ notify_std (int std, const char * message)
if ((compile_options.allow_std & std) != 0 && !warning)
return SUCCESS;
show_locus ();
if (!warning)
{
st_printf ("Fortran runtime error: %s\n", message);

5
libgfortran/runtime/fpu.c
View File

@ -1,8 +1,3 @@
/* This is needed for fpu-glibc.h, before all other includes */
#ifdef HAVE_FENV_H
#define _GNU_SOURCE
#endif
#include "libgfortran.h"
/* We include the platform-dependent code. */

6
libgfortran/runtime/pause.c
View File

@ -1,5 +1,5 @@
/* Implementation of the STOP statement.
Copyright 2002 Free Software Foundation, Inc.
Copyright 2002, 2005 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
This file is part of the GNU Fortran 95 runtime library (libgfortran).
@ -55,8 +55,6 @@ export_proto(pause_numeric);
void
pause_numeric (GFC_INTEGER_4 code)
{
show_locus ();
if (code == -1)
st_printf ("PAUSE\n");
else
@ -71,8 +69,6 @@ export_proto(pause_string);
void
pause_string (char *string, GFC_INTEGER_4 len)
{
show_locus ();
st_printf ("PAUSE ");
while (len--)
st_printf ("%c", *(string++));

6
libgfortran/runtime/stop.c
View File

@ -1,5 +1,5 @@
/* Implementation of the STOP statement.
Copyright 2002 Free Software Foundation, Inc.
Copyright 2002, 2005 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
This file is part of the GNU Fortran 95 runtime library (libgfortran).
@ -37,8 +37,6 @@ Boston, MA 02110-1301, USA. */
void
stop_numeric (GFC_INTEGER_4 code)
{
show_locus ();
if (code == -1)
code = 0;
else
@ -55,8 +53,6 @@ export_proto(stop_string);
void
stop_string (const char *string, GFC_INTEGER_4 len)
{
show_locus ();
st_printf ("STOP ");
while (len--)
st_printf ("%c", *(string++));

8
libgfortran/runtime/string.c
View File

@ -31,7 +31,7 @@ Boston, MA 02110-1301, USA. */
#include <string.h>
#include "libgfortran.h"
#include "../io/io.h"
/* Compare a C-style string with a fortran style string in a case-insensitive
manner. Used for decoding string options to various statements. Returns
@ -104,14 +104,14 @@ cf_strcpy (char *dest, int dest_len, const char *src)
if no default is provided. */
int
find_option (const char *s1, int s1_len, const st_option * opts,
const char *error_message)
find_option (st_parameter_common *cmp, const char *s1, int s1_len,
const st_option * opts, const char *error_message)
{
for (; opts->name; opts++)
if (compare0 (s1, s1_len, opts->name))
return opts->value;
generate_error (ERROR_BAD_OPTION, error_message);
generate_error (cmp, ERROR_BAD_OPTION, error_message);
return -1;
}