From 60c514ba498cf233e786eea1bae3b77af2ee4356 Mon Sep 17 00:00:00 2001 From: jakub Date: Mon, 21 Nov 2005 22:03:56 +0000 Subject: 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. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@107328 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 85 ++ gcc/fortran/Make-lang.in | 3 +- gcc/fortran/dump-parse-tree.c | 7 +- gcc/fortran/io.c | 13 +- gcc/fortran/ioparm.def | 67 ++ gcc/fortran/resolve.c | 3 + gcc/fortran/trans-io.c | 1092 +++++++++++--------- gcc/testsuite/ChangeLog | 8 + gcc/testsuite/gfortran.dg/inquire_9.f90 | 24 + .../gfortran.fortran-torture/execute/inquire_5.f90 | 32 + 10 files changed, 852 insertions(+), 482 deletions(-) create mode 100644 gcc/fortran/ioparm.def create mode 100644 gcc/testsuite/gfortran.dg/inquire_9.f90 create mode 100644 gcc/testsuite/gfortran.fortran-torture/execute/inquire_5.f90 (limited to 'gcc') diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 355430d553a..4a124d3b3ad 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,88 @@ +2005-11-21 Jakub Jelinek + + 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 PR fortran/24223 diff --git a/gcc/fortran/Make-lang.in b/gcc/fortran/Make-lang.in index 96b6e252110..5d3a0e0ef5f 100644 --- a/gcc/fortran/Make-lang.in +++ b/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 diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index 7d2b26d2d72..499e1fa22e5 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/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 "); diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c index 183948e5788..26c335688fc 100644 --- a/gcc/fortran/io.c +++ b/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; } diff --git a/gcc/fortran/ioparm.def b/gcc/fortran/ioparm.def new file mode 100644 index 00000000000..9ca0cf659b1 --- /dev/null +++ b/gcc/fortran/ioparm.def @@ -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) diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index cb9c65bee7b..c543a956369 100644 --- a/gcc/fortran/resolve.c +++ b/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: diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index bdfa450dc2a..720ff5858e0 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -38,351 +38,403 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA /* Members of the ioparm structure. */ -static GTY(()) tree ioparm_unit; -static GTY(()) tree ioparm_err; -static GTY(()) tree ioparm_end; -static GTY(()) tree ioparm_eor; -static GTY(()) tree ioparm_list_format; -static GTY(()) tree ioparm_library_return; -static GTY(()) tree ioparm_iostat; -static GTY(()) tree ioparm_exist; -static GTY(()) tree ioparm_opened; -static GTY(()) tree ioparm_number; -static GTY(()) tree ioparm_named; -static GTY(()) tree ioparm_rec; -static GTY(()) tree ioparm_nextrec; -static GTY(()) tree ioparm_size; -static GTY(()) tree ioparm_recl_in; -static GTY(()) tree ioparm_recl_out; -static GTY(()) tree ioparm_iolength; -static GTY(()) tree ioparm_file; -static GTY(()) tree ioparm_file_len; -static GTY(()) tree ioparm_status; -static GTY(()) tree ioparm_status_len; -static GTY(()) tree ioparm_access; -static GTY(()) tree ioparm_access_len; -static GTY(()) tree ioparm_form; -static GTY(()) tree ioparm_form_len; -static GTY(()) tree ioparm_blank; -static GTY(()) tree ioparm_blank_len; -static GTY(()) tree ioparm_position; -static GTY(()) tree ioparm_position_len; -static GTY(()) tree ioparm_action; -static GTY(()) tree ioparm_action_len; -static GTY(()) tree ioparm_delim; -static GTY(()) tree ioparm_delim_len; -static GTY(()) tree ioparm_pad; -static GTY(()) tree ioparm_pad_len; -static GTY(()) tree ioparm_format; -static GTY(()) tree ioparm_format_len; -static GTY(()) tree ioparm_advance; -static GTY(()) tree ioparm_advance_len; -static GTY(()) tree ioparm_name; -static GTY(()) tree ioparm_name_len; -static GTY(()) tree ioparm_internal_unit; -static GTY(()) tree ioparm_internal_unit_len; -static GTY(()) tree ioparm_internal_unit_desc; -static GTY(()) tree ioparm_sequential; -static GTY(()) tree ioparm_sequential_len; -static GTY(()) tree ioparm_direct; -static GTY(()) tree ioparm_direct_len; -static GTY(()) tree ioparm_formatted; -static GTY(()) tree ioparm_formatted_len; -static GTY(()) tree ioparm_unformatted; -static GTY(()) tree ioparm_unformatted_len; -static GTY(()) tree ioparm_read; -static GTY(()) tree ioparm_read_len; -static GTY(()) tree ioparm_write; -static GTY(()) tree ioparm_write_len; -static GTY(()) tree ioparm_readwrite; -static GTY(()) tree ioparm_readwrite_len; -static GTY(()) tree ioparm_namelist_name; -static GTY(()) tree ioparm_namelist_name_len; -static GTY(()) tree ioparm_namelist_read_mode; -static GTY(()) tree ioparm_iomsg; -static GTY(()) tree ioparm_iomsg_len; - -/* The global I/O variables */ - -static GTY(()) tree ioparm_var; -static GTY(()) tree locus_file; -static GTY(()) tree locus_line; +enum ioparam_type +{ + IOPARM_ptype_common, + IOPARM_ptype_open, + IOPARM_ptype_close, + IOPARM_ptype_filepos, + IOPARM_ptype_inquire, + IOPARM_ptype_dt, + IOPARM_ptype_num +}; + +enum iofield_type +{ + IOPARM_type_int4, + IOPARM_type_pint4, + IOPARM_type_pchar, + IOPARM_type_parray, + IOPARM_type_pad, + IOPARM_type_char1, + IOPARM_type_char2, + IOPARM_type_common, + IOPARM_type_num +}; + +typedef struct gfc_st_parameter_field GTY(()) +{ + const char *name; + unsigned int mask; + enum ioparam_type param_type; + enum iofield_type type; + tree field; + tree field_len; +} +gfc_st_parameter_field; +typedef struct gfc_st_parameter GTY(()) +{ + const char *name; + tree type; +} +gfc_st_parameter; + +enum iofield +{ +#define IOPARM(param_type, name, mask, type) IOPARM_##param_type##_##name, +#include "ioparm.def" +#undef IOPARM + IOPARM_field_num +}; + +static GTY(()) gfc_st_parameter st_parameter[] = +{ + { "common", NULL }, + { "open", NULL }, + { "close", NULL }, + { "filepos", NULL }, + { "inquire", NULL }, + { "dt", NULL } +}; + +static GTY(()) gfc_st_parameter_field st_parameter_field[] = +{ +#define IOPARM(param_type, name, mask, type) \ + { #name, mask, IOPARM_ptype_##param_type, IOPARM_type_##type, NULL, NULL }, +#include "ioparm.def" +#undef IOPARM + { NULL, 0, 0, 0, NULL, NULL } +}; /* Library I/O subroutines */ -static GTY(()) tree iocall_read; -static GTY(()) tree iocall_read_done; -static GTY(()) tree iocall_write; -static GTY(()) tree iocall_write_done; -static GTY(()) tree iocall_x_integer; -static GTY(()) tree iocall_x_logical; -static GTY(()) tree iocall_x_character; -static GTY(()) tree iocall_x_real; -static GTY(()) tree iocall_x_complex; -static GTY(()) tree iocall_x_array; -static GTY(()) tree iocall_open; -static GTY(()) tree iocall_close; -static GTY(()) tree iocall_inquire; -static GTY(()) tree iocall_iolength; -static GTY(()) tree iocall_iolength_done; -static GTY(()) tree iocall_rewind; -static GTY(()) tree iocall_backspace; -static GTY(()) tree iocall_endfile; -static GTY(()) tree iocall_flush; -static GTY(()) tree iocall_set_nml_val; -static GTY(()) tree iocall_set_nml_val_dim; +enum iocall +{ + IOCALL_READ, + IOCALL_READ_DONE, + IOCALL_WRITE, + IOCALL_WRITE_DONE, + IOCALL_X_INTEGER, + IOCALL_X_LOGICAL, + IOCALL_X_CHARACTER, + IOCALL_X_REAL, + IOCALL_X_COMPLEX, + IOCALL_X_ARRAY, + IOCALL_OPEN, + IOCALL_CLOSE, + IOCALL_INQUIRE, + IOCALL_IOLENGTH, + IOCALL_IOLENGTH_DONE, + IOCALL_REWIND, + IOCALL_BACKSPACE, + IOCALL_ENDFILE, + IOCALL_FLUSH, + IOCALL_SET_NML_VAL, + IOCALL_SET_NML_VAL_DIM, + IOCALL_NUM +}; + +static GTY(()) tree iocall[IOCALL_NUM]; /* Variable for keeping track of what the last data transfer statement was. Used for deciding which subroutine to call when the data transfer is complete. */ static enum { READ, WRITE, IOLENGTH } last_dt; -#define ADD_FIELD(name, type) \ - ioparm_ ## name = gfc_add_field_to_struct \ - (&(TYPE_FIELDS (ioparm_type)), ioparm_type, \ - get_identifier (stringize(name)), type) +/* The data transfer parameter block that should be shared by all + data transfer calls belonging to the same read/write/iolength. */ +static GTY(()) tree dt_parm; +static stmtblock_t *dt_post_end_block; -#define ADD_STRING(name) \ - ioparm_ ## name = gfc_add_field_to_struct \ - (&(TYPE_FIELDS (ioparm_type)), ioparm_type, \ - get_identifier (stringize(name)), pchar_type_node); \ - ioparm_ ## name ## _len = gfc_add_field_to_struct \ - (&(TYPE_FIELDS (ioparm_type)), ioparm_type, \ - get_identifier (stringize(name) "_len"), gfc_charlen_type_node) +static void +gfc_build_st_parameter (enum ioparam_type ptype, tree *types) +{ + enum iofield type; + gfc_st_parameter_field *p; + char name[64]; + size_t len; + tree t = make_node (RECORD_TYPE); + + len = strlen (st_parameter[ptype].name); + gcc_assert (len <= sizeof (name) - sizeof ("__st_parameter_")); + memcpy (name, "__st_parameter_", sizeof ("__st_parameter_")); + memcpy (name + sizeof ("__st_parameter_") - 1, st_parameter[ptype].name, + len); + TYPE_NAME (t) = get_identifier (name); + + for (type = 0, p = st_parameter_field; type < IOPARM_field_num; type++, p++) + if (p->param_type == ptype) + switch (p->type) + { + case IOPARM_type_int4: + case IOPARM_type_pint4: + case IOPARM_type_parray: + case IOPARM_type_pchar: + case IOPARM_type_pad: + p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t, + get_identifier (p->name), + types[p->type]); + break; + case IOPARM_type_char1: + p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t, + get_identifier (p->name), + pchar_type_node); + /* FALLTHROUGH */ + case IOPARM_type_char2: + len = strlen (p->name); + gcc_assert (len <= sizeof (name) - sizeof ("_len")); + memcpy (name, p->name, len); + memcpy (name + len, "_len", sizeof ("_len")); + p->field_len = gfc_add_field_to_struct (&TYPE_FIELDS (t), t, + get_identifier (name), + gfc_charlen_type_node); + if (p->type == IOPARM_type_char2) + p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t, + get_identifier (p->name), + pchar_type_node); + break; + case IOPARM_type_common: + p->field + = gfc_add_field_to_struct (&TYPE_FIELDS (t), t, + get_identifier (p->name), + st_parameter[IOPARM_ptype_common].type); + break; + case IOPARM_type_num: + gcc_unreachable (); + } + gfc_finish_type (t); + st_parameter[ptype].type = t; +} /* Create function decls for IO library functions. */ void gfc_build_io_library_fndecls (void) { - tree gfc_int4_type_node; - tree gfc_pint4_type_node; + tree types[IOPARM_type_num], pad_idx, gfc_int4_type_node; + tree parm_type, dt_parm_type; tree gfc_c_int_type_node; - tree ioparm_type; - - gfc_int4_type_node = gfc_get_int_type (4); - gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node); + HOST_WIDE_INT pad_size; + enum ioparam_type ptype; + + types[IOPARM_type_int4] = gfc_int4_type_node = gfc_get_int_type (4); + types[IOPARM_type_pint4] = build_pointer_type (gfc_int4_type_node); + types[IOPARM_type_parray] = pchar_type_node; + types[IOPARM_type_pchar] = pchar_type_node; + pad_size = 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node)); + pad_size += 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node)); + pad_idx = build_index_type (build_int_cst (NULL_TREE, pad_size)); + types[IOPARM_type_pad] = build_array_type (char_type_node, pad_idx); gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind); - /* Build the st_parameter structure. Information associated with I/O - calls are transferred here. This must match the one defined in the - library exactly. */ - - ioparm_type = make_node (RECORD_TYPE); - TYPE_NAME (ioparm_type) = get_identifier ("_gfc_ioparm"); - - ADD_FIELD (unit, gfc_int4_type_node); - ADD_FIELD (err, gfc_int4_type_node); - ADD_FIELD (end, gfc_int4_type_node); - ADD_FIELD (eor, gfc_int4_type_node); - ADD_FIELD (list_format, gfc_int4_type_node); - ADD_FIELD (library_return, gfc_int4_type_node); - - ADD_FIELD (iostat, gfc_pint4_type_node); - ADD_FIELD (exist, gfc_pint4_type_node); - ADD_FIELD (opened, gfc_pint4_type_node); - ADD_FIELD (number, gfc_pint4_type_node); - ADD_FIELD (named, gfc_pint4_type_node); - ADD_FIELD (rec, gfc_int4_type_node); - ADD_FIELD (nextrec, gfc_pint4_type_node); - ADD_FIELD (size, gfc_pint4_type_node); - - ADD_FIELD (recl_in, gfc_int4_type_node); - ADD_FIELD (recl_out, gfc_pint4_type_node); - - ADD_FIELD (iolength, gfc_pint4_type_node); - - ADD_STRING (file); - ADD_STRING (status); - - ADD_STRING (access); - ADD_STRING (form); - ADD_STRING (blank); - ADD_STRING (position); - ADD_STRING (action); - ADD_STRING (delim); - ADD_STRING (pad); - ADD_STRING (format); - ADD_STRING (advance); - ADD_STRING (name); - ADD_STRING (internal_unit); - ADD_FIELD (internal_unit_desc, pchar_type_node); - ADD_STRING (sequential); - - ADD_STRING (direct); - ADD_STRING (formatted); - ADD_STRING (unformatted); - ADD_STRING (read); - ADD_STRING (write); - ADD_STRING (readwrite); - - ADD_STRING (namelist_name); - ADD_FIELD (namelist_read_mode, gfc_int4_type_node); - ADD_STRING (iomsg); - - gfc_finish_type (ioparm_type); - - ioparm_var = build_decl (VAR_DECL, get_identifier (PREFIX("ioparm")), - ioparm_type); - DECL_EXTERNAL (ioparm_var) = 1; - TREE_PUBLIC (ioparm_var) = 1; - - locus_line = build_decl (VAR_DECL, get_identifier (PREFIX("line")), - gfc_int4_type_node); - DECL_EXTERNAL (locus_line) = 1; - TREE_PUBLIC (locus_line) = 1; - - locus_file = build_decl (VAR_DECL, get_identifier (PREFIX("filename")), - pchar_type_node); - DECL_EXTERNAL (locus_file) = 1; - TREE_PUBLIC (locus_file) = 1; + for (ptype = IOPARM_ptype_common; ptype < IOPARM_ptype_num; ptype++) + gfc_build_st_parameter (ptype, types); /* Define the transfer functions. */ - iocall_x_integer = + dt_parm_type = build_pointer_type (st_parameter[IOPARM_ptype_dt].type); + + iocall[IOCALL_X_INTEGER] = gfc_build_library_function_decl (get_identifier (PREFIX("transfer_integer")), - void_type_node, 2, pvoid_type_node, - gfc_int4_type_node); + void_type_node, 3, dt_parm_type, + pvoid_type_node, gfc_int4_type_node); - iocall_x_logical = + iocall[IOCALL_X_LOGICAL] = gfc_build_library_function_decl (get_identifier (PREFIX("transfer_logical")), - void_type_node, 2, pvoid_type_node, - gfc_int4_type_node); + void_type_node, 3, dt_parm_type, + pvoid_type_node, gfc_int4_type_node); - iocall_x_character = + iocall[IOCALL_X_CHARACTER] = gfc_build_library_function_decl (get_identifier (PREFIX("transfer_character")), - void_type_node, 2, pvoid_type_node, - gfc_int4_type_node); + void_type_node, 3, dt_parm_type, + pvoid_type_node, gfc_int4_type_node); - iocall_x_real = + iocall[IOCALL_X_REAL] = gfc_build_library_function_decl (get_identifier (PREFIX("transfer_real")), - void_type_node, 2, + void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node); - iocall_x_complex = + iocall[IOCALL_X_COMPLEX] = gfc_build_library_function_decl (get_identifier (PREFIX("transfer_complex")), - void_type_node, 2, pvoid_type_node, - gfc_int4_type_node); + void_type_node, 3, dt_parm_type, + pvoid_type_node, gfc_int4_type_node); - iocall_x_array = + iocall[IOCALL_X_ARRAY] = gfc_build_library_function_decl (get_identifier (PREFIX("transfer_array")), - void_type_node, 3, pvoid_type_node, - gfc_c_int_type_node, + void_type_node, 4, dt_parm_type, + pvoid_type_node, gfc_c_int_type_node, gfc_charlen_type_node); /* Library entry points */ - iocall_read = + iocall[IOCALL_READ] = gfc_build_library_function_decl (get_identifier (PREFIX("st_read")), - void_type_node, 0); + void_type_node, 1, dt_parm_type); - iocall_write = + iocall[IOCALL_WRITE] = gfc_build_library_function_decl (get_identifier (PREFIX("st_write")), - void_type_node, 0); - iocall_open = + void_type_node, 1, dt_parm_type); + + parm_type = build_pointer_type (st_parameter[IOPARM_ptype_open].type); + iocall[IOCALL_OPEN] = gfc_build_library_function_decl (get_identifier (PREFIX("st_open")), - void_type_node, 0); + void_type_node, 1, parm_type); + - iocall_close = + parm_type = build_pointer_type (st_parameter[IOPARM_ptype_close].type); + iocall[IOCALL_CLOSE] = gfc_build_library_function_decl (get_identifier (PREFIX("st_close")), - void_type_node, 0); + void_type_node, 1, parm_type); - iocall_inquire = + parm_type = build_pointer_type (st_parameter[IOPARM_ptype_inquire].type); + iocall[IOCALL_INQUIRE] = gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")), - gfc_int4_type_node, 0); + gfc_int4_type_node, 1, parm_type); - iocall_iolength = + iocall[IOCALL_IOLENGTH] = gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")), - void_type_node, 0); + void_type_node, 1, dt_parm_type); - iocall_rewind = + parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type); + iocall[IOCALL_REWIND] = gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")), - gfc_int4_type_node, 0); + gfc_int4_type_node, 1, parm_type); - iocall_backspace = + iocall[IOCALL_BACKSPACE] = gfc_build_library_function_decl (get_identifier (PREFIX("st_backspace")), - gfc_int4_type_node, 0); + gfc_int4_type_node, 1, parm_type); - iocall_endfile = + iocall[IOCALL_ENDFILE] = gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")), - gfc_int4_type_node, 0); + gfc_int4_type_node, 1, parm_type); - iocall_flush = + iocall[IOCALL_FLUSH] = gfc_build_library_function_decl (get_identifier (PREFIX("st_flush")), - gfc_int4_type_node, 0); + gfc_int4_type_node, 1, parm_type); /* Library helpers */ - iocall_read_done = + iocall[IOCALL_READ_DONE] = gfc_build_library_function_decl (get_identifier (PREFIX("st_read_done")), - gfc_int4_type_node, 0); + gfc_int4_type_node, 1, dt_parm_type); - iocall_write_done = + iocall[IOCALL_WRITE_DONE] = gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")), - gfc_int4_type_node, 0); + gfc_int4_type_node, 1, dt_parm_type); - iocall_iolength_done = + iocall[IOCALL_IOLENGTH_DONE] = gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")), - gfc_int4_type_node, 0); + gfc_int4_type_node, 1, dt_parm_type); - iocall_set_nml_val = + iocall[IOCALL_SET_NML_VAL] = gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var")), - void_type_node, 5, - pvoid_type_node, pvoid_type_node, - gfc_int4_type_node, gfc_charlen_type_node, + void_type_node, 6, dt_parm_type, + pvoid_type_node, pvoid_type_node, + gfc_int4_type_node, gfc_charlen_type_node, gfc_int4_type_node); - iocall_set_nml_val_dim = + iocall[IOCALL_SET_NML_VAL_DIM] = gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_dim")), - void_type_node, 4, + void_type_node, 5, dt_parm_type, gfc_int4_type_node, gfc_int4_type_node, gfc_int4_type_node, gfc_int4_type_node); } +/* Generate code to store an integer constant into the + st_parameter_XXX structure. */ + +static unsigned int +set_parameter_const (stmtblock_t *block, tree var, enum iofield type, + unsigned int val) +{ + tree tmp; + gfc_st_parameter_field *p = &st_parameter_field[type]; + + if (p->param_type == IOPARM_ptype_common) + var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type, + var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); + tmp = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field, + NULL_TREE); + gfc_add_modify_expr (block, tmp, build_int_cst (TREE_TYPE (p->field), val)); + return p->mask; +} + + /* Generate code to store a non-string I/O parameter into the - ioparm structure. This is a pass by value. */ + st_parameter_XXX structure. This is a pass by value. */ -static void -set_parameter_value (stmtblock_t * block, tree var, gfc_expr * e) +static unsigned int +set_parameter_value (stmtblock_t *block, tree var, enum iofield type, + gfc_expr *e) { gfc_se se; tree tmp; + gfc_st_parameter_field *p = &st_parameter_field[type]; gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, e, TREE_TYPE (var)); + gfc_conv_expr_type (&se, e, TREE_TYPE (p->field)); gfc_add_block_to_block (block, &se.pre); - tmp = build3 (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE); + if (p->param_type == IOPARM_ptype_common) + var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type, + var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); + tmp = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field, + NULL_TREE); gfc_add_modify_expr (block, tmp, se.expr); + return p->mask; } /* Generate code to store a non-string I/O parameter into the - ioparm structure. This is pass by reference. */ + st_parameter_XXX structure. This is pass by reference. */ -static void -set_parameter_ref (stmtblock_t * block, tree var, gfc_expr * e) +static unsigned int +set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock, + tree var, enum iofield type, gfc_expr *e) { gfc_se se; - tree tmp; + tree tmp, addr; + gfc_st_parameter_field *p = &st_parameter_field[type]; + gcc_assert (e->ts.type == BT_INTEGER || e->ts.type == BT_LOGICAL); gfc_init_se (&se, NULL); - se.want_pointer = 1; + gfc_conv_expr_lhs (&se, e); - gfc_conv_expr_type (&se, e, TREE_TYPE (var)); gfc_add_block_to_block (block, &se.pre); - tmp = build3 (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE); - gfc_add_modify_expr (block, tmp, se.expr); + if (TYPE_MODE (TREE_TYPE (se.expr)) + == TYPE_MODE (TREE_TYPE (TREE_TYPE (p->field)))) + addr = convert (TREE_TYPE (p->field), + gfc_build_addr_expr (NULL, se.expr)); + else + { + /* The type used by the library has different size + from the type of the variable supplied by the user. + Need to use a temporary. */ + tree tmpvar + = gfc_create_var (TREE_TYPE (TREE_TYPE (p->field)), + st_parameter_field[type].name); + addr = gfc_build_addr_expr (NULL, tmpvar); + tmp = convert (TREE_TYPE (se.expr), tmpvar); + gfc_add_modify_expr (postblock, se.expr, tmp); + } + + if (p->param_type == IOPARM_ptype_common) + var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type, + var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); + tmp = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field, + NULL_TREE); + gfc_add_modify_expr (block, tmp, addr); + return p->mask; } /* Given an array expr, find its address and length to get a string. If the @@ -450,22 +502,27 @@ gfc_convert_array_to_string (gfc_se * se, gfc_expr * e) /* Generate code to store a string and its length into the - ioparm structure. */ + st_parameter_XXX structure. */ -static void +static unsigned int set_string (stmtblock_t * block, stmtblock_t * postblock, tree var, - tree var_len, gfc_expr * e) + enum iofield type, gfc_expr * e) { gfc_se se; tree tmp; tree msg; tree io; tree len; + gfc_st_parameter_field *p = &st_parameter_field[type]; gfc_init_se (&se, NULL); - io = build3 (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE); - len = build3 (COMPONENT_REF, TREE_TYPE (var_len), ioparm_var, var_len, + if (p->param_type == IOPARM_ptype_common) + var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type, + var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); + io = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field, + NULL_TREE); + len = build3 (COMPONENT_REF, TREE_TYPE (p->field_len), var, p->field_len, NULL_TREE); /* Integer variable assigned a format label. */ @@ -500,28 +557,34 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var, gfc_add_block_to_block (block, &se.pre); gfc_add_block_to_block (postblock, &se.post); + return p->mask; } /* Generate code to store the character (array) and the character length for an internal unit. */ -static void -set_internal_unit (stmtblock_t * block, tree iunit, tree iunit_len, - tree iunit_desc, gfc_expr * e) +static unsigned int +set_internal_unit (stmtblock_t * block, tree var, gfc_expr * e) { gfc_se se; tree io; tree len; tree desc; tree tmp; + gfc_st_parameter_field *p; + unsigned int mask; gfc_init_se (&se, NULL); - io = build3 (COMPONENT_REF, TREE_TYPE (iunit), ioparm_var, iunit, NULL_TREE); - len = build3 (COMPONENT_REF, TREE_TYPE (iunit_len), ioparm_var, iunit_len, + p = &st_parameter_field[IOPARM_dt_internal_unit]; + mask = p->mask; + io = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field, + NULL_TREE); + len = build3 (COMPONENT_REF, TREE_TYPE (p->field_len), var, p->field_len, NULL_TREE); - desc = build3 (COMPONENT_REF, TREE_TYPE (iunit_desc), ioparm_var, iunit_desc, + p = &st_parameter_field[IOPARM_dt_internal_unit_desc]; + desc = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field, NULL_TREE); gcc_assert (e->ts.type == BT_CHARACTER); @@ -555,19 +618,9 @@ set_internal_unit (stmtblock_t * block, tree iunit, tree iunit_len, gfc_add_modify_expr (&se.pre, desc, se.expr); gfc_add_block_to_block (block, &se.pre); + return mask; } -/* Set a member of the ioparm structure to one. */ -static void -set_flag (stmtblock_t *block, tree var) -{ - tree tmp, type = TREE_TYPE (var); - - tmp = build3 (COMPONENT_REF, type, ioparm_var, var, NULL_TREE); - gfc_add_modify_expr (block, tmp, convert (type, integer_one_node)); -} - - /* Add a case to a IO-result switch. */ static void @@ -600,11 +653,12 @@ add_case (int label_value, gfc_st_label * label, stmtblock_t * body) be created anyway. */ static void -io_result (stmtblock_t * block, gfc_st_label * err_label, +io_result (stmtblock_t * block, tree var, gfc_st_label * err_label, gfc_st_label * end_label, gfc_st_label * eor_label) { stmtblock_t body; tree tmp, rc; + gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags]; /* If no labels are specified, ignore the result instead of building an empty switch. */ @@ -624,8 +678,12 @@ io_result (stmtblock_t * block, gfc_st_label * err_label, tmp = gfc_finish_block (&body); - rc = build3 (COMPONENT_REF, TREE_TYPE (ioparm_library_return), ioparm_var, - ioparm_library_return, NULL_TREE); + var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type, + var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); + rc = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field, + NULL_TREE); + rc = build2 (BIT_AND_EXPR, TREE_TYPE (rc), rc, + build_int_cst (TREE_TYPE (rc), IOPARM_common_libreturn_mask)); tmp = build3_v (SWITCH_EXPR, rc, tmp, NULL_TREE); @@ -637,24 +695,29 @@ io_result (stmtblock_t * block, gfc_st_label * err_label, library call goes awry, we can tell the user where the problem is. */ static void -set_error_locus (stmtblock_t * block, locus * where) +set_error_locus (stmtblock_t * block, tree var, locus * where) { gfc_file *f; - tree tmp; + tree str, locus_file; int line; + gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_filename]; + locus_file = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type, + var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); + locus_file = build3 (COMPONENT_REF, TREE_TYPE (p->field), locus_file, + p->field, NULL_TREE); f = where->lb->file; - tmp = gfc_build_cstring_const (f->filename); + str = gfc_build_cstring_const (f->filename); - tmp = gfc_build_addr_expr (pchar_type_node, tmp); - gfc_add_modify_expr (block, locus_file, tmp); + str = gfc_build_addr_expr (pchar_type_node, str); + gfc_add_modify_expr (block, locus_file, str); #ifdef USE_MAPPED_LOCATION line = LOCATION_LINE (where->lb->location); #else line = where->lb->linenum; #endif - gfc_add_modify_expr (block, locus_line, build_int_cst (NULL_TREE, line)); + set_parameter_const (block, var, IOPARM_common_line, line); } @@ -665,69 +728,79 @@ gfc_trans_open (gfc_code * code) { stmtblock_t block, post_block; gfc_open *p; - tree tmp; + tree tmp, var; + unsigned int mask = 0; - gfc_init_block (&block); + gfc_start_block (&block); gfc_init_block (&post_block); - set_error_locus (&block, &code->loc); + var = gfc_create_var (st_parameter[IOPARM_ptype_open].type, "open_parm"); + + set_error_locus (&block, var, &code->loc); p = code->ext.open; if (p->unit) - set_parameter_value (&block, ioparm_unit, p->unit); + set_parameter_value (&block, var, IOPARM_common_unit, p->unit); + else + set_parameter_const (&block, var, IOPARM_common_unit, 0); if (p->file) - set_string (&block, &post_block, ioparm_file, ioparm_file_len, p->file); + mask |= set_string (&block, &post_block, var, IOPARM_open_file, p->file); if (p->status) - set_string (&block, &post_block, ioparm_status, - ioparm_status_len, p->status); + mask |= set_string (&block, &post_block, var, IOPARM_open_status, + p->status); if (p->access) - set_string (&block, &post_block, ioparm_access, - ioparm_access_len, p->access); + mask |= set_string (&block, &post_block, var, IOPARM_open_access, + p->access); if (p->form) - set_string (&block, &post_block, ioparm_form, ioparm_form_len, p->form); + mask |= set_string (&block, &post_block, var, IOPARM_open_form, p->form); if (p->recl) - set_parameter_value (&block, ioparm_recl_in, p->recl); + mask |= set_parameter_value (&block, var, IOPARM_open_recl_in, p->recl); if (p->blank) - set_string (&block, &post_block, ioparm_blank, ioparm_blank_len, - p->blank); + mask |= set_string (&block, &post_block, var, IOPARM_open_blank, + p->blank); if (p->position) - set_string (&block, &post_block, ioparm_position, - ioparm_position_len, p->position); + mask |= set_string (&block, &post_block, var, IOPARM_open_position, + p->position); if (p->action) - set_string (&block, &post_block, ioparm_action, - ioparm_action_len, p->action); + mask |= set_string (&block, &post_block, var, IOPARM_open_action, + p->action); if (p->delim) - set_string (&block, &post_block, ioparm_delim, ioparm_delim_len, - p->delim); + mask |= set_string (&block, &post_block, var, IOPARM_open_delim, + p->delim); if (p->pad) - set_string (&block, &post_block, ioparm_pad, ioparm_pad_len, p->pad); + mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad); if (p->iomsg) - set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len, - p->iomsg); + mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, + p->iomsg); if (p->iostat) - set_parameter_ref (&block, ioparm_iostat, p->iostat); + mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat, + p->iostat); if (p->err) - set_flag (&block, ioparm_err); + mask |= IOPARM_common_err; + + set_parameter_const (&block, var, IOPARM_common_flags, mask); - tmp = gfc_build_function_call (iocall_open, NULL_TREE); + tmp = gfc_build_addr_expr (NULL_TREE, var); + tmp = gfc_chainon_list (NULL_TREE, tmp); + tmp = gfc_build_function_call (iocall[IOCALL_OPEN], tmp); gfc_add_expr_to_block (&block, tmp); gfc_add_block_to_block (&block, &post_block); - io_result (&block, p->err, NULL, NULL); + io_result (&block, var, p->err, NULL, NULL); return gfc_finish_block (&block); } @@ -740,37 +813,47 @@ gfc_trans_close (gfc_code * code) { stmtblock_t block, post_block; gfc_close *p; - tree tmp; + tree tmp, var; + unsigned int mask = 0; - gfc_init_block (&block); + gfc_start_block (&block); gfc_init_block (&post_block); - set_error_locus (&block, &code->loc); + var = gfc_create_var (st_parameter[IOPARM_ptype_close].type, "close_parm"); + + set_error_locus (&block, var, &code->loc); p = code->ext.close; if (p->unit) - set_parameter_value (&block, ioparm_unit, p->unit); + set_parameter_value (&block, var, IOPARM_common_unit, p->unit); + else + set_parameter_const (&block, var, IOPARM_common_unit, 0); if (p->status) - set_string (&block, &post_block, ioparm_status, - ioparm_status_len, p->status); + mask |= set_string (&block, &post_block, var, IOPARM_close_status, + p->status); if (p->iomsg) - set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len, - p->iomsg); + mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, + p->iomsg); if (p->iostat) - set_parameter_ref (&block, ioparm_iostat, p->iostat); + mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat, + p->iostat); if (p->err) - set_flag (&block, ioparm_err); + mask |= IOPARM_common_err; - tmp = gfc_build_function_call (iocall_close, NULL_TREE); + set_parameter_const (&block, var, IOPARM_common_flags, mask); + + tmp = gfc_build_addr_expr (NULL_TREE, var); + tmp = gfc_chainon_list (NULL_TREE, tmp); + tmp = gfc_build_function_call (iocall[IOCALL_CLOSE], tmp); gfc_add_expr_to_block (&block, tmp); gfc_add_block_to_block (&block, &post_block); - io_result (&block, p->err, NULL, NULL); + io_result (&block, var, p->err, NULL, NULL); return gfc_finish_block (&block); } @@ -783,34 +866,45 @@ build_filepos (tree function, gfc_code * code) { stmtblock_t block, post_block; gfc_filepos *p; - tree tmp; + tree tmp, var; + unsigned int mask = 0; p = code->ext.filepos; - gfc_init_block (&block); + gfc_start_block (&block); gfc_init_block (&post_block); - set_error_locus (&block, &code->loc); + var = gfc_create_var (st_parameter[IOPARM_ptype_filepos].type, + "filepos_parm"); + + set_error_locus (&block, var, &code->loc); if (p->unit) - set_parameter_value (&block, ioparm_unit, p->unit); + set_parameter_value (&block, var, IOPARM_common_unit, p->unit); + else + set_parameter_const (&block, var, IOPARM_common_unit, 0); if (p->iomsg) - set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len, - p->iomsg); + mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, + p->iomsg); if (p->iostat) - set_parameter_ref (&block, ioparm_iostat, p->iostat); + mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat, + p->iostat); if (p->err) - set_flag (&block, ioparm_err); + mask |= IOPARM_common_err; - tmp = gfc_build_function_call (function, NULL); + set_parameter_const (&block, var, IOPARM_common_flags, mask); + + tmp = gfc_build_addr_expr (NULL_TREE, var); + tmp = gfc_chainon_list (NULL_TREE, tmp); + tmp = gfc_build_function_call (function, tmp); gfc_add_expr_to_block (&block, tmp); gfc_add_block_to_block (&block, &post_block); - io_result (&block, p->err, NULL, NULL); + io_result (&block, var, p->err, NULL, NULL); return gfc_finish_block (&block); } @@ -821,8 +915,7 @@ build_filepos (tree function, gfc_code * code) tree gfc_trans_backspace (gfc_code * code) { - - return build_filepos (iocall_backspace, code); + return build_filepos (iocall[IOCALL_BACKSPACE], code); } @@ -831,8 +924,7 @@ gfc_trans_backspace (gfc_code * code) tree gfc_trans_endfile (gfc_code * code) { - - return build_filepos (iocall_endfile, code); + return build_filepos (iocall[IOCALL_ENDFILE], code); } @@ -841,8 +933,7 @@ gfc_trans_endfile (gfc_code * code) tree gfc_trans_rewind (gfc_code * code) { - - return build_filepos (iocall_rewind, code); + return build_filepos (iocall[IOCALL_REWIND], code); } @@ -851,8 +942,7 @@ gfc_trans_rewind (gfc_code * code) tree gfc_trans_flush (gfc_code * code) { - - return build_filepos (iocall_flush, code); + return build_filepos (iocall[IOCALL_FLUSH], code); } @@ -863,12 +953,16 @@ gfc_trans_inquire (gfc_code * code) { stmtblock_t block, post_block; gfc_inquire *p; - tree tmp; + tree tmp, var; + unsigned int mask = 0; - gfc_init_block (&block); + gfc_start_block (&block); gfc_init_block (&post_block); - set_error_locus (&block, &code->loc); + var = gfc_create_var (st_parameter[IOPARM_ptype_inquire].type, + "inquire_parm"); + + set_error_locus (&block, var, &code->loc); p = code->ext.inquire; /* Sanity check. */ @@ -876,102 +970,119 @@ gfc_trans_inquire (gfc_code * code) gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers.", &code->loc); if (p->unit) - set_parameter_value (&block, ioparm_unit, p->unit); + set_parameter_value (&block, var, IOPARM_common_unit, p->unit); + else + set_parameter_const (&block, var, IOPARM_common_unit, 0); if (p->file) - set_string (&block, &post_block, ioparm_file, ioparm_file_len, p->file); + mask |= set_string (&block, &post_block, var, IOPARM_inquire_file, + p->file); if (p->iomsg) - set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len, - p->iomsg); + mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, + p->iomsg); if (p->iostat) - set_parameter_ref (&block, ioparm_iostat, p->iostat); + mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat, + p->iostat); if (p->exist) - set_parameter_ref (&block, ioparm_exist, p->exist); + mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_exist, + p->exist); if (p->opened) - set_parameter_ref (&block, ioparm_opened, p->opened); + mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_opened, + p->opened); if (p->number) - set_parameter_ref (&block, ioparm_number, p->number); + mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_number, + p->number); if (p->named) - set_parameter_ref (&block, ioparm_named, p->named); + mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_named, + p->named); if (p->name) - set_string (&block, &post_block, ioparm_name, ioparm_name_len, p->name); + mask |= set_string (&block, &post_block, var, IOPARM_inquire_name, + p->name); if (p->access) - set_string (&block, &post_block, ioparm_access, - ioparm_access_len, p->access); + mask |= set_string (&block, &post_block, var, IOPARM_inquire_access, + p->access); if (p->sequential) - set_string (&block, &post_block, ioparm_sequential, - ioparm_sequential_len, p->sequential); + mask |= set_string (&block, &post_block, var, IOPARM_inquire_sequential, + p->sequential); if (p->direct) - set_string (&block, &post_block, ioparm_direct, - ioparm_direct_len, p->direct); + mask |= set_string (&block, &post_block, var, IOPARM_inquire_direct, + p->direct); if (p->form) - set_string (&block, &post_block, ioparm_form, ioparm_form_len, p->form); + mask |= set_string (&block, &post_block, var, IOPARM_inquire_form, + p->form); if (p->formatted) - set_string (&block, &post_block, ioparm_formatted, - ioparm_formatted_len, p->formatted); + mask |= set_string (&block, &post_block, var, IOPARM_inquire_formatted, + p->formatted); if (p->unformatted) - set_string (&block, &post_block, ioparm_unformatted, - ioparm_unformatted_len, p->unformatted); + mask |= set_string (&block, &post_block, var, IOPARM_inquire_unformatted, + p->unformatted); if (p->recl) - set_parameter_ref (&block, ioparm_recl_out, p->recl); + mask |= set_parameter_ref (&block, &post_block, var, + IOPARM_inquire_recl_out, p->recl); if (p->nextrec) - set_parameter_ref (&block, ioparm_nextrec, p->nextrec); + mask |= set_parameter_ref (&block, &post_block, var, + IOPARM_inquire_nextrec, p->nextrec); if (p->blank) - set_string (&block, &post_block, ioparm_blank, ioparm_blank_len, - p->blank); + mask |= set_string (&block, &post_block, var, IOPARM_inquire_blank, + p->blank); if (p->position) - set_string (&block, &post_block, ioparm_position, - ioparm_position_len, p->position); + mask |= set_string (&block, &post_block, var, IOPARM_inquire_position, + p->position); if (p->action) - set_string (&block, &post_block, ioparm_action, - ioparm_action_len, p->action); + mask |= set_string (&block, &post_block, var, IOPARM_inquire_action, + p->action); if (p->read) - set_string (&block, &post_block, ioparm_read, ioparm_read_len, p->read); + mask |= set_string (&block, &post_block, var, IOPARM_inquire_read, + p->read); if (p->write) - set_string (&block, &post_block, ioparm_write, - ioparm_write_len, p->write); + mask |= set_string (&block, &post_block, var, IOPARM_inquire_write, + p->write); if (p->readwrite) - set_string (&block, &post_block, ioparm_readwrite, - ioparm_readwrite_len, p->readwrite); + mask |= set_string (&block, &post_block, var, IOPARM_inquire_readwrite, + p->readwrite); if (p->delim) - set_string (&block, &post_block, ioparm_delim, ioparm_delim_len, - p->delim); + mask |= set_string (&block, &post_block, var, IOPARM_inquire_delim, + p->delim); if (p->pad) - set_string (&block, &post_block, ioparm_pad, ioparm_pad_len, - p->pad); + mask |= set_string (&block, &post_block, var, IOPARM_inquire_pad, + p->pad); if (p->err) - set_flag (&block, ioparm_err); + mask |= IOPARM_common_err; - tmp = gfc_build_function_call (iocall_inquire, NULL); + set_parameter_const (&block, var, IOPARM_common_flags, mask); + + tmp = gfc_build_addr_expr (NULL_TREE, var); + tmp = gfc_chainon_list (NULL_TREE, tmp); + tmp = gfc_build_function_call (iocall[IOCALL_INQUIRE], tmp); gfc_add_expr_to_block (&block, tmp); gfc_add_block_to_block (&block, &post_block); - io_result (&block, p->err, NULL, NULL); + io_result (&block, var, p->err, NULL, NULL); return gfc_finish_block (&block); } @@ -1085,8 +1196,8 @@ nml_get_addr_expr (gfc_symbol * sym, gfc_component * c, } /* For an object VAR_NAME whose base address is BASE_ADDR, generate a - call to iocall_set_nml_val. For derived type variable, recursively - generate calls to iocall_set_nml_val for each component. */ + call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively + generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */ #define NML_FIRST_ARG(a) args = gfc_chainon_list (NULL_TREE, a) #define NML_ADD_ARG(a) args = gfc_chainon_list (args, a) @@ -1105,6 +1216,7 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name, tree tmp; tree args; tree dtype; + tree dt_parm_addr; int n_dim; int itype; int rank = 0; @@ -1167,7 +1279,9 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name, The call for the scalar part transfers: (address, name, type, kind or string_length, dtype) */ - NML_FIRST_ARG (addr_expr); + dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm); + NML_FIRST_ARG (dt_parm_addr); + NML_ADD_ARG (addr_expr); NML_ADD_ARG (string); NML_ADD_ARG (IARG (ts->kind)); @@ -1177,7 +1291,7 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name, NML_ADD_ARG (convert (gfc_charlen_type_node, integer_zero_node)); NML_ADD_ARG (dtype); - tmp = gfc_build_function_call (iocall_set_nml_val, args); + tmp = gfc_build_function_call (iocall[IOCALL_SET_NML_VAL], args); gfc_add_expr_to_block (block, tmp); /* If the object is an array, transfer rank times: @@ -1185,11 +1299,12 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name, for ( n_dim = 0 ; n_dim < rank ; n_dim++ ) { - NML_FIRST_ARG (IARG (n_dim)); + NML_FIRST_ARG (dt_parm_addr); + NML_ADD_ARG (IARG (n_dim)); NML_ADD_ARG (GFC_TYPE_ARRAY_STRIDE (dt, n_dim)); NML_ADD_ARG (GFC_TYPE_ARRAY_LBOUND (dt, n_dim)); NML_ADD_ARG (GFC_TYPE_ARRAY_UBOUND (dt, n_dim)); - tmp = gfc_build_function_call (iocall_set_nml_val_dim, args); + tmp = gfc_build_function_call (iocall[IOCALL_SET_NML_VAL_DIM], args); gfc_add_expr_to_block (block, tmp); } @@ -1221,98 +1336,142 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name, out by now. */ static tree -build_dt (tree * function, gfc_code * code) +build_dt (tree function, gfc_code * code) { - stmtblock_t block, post_block; + stmtblock_t block, post_block, post_end_block; gfc_dt *dt; - tree tmp; + tree tmp, var; gfc_expr *nmlname; gfc_namelist *nml; + unsigned int mask = 0; - gfc_init_block (&block); + gfc_start_block (&block); gfc_init_block (&post_block); + gfc_init_block (&post_end_block); + + var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm"); + + set_error_locus (&block, var, &code->loc); + + if (last_dt == IOLENGTH) + { + gfc_inquire *inq; + + inq = code->ext.inquire; - set_error_locus (&block, &code->loc); - dt = code->ext.dt; + /* First check that preconditions are met. */ + gcc_assert (inq != NULL); + gcc_assert (inq->iolength != NULL); - gcc_assert (dt != NULL); + /* Connect to the iolength variable. */ + mask |= set_parameter_ref (&block, &post_end_block, var, + IOPARM_dt_iolength, inq->iolength); + dt = NULL; + } + else + { + dt = code->ext.dt; + gcc_assert (dt != NULL); + } - if (dt->io_unit) + if (dt && dt->io_unit) { if (dt->io_unit->ts.type == BT_CHARACTER) { - set_internal_unit (&block, - ioparm_internal_unit, - ioparm_internal_unit_len, - ioparm_internal_unit_desc, - dt->io_unit); + mask |= set_internal_unit (&block, var, dt->io_unit); + set_parameter_const (&block, var, IOPARM_common_unit, 0); } else - set_parameter_value (&block, ioparm_unit, dt->io_unit); + set_parameter_value (&block, var, IOPARM_common_unit, dt->io_unit); } + else + set_parameter_const (&block, var, IOPARM_common_unit, 0); - if (dt->rec) - set_parameter_value (&block, ioparm_rec, dt->rec); + if (dt) + { + if (dt->rec) + mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec); - if (dt->advance) - set_string (&block, &post_block, ioparm_advance, ioparm_advance_len, - dt->advance); + if (dt->advance) + mask |= set_string (&block, &post_block, var, IOPARM_dt_advance, + dt->advance); - if (dt->format_expr) - set_string (&block, &post_block, ioparm_format, ioparm_format_len, - dt->format_expr); + if (dt->format_expr) + mask |= set_string (&block, &post_block, var, IOPARM_dt_format, + dt->format_expr); - if (dt->format_label) - { - if (dt->format_label == &format_asterisk) - set_flag (&block, ioparm_list_format); - else - set_string (&block, &post_block, ioparm_format, - ioparm_format_len, dt->format_label->format); - } + if (dt->format_label) + { + if (dt->format_label == &format_asterisk) + mask |= IOPARM_dt_list_format; + else + mask |= set_string (&block, &post_block, var, IOPARM_dt_format, + dt->format_label->format); + } - if (dt->iomsg) - set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len, - dt->iomsg); + if (dt->iomsg) + mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, + dt->iomsg); - if (dt->iostat) - set_parameter_ref (&block, ioparm_iostat, dt->iostat); + if (dt->iostat) + mask |= set_parameter_ref (&block, &post_end_block, var, + IOPARM_common_iostat, dt->iostat); - if (dt->size) - set_parameter_ref (&block, ioparm_size, dt->size); + if (dt->size) + mask |= set_parameter_ref (&block, &post_end_block, var, + IOPARM_dt_size, dt->size); - if (dt->err) - set_flag (&block, ioparm_err); + if (dt->err) + mask |= IOPARM_common_err; - if (dt->eor) - set_flag(&block, ioparm_eor); + if (dt->eor) + mask |= IOPARM_common_eor; - if (dt->end) - set_flag(&block, ioparm_end); + if (dt->end) + mask |= IOPARM_common_end; - if (dt->namelist) - { - if (dt->format_expr || dt->format_label) - gfc_internal_error ("build_dt: format with namelist"); + if (dt->namelist) + { + if (dt->format_expr || dt->format_label) + gfc_internal_error ("build_dt: format with namelist"); + + nmlname = gfc_new_nml_name_expr (dt->namelist->name); - nmlname = gfc_new_nml_name_expr(dt->namelist->name); + mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name, + nmlname); - set_string (&block, &post_block, ioparm_namelist_name, - ioparm_namelist_name_len, nmlname); + if (last_dt == READ) + mask |= IOPARM_dt_namelist_read_mode; - if (last_dt == READ) - set_flag (&block, ioparm_namelist_read_mode); + set_parameter_const (&block, var, IOPARM_common_flags, mask); - for (nml = dt->namelist->namelist; nml; nml = nml->next) - transfer_namelist_element (&block, nml->sym->name, nml->sym, - NULL, NULL); + dt_parm = var; + + for (nml = dt->namelist->namelist; nml; nml = nml->next) + transfer_namelist_element (&block, nml->sym->name, nml->sym, + NULL, NULL); + } + else + set_parameter_const (&block, var, IOPARM_common_flags, mask); } + else + set_parameter_const (&block, var, IOPARM_common_flags, mask); - tmp = gfc_build_function_call (*function, NULL_TREE); + tmp = gfc_build_addr_expr (NULL_TREE, var); + tmp = gfc_chainon_list (NULL_TREE, tmp); + tmp = gfc_build_function_call (function, tmp); gfc_add_expr_to_block (&block, tmp); gfc_add_block_to_block (&block, &post_block); + dt_parm = var; + dt_post_end_block = &post_end_block; + + gfc_add_expr_to_block (&block, gfc_trans_code (code->block->next)); + + dt_parm = NULL; + dt_post_end_block = NULL; + return gfc_finish_block (&block); } @@ -1324,31 +1483,8 @@ build_dt (tree * function, gfc_code * code) tree gfc_trans_iolength (gfc_code * code) { - stmtblock_t block; - gfc_inquire *inq; - tree dt; - - gfc_init_block (&block); - - set_error_locus (&block, &code->loc); - - inq = code->ext.inquire; - - /* First check that preconditions are met. */ - gcc_assert (inq != NULL); - gcc_assert (inq->iolength != NULL); - - /* Connect to the iolength variable. */ - if (inq->iolength) - set_parameter_ref (&block, ioparm_iolength, inq->iolength); - - /* Actual logic. */ last_dt = IOLENGTH; - dt = build_dt(&iocall_iolength, code); - - gfc_add_expr_to_block (&block, dt); - - return gfc_finish_block (&block); + return build_dt (iocall[IOCALL_IOLENGTH], code); } @@ -1357,9 +1493,8 @@ gfc_trans_iolength (gfc_code * code) tree gfc_trans_read (gfc_code * code) { - last_dt = READ; - return build_dt (&iocall_read, code); + return build_dt (iocall[IOCALL_READ], code); } @@ -1368,9 +1503,8 @@ gfc_trans_read (gfc_code * code) tree gfc_trans_write (gfc_code * code) { - last_dt = WRITE; - return build_dt (&iocall_write, code); + return build_dt (iocall[IOCALL_WRITE], code); } @@ -1387,28 +1521,32 @@ gfc_trans_dt_end (gfc_code * code) switch (last_dt) { case READ: - function = iocall_read_done; + function = iocall[IOCALL_READ_DONE]; break; case WRITE: - function = iocall_write_done; + function = iocall[IOCALL_WRITE_DONE]; break; case IOLENGTH: - function = iocall_iolength_done; + function = iocall[IOCALL_IOLENGTH_DONE]; break; default: gcc_unreachable (); } - tmp = gfc_build_function_call (function, NULL); + tmp = gfc_build_addr_expr (NULL_TREE, dt_parm); + tmp = gfc_chainon_list (NULL_TREE, tmp); + tmp = gfc_build_function_call (function, tmp); gfc_add_expr_to_block (&block, tmp); + gfc_add_block_to_block (&block, dt_post_end_block); + gfc_init_block (dt_post_end_block); if (last_dt != IOLENGTH) { gcc_assert (code->ext.dt != NULL); - io_result (&block, code->ext.dt->err, + io_result (&block, dt_parm, code->ext.dt->err, code->ext.dt->end, code->ext.dt->eor); } @@ -1523,22 +1661,22 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr) { case BT_INTEGER: arg2 = build_int_cst (NULL_TREE, kind); - function = iocall_x_integer; + function = iocall[IOCALL_X_INTEGER]; break; case BT_REAL: arg2 = build_int_cst (NULL_TREE, kind); - function = iocall_x_real; + function = iocall[IOCALL_X_REAL]; break; case BT_COMPLEX: arg2 = build_int_cst (NULL_TREE, kind); - function = iocall_x_complex; + function = iocall[IOCALL_X_COMPLEX]; break; case BT_LOGICAL: arg2 = build_int_cst (NULL_TREE, kind); - function = iocall_x_logical; + function = iocall[IOCALL_X_LOGICAL]; break; case BT_CHARACTER: @@ -1550,7 +1688,7 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr) gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE); arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp))); } - function = iocall_x_character; + function = iocall[IOCALL_X_CHARACTER]; break; case BT_DERIVED: @@ -1584,7 +1722,9 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr) internal_error ("Bad IO basetype (%d)", ts->type); } - args = gfc_chainon_list (NULL_TREE, addr_expr); + tmp = gfc_build_addr_expr (NULL_TREE, dt_parm); + args = gfc_chainon_list (NULL_TREE, tmp); + args = gfc_chainon_list (args, addr_expr); args = gfc_chainon_list (args, arg2); tmp = gfc_build_function_call (function, args); @@ -1609,10 +1749,12 @@ transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr) kind_arg = build_int_cst (NULL_TREE, ts->kind); - args = gfc_chainon_list (NULL_TREE, addr_expr); + tmp = gfc_build_addr_expr (NULL_TREE, dt_parm); + args = gfc_chainon_list (NULL_TREE, tmp); + args = gfc_chainon_list (args, addr_expr); args = gfc_chainon_list (args, kind_arg); args = gfc_chainon_list (args, charlen_arg); - tmp = gfc_build_function_call (iocall_x_array, args); + tmp = gfc_build_function_call (iocall[IOCALL_X_ARRAY], args); gfc_add_expr_to_block (&se->pre, tmp); gfc_add_block_to_block (&se->pre, &se->post); } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 315c0f9648f..23dabc9ce9a 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2005-11-21 Jakub Jelinek + + 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 PR libfortran/24432 diff --git a/gcc/testsuite/gfortran.dg/inquire_9.f90 b/gcc/testsuite/gfortran.dg/inquire_9.f90 new file mode 100644 index 00000000000..f1f8ffd1556 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/inquire_9.f90 @@ -0,0 +1,24 @@ +! PR fortran/24774 +! { dg-do run } + logical :: l + l = .true. + inquire (file='inquire_9 file that should not exist', exist=l) + if (l) call abort + l = .true. + inquire (unit=-16, exist=l) + if (l) call abort + open (unit=16, file='inquire_9.tst') + print (unit=16, fmt='(a)'), 'Test' + l = .false. + inquire (unit=16, exist=l) + if (.not.l) call abort + l = .false. + inquire (file='inquire_9.tst', exist=l) + if (.not.l) call abort + close (unit=16) + l = .false. + inquire (file='inquire_9.tst', exist=l) + if (.not.l) call abort + open (unit=16, file='inquire_9.tst') + close (unit=16, status='delete') +end diff --git a/gcc/testsuite/gfortran.fortran-torture/execute/inquire_5.f90 b/gcc/testsuite/gfortran.fortran-torture/execute/inquire_5.f90 new file mode 100644 index 00000000000..1077650d87d --- /dev/null +++ b/gcc/testsuite/gfortran.fortran-torture/execute/inquire_5.f90 @@ -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 -- cgit v1.2.1