Skip to content

R
riscv-gcc-1
Commit 5e805e44 by Jakub Jelinek Committed by Jakub Jelinek
Options

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

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

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

From-SVN: r107328
parent 9b92bf04
Showing with 991 additions and 390 deletions
gcc/fortran/ChangeLog
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
......
gcc/fortran/Make-lang.in
......@@ -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
......
gcc/fortran/dump-parse-tree.c
......@@ -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 ");
......
gcc/fortran/io.c
......@@ -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;
}
......
gcc/fortran/ioparm.def 0 → 100644
#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)
gcc/fortran/resolve.c
......@@ -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:
......
gcc/testsuite/ChangeLog
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
gcc/testsuite/gfortran.dg/inquire_9.f90 0 → 100644
! 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
gcc/testsuite/gfortran.fortran-torture/execute/inquire_5.f90 0 → 100644
! 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
libgfortran/Makefile.am
......@@ -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 \
......
libgfortran/Makefile.in
......@@ -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 \
......
libgfortran/acinclude.m4
......@@ -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],
......
libgfortran/config.h.in
......@@ -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
......
libgfortran/configure
......@@ -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
......
libgfortran/configure.ac
......@@ -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
......
libgfortran/intrinsics/flush.c
......@@ -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);
}
}
}
libgfortran/intrinsics/rand.c
/* Implementation of the IRAND, RAND, and SRAND intrinsics.
Copyright (C) 2004 Free Software Foundation, Inc.
Copyright (C) 2004, 2005 Free Software Foundation, Inc.
Contributed by Steven G. Kargl <kargls@comcast.net>.
This file is part of the GNU Fortran 95 runtime library (libgfortran).
......@@ -37,12 +37,18 @@ Boston, MA 02110-1301, USA. */
#include "config.h"
#include "libgfortran.h"
#include "../io/io.h"
#define GFC_RAND_A 16807
#define GFC_RAND_M 2147483647
#define GFC_RAND_M1 (GFC_RAND_M - 1)
static GFC_UINTEGER_8 rand_seed = 1;
#ifdef __GTHREAD_MUTEX_INIT
static __gthread_mutex_t rand_seed_lock = __GTHREAD_MUTEX_INIT;
#else
static __gthread_mutex_t rand_seed_lock;
#endif
/* Set the seed of the irand generator. Note 0 is a bad seed. */
......@@ -59,7 +65,9 @@ export_proto_np(PREFIX(srand));
void
PREFIX(srand) (GFC_INTEGER_4 *i)
{
__gthread_mutex_lock (&rand_seed_lock);
srand_internal (*i);
__gthread_mutex_unlock (&rand_seed_lock);
}
/* Return an INTEGER in the range [1,GFC_RAND_M-1]. */
......@@ -76,6 +84,8 @@ irand (GFC_INTEGER_4 *i)
else
j = 0;
__gthread_mutex_lock (&rand_seed_lock);
switch (j)
{
/* Return the next RN. */
......@@ -95,8 +105,11 @@ irand (GFC_INTEGER_4 *i)
}
rand_seed = GFC_RAND_A * rand_seed % GFC_RAND_M;
j = (GFC_INTEGER_4) rand_seed;
__gthread_mutex_unlock (&rand_seed_lock);
return (GFC_INTEGER_4) rand_seed;
return j;
}
iexport(irand);
......@@ -111,3 +124,11 @@ PREFIX(rand) (GFC_INTEGER_4 *i)
{
return normalize_r4_i4 (irand (i) - 1, GFC_RAND_M1 - 1);
}
#ifndef __GTHREAD_MUTEX_INIT
static void __attribute__((constructor))
init (void)
{
__GTHREAD_MUTEX_INIT_FUNCTION (&rand_seed_lock);
}
#endif
libgfortran/intrinsics/random.c
......@@ -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
libgfortran/intrinsics/system_clock.c
......@@ -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
......
libgfortran/intrinsics/tty.c
......@@ -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);
}
}
......
libgfortran/io/close.c
......@@ -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);
......
libgfortran/io/file_pos.c
......@@ -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 ();
......
libgfortran/io/lock.c
......@@ -33,53 +33,28 @@ Boston, MA 02110-1301, USA. */
#include "libgfortran.h"
#include "io.h"
st_parameter ioparm;
iexport_data(ioparm);
namelist_info *ionml;
global_t g;
/* library_start()-- Called with a library call is entered. */
void
library_start (void)
library_start (st_parameter_common *cmp)
{
if (g.in_library)
internal_error ("Recursive library calls not allowed");
/* The in_library flag indicates whether we're currently processing a
library call. Some calls leave immediately, but READ and WRITE
processing return control to the caller but are still considered to
stay within the library. */
g.in_library = 1;
if ((cmp->flags & IOPARM_HAS_IOSTAT) != 0)
*cmp->iostat = ERROR_OK;
if (ioparm.iostat != NULL)
*ioparm.iostat = ERROR_OK;
ioparm.library_return = LIBRARY_OK;
cmp->flags &= ~IOPARM_LIBRETURN_MASK;
}
/* library_end()-- Called when a library call is complete in order to
clean up for the next call. */
void
library_end (void)
free_ionml (st_parameter_dt *dtp)
{
int t;
namelist_info * t1, *t2;
g.in_library = 0;
filename = NULL;
line = 0;
t = ioparm.library_return;
/* Delete the namelist, if it exists. */
if (ionml != NULL)
if (dtp->u.p.ionml != NULL)
{
t1 = ionml;
t1 = dtp->u.p.ionml;
while (t1 != NULL)
{
t2 = t1;
......@@ -93,8 +68,5 @@ library_end (void)
free_mem (t2);
}
}
ionml = NULL;
memset (&ioparm, '\0', sizeof (ioparm));
ioparm.library_return = t;
dtp->u.p.ionml = NULL;
}
libgfortran/io/read.c
/* 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);
}
libgfortran/io/unix.c
......@@ -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)
......
libgfortran/io/unix.h 0 → 100644
/* 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);
libgfortran/libgfortran.h
......@@ -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);
......
libgfortran/libtool-version
......@@ -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
libgfortran/runtime/error.c
......@@ -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);
......
libgfortran/runtime/fpu.c
/* 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. */
......
libgfortran/runtime/pause.c
/* 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++));
......
libgfortran/runtime/stop.c
/* 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++));
......
libgfortran/runtime/string.c
......@@ -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;
}
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment