diff options
| author | bstarynk <bstarynk@138bc75d-0d04-0410-961f-82ee72b054a4> | 2012-08-29 12:37:05 +0000 |
|---|---|---|
| committer | bstarynk <bstarynk@138bc75d-0d04-0410-961f-82ee72b054a4> | 2012-08-29 12:37:05 +0000 |
| commit | 12cb78d1cca1387a092ec0bd49c250340bff4afc (patch) | |
| tree | 1eab97da96906e0a2786d51d9f25f20de02befcf /gcc/fortran | |
| parent | 31879e18aea3222fe3e56f2c0319c9f230645ff3 (diff) | |
| download | gcc-12cb78d1cca1387a092ec0bd49c250340bff4afc.tar.gz | |
2012-08-29 Basile Starynkevitch <basile@starynkevitch.net>
MELT branch merged with trunk rev 190745 using svnmerge, notably
C++ conversion.
[gcc/]
2012-08-29 Basile Starynkevitch <basile@starynkevitch.net>
{{merging with trunk, converted to C++}}
* melt-runtime.h (MELT_FLEXIBLE_DIM): Set when C++.
* melt-runtime.c (melt_tempdir_path): Don't use choose_tmpdir from
libiberty.
(meltgc_start_module_by_index): Use address-of & on VEC_index.
(melt_really_initialize): When printing builtin settings, handle
GCC 4.8 as with implicit ENABLE_BUILD_WITH_CXX.
(meltgc_out_edge): Provide additional flag TDF_DETAILS for dump_edge_info.
(melt_val2passflag): Handle PROP_referenced_vars only when defined.
* melt-module.mk: Use GCCMELT_COMPILER instead of GCCMELT_CC.
* melt-build-script.tpl: Transmit GCCMELT_COMPILER on every make
using melt-module.mk and improve the error message.
* melt-build-script.sh: Regenerate.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/melt-branch@190778 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/fortran')
50 files changed, 2778 insertions, 986 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index bbd0b50a904..2b316774906 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,645 @@ +2012-08-28 Tobias Burnus <burnus@net-b.de> + + PR fortran/54384 + * symbol.c (gfc_copy_formal_args): Set also sym->formal_ns. + +2012-08-27 Tobias Burnus <burnus@net-b.de> + + PR fortran/54384 + * resolve.c (gfc_resolve_character_operator): Free temporary + variables. + * trans-expr.c (gfc_conv_statement_function): Ditto. + +2012-08-27 Tobias Burnus <burnus@net-b.de> + + PR fortran/54384 + * dependency.c (check_section_vs_section): Use gfc_free_expr + instead of free. + * trans-intrinsic.c (conv_generic_with_optional_char_arg): Use + gfc_free_symbol instead of free. + +2012-08-27 Tobias Burnus <burnus@net-b.de> + + PR fortran/54384 + * trans-expr.c (gfc_trans_arrayfunc_assign): Free se.ss + and loop. + +2012-08-27 Tobias Burnus <burnus@net-b.de> + + PR fortran/41093 + * gfortran.h (gfc_common_head): Add "int refs". + * match.c (gfc_match_common): Increment refs. + * resolve.c (resolve_symbol): Only increment formal_ns->refs + if formal_ns is not sym->ns. + * symbol.c (gfc_free_symbol): Only free formal_ns if + if formal_ns is not sym->ns. Free common_block if refs is one. + (gfc_release_symbol): Release formal_ns only if the + symbol is not ENTRY of a module. + * decl.c (get_proc_name): Don't increment gfc_current_ns->refs. + * parse.c (parse_interface): Incement proc_unit->refs++ for + proc-pointer result variables. + * module.c (mio_symbol): Don't increase sym->refs for its + use in sym->formal_ns->proc_name. + +2012-08-27 Tobias Burnus <burnus@net-b.de> + + PR fortran/54370 + * trans-stmt.c (gfc_trans_do_while): Don't change the logical + kind for negation of the condition. + +2012-08-27 Tobias Burnus <burnus@net-b.de> + + * options.c (set_Wall): Don't set for -Wcompare-reals. + * invoke.texi (-Wall, -Wcompare-reals): -Wall no longer + implies -Wcompare-reals. + +2012-08-24 Simon Baldwin <simonb@google.com> + + * lang.opt (-cpp=): Mark flag NoDWARFRecord. + +2012-08-23 Tobias Burnus <burnus@net-b.de> + + PR fortran/54350 + * trans-array.c (free_ss_info): Free data.array.subscript. + (gfc_free_ss): No longer free data.array.subscript. + (walk_coarray): New function, moved from trans-intrinsic.c + (gfc_conv_expr_descriptor): Walk array descriptor instead + of taking passed "ss". + (get_array_ctor_all_strlen, gfc_add_loop_ss_code, + gfc_conv_array_parameter): Update call and cleanup ss handling. + * trans-array.h (gfc_conv_expr_descriptor, + gfc_conv_array_parameter): Update prototype. + * trans-expr.c (gfc_conv_derived_to_class, + conv_isocbinding_procedure, gfc_conv_procedure_call, + gfc_trans_alloc_subarray_assign, gfc_trans_subcomponent_assign, + gfc_trans_pointer_assignment, gfc_trans_arrayfunc_assign): Update + call to gfc_conv_expr_descriptor and gfc_conv_array_parameter, and + clean up. + * trans-intrinsic.c (walk_coarray): Moved to trans-array.c + (trans_this_image, trans_image_index, gfc_conv_intrinsic_rank + gfc_conv_intrinsic_bound, gfc_conv_intrinsic_cobound, + gfc_conv_intrinsic_len, gfc_conv_intrinsic_size, + gfc_conv_intrinsic_sizeof, gfc_conv_intrinsic_storage_size, + gfc_conv_intrinsic_transfer, gfc_conv_allocated, + gfc_conv_associated, gfc_conv_intrinsic_loc, + conv_intrinsic_move_alloc): Update calls. + * trans-io.c (gfc_convert_array_to_string, set_internal_unit, + gfc_trans_transfer): Ditto. + * trans-stmt.c (gfc_conv_elemental_dependencies, + gfc_trans_sync, trans_associate_var, + gfc_trans_pointer_assign_need_temp): Ditto. + +2012-08-23 Jakub Jelinek <jakub@redhat.com> + + * trans-decl.c (trans_function_start, generate_coarray_init, + create_main_function, gfc_generate_constructors): Call + allocate_struct_function instead of init_function_start. + +2012-08-22 Tobias Burnus <burnus@net-b.de> + + * trans-expr.c (gfc_copy_class_to_class, + gfc_trans_arrayfunc_assign): Free loop and ss data. + * trans-intrinsic.c (gfc_trans_arrayfunc_assign): Free ss data. + +2012-08-21 Tobias Burnus <burnus@net-b.de> + + * parse.c (parse_contained): Include EXEC_END_PROCEDURE + in ns->code to make sure the gfc_code is freed. + +2012-08-20 Tobias Burnus <burnus@net-b.de> + + PR fortran/54301 + * expr.c (gfc_check_pointer_assign): Warn when a pointer, + which is a function result, might outlive its target. + +2012-08-20 Tobias Burnus <burnus@net-b.de> + + PR fortran/54301 + * expr.c (gfc_check_pointer_assign): Warn when the pointer + might outlive its target. + * gfortran.h (struct gfc_option_t): Add warn_target_lifetime. + * options.c (gfc_init_options, set_wall, gfc_handle_option): + handle it. + * invoke.texi (-Wtarget-lifetime): Document it. + (-Wall): Implied it. + * lang.opt (-Wtarget-lifetime): New flag. + +2012-08-19 Thomas König <tkoenig@gcc.gnu.org> + + PR fortran/54298 + * gfortran.h (struct gfc_option_t): Add warn_compare_reals. + * lang.opt: Add Wcompare-reals. + * invoke.texi: Document -Wcompare-reals. + * resolve.c (resolve_operator): If -Wcompare-reals is in effect, + warn about equality/inequality comparisions for REAL and COMPLEX. + * options.c (gfc_init_options): Set warn_compare_reals. + (set_Wall): Include warn_compare_reals in Wall. + (gfc_handle_option): Handle Wcompare_reals. + +2012-08-17 Jakub Jelinek <jakub@redhat.com> + + * array.c (gfc_match_array_ref): Fix up memset arguments. + +2012-08-16 Diego Novillo <dnovillo@google.com> + + Revert + + PR bootstrap/54281 + * gfortran.h: Do not include gmp.h. + +2012-08-16 Diego Novillo <dnovillo@google.com> + + PR bootstrap/54281 + * gfortran.h: Do not include gmp.h. + +2012-08-15 Janus Weil <janus@gcc.gnu.org> + + PR fortran/54243 + PR fortran/54244 + * resolve.c (check_typebound_baseobject): Check for class_ok attribute. + (resolve_procedure_interface,resolve_fl_derived0): Copy class_ok + attribute. + +2012-08-14 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/47586 + * trans-expr.c (expr_is_variable): Handle regular, procedure pointer, + and typebound functions returning a data pointer. + +2012-08-14 Mikael Morin <mikael@gcc.gnu.org> + + * decl.c (match_ppc_decl): Copy the procedure interface's symbol + as procedure interface's result. + +2012-08-14 Mikael Morin <mikael@gcc.gnu.org> + + * trans-expr.c (gfc_trans_scalar_assign): Rename argument, + extend comment. + +2012-08-14 Mikael Morin <mikael@gcc.gnu.org> + + * gfortran.h (gfc_get_proc_ptr_comp): New prototype. + (gfc_is_proc_ptr_comp): Update prototype. + * expr.c (gfc_get_proc_ptr_comp): New function based on the old + gfc_is_proc_ptr_comp. + (gfc_is_proc_ptr_comp): Call gfc_get_proc_ptr_comp. + (gfc_specification_expr, gfc_check_pointer_assign): Use + gfc_get_proc_ptr_comp. + * trans-array.c (gfc_walk_function_expr): Likewise. + * resolve.c (resolve_structure_cons, update_ppc_arglist, + resolve_ppc_call, resolve_expr_ppc): Likewise. + (resolve_function): Update call to gfc_is_proc_ptr_comp. + * dump-parse-tree.c (show_expr): Likewise. + * interface.c (compare_actual_formal): Likewise. + * match.c (gfc_match_pointer_assignment): Likewise. + * primary.c (gfc_match_varspec): Likewise. + * trans-io.c (gfc_trans_transfer): Likewise. + * trans-expr.c (gfc_conv_variable, conv_function_val, + conv_isocbinding_procedure, gfc_conv_procedure_call, + gfc_trans_pointer_assignment): Likewise. + (gfc_conv_procedure_call, gfc_trans_array_func_assign): + Use gfc_get_proc_ptr_comp. + +2012-08-14 Tobias Burnus <burnus@net-b.de> + + PR fortran/40881 + * error.c (gfc_notify_std): Reset cur_error_buffer->flag flag + when the error/warning has been printed. + * gfortran.h (gfc_sl_type): Add ST_LABEL_DO_TARGET. + * match.c (gfc_match_do): Use ST_LABEL_DO_TARGET. + * parse.c (check_statement_label): Use ST_LABEL_DO_TARGET. + (parse_executable): Add obsolescence check for DATA. + * resolve.c (resolve_branch): Handle ST_LABEL_DO_TARGET. + * symbol.c (gfc_define_st_label, gfc_reference_st_label): + Add obsolescence diagnostics. + * trans-stmt.c (gfc_trans_label_assign): Handle ST_LABEL_DO_TARGET. + +2012-08-14 Tobias Burnus <burnus@net-b.de> + + PR fortran/54234 + * check.c (gfc_check_cmplx): Add -Wconversion warning + when converting higher-precision REAL to default-precision + CMPLX without kind= parameter. + +2012-08-12 Tobias Burnus <burnus@net-b.de> + + PR fortran/54221 + * trans-decl.c (gfc_finish_var_decl, build_function_decl): + Fix setting private module vars/procs as TREE_PUBLIC(...) = 0. + +2012-08-09 Tobias Burnus <burnus@net-b.de> + + PR fortran/54199 + * intrinsic.c (gfc_warn_intrinsic_shadow): Better warning + for internal procedures. + +2012-08-06 Janus Weil <janus@gcc.gnu.org> + + PR fortran/35831 + * interface.c (check_result_characteristics): New function, which checks + the characteristics of function results. + (gfc_compare_interfaces,gfc_check_typebound_override): Call it. + +2012-08-02 Thomas König <tkoenig@gcc.gnu.org> + + PR fortran/54033 + * scanner.c (add_path_to_list): New argument warn. Don't + warn if it is true. + (gfc_add_include_path): Warn if directory is missing. + (gfc_add_intrinsic_modules_path): Do not warn if directory + is missing. + * optinons.c (gfc_handle_option): Do not add directory + for intrinsic modules to normal include path. + +2012-08-03 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/54166 + * trans-array.c (set_loop_bounds): Access specinfo using spec_dim. + +2012-08-02 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/48820 + * trans-array.c (gfc_conv_ss_startstride): Set the intrinsic + result's lower and upper bounds according to the rank. + (set_loop_bounds): Set the loop upper bound in the intrinsic case. + +2012-08-02 Mikael Morin <mikael@gcc.gnu.org> + + * trans-array.c (set_loop_bounds): Allow non-array-section to be + chosen using the stride and lower bound criteria. + +2012-08-02 Mikael Morin <mikael@gcc.gnu.org> + + * trans-array.c (set_loop_bounds): Remove useless dimension check. + Don't update loopspec if it would loose the wanted stride criterion. + +2012-08-02 Mikael Morin <mikael@gcc.gnu.org> + + * trans-array.h (gfc_conv_descriptor_rank): New prototype. + * trans-array.c (gfc_conv_descriptor_rank): New function moved and + renamed ... + * trans-intrinsic.c (get_rank_from_desc): ... from this one. + (gfc_conv_intrinsic_rank, gfc_conv_intrinsic_bound, + gfc_conv_associated): Also rename function calls. + +2012-08-02 Mikael Morin <mikael@gcc.gnu.org> + + * iresolve.c (resolve_bound, gfc_resolve_shape): + Don't set the shape for assumed rank arrays. + * simplify.c (gfc_simplify_shape): Don't try to simplify if the + argument is assumed rank. + +2012-08-02 Mikael Morin <mikael@gcc.gnu.org> + + * array.c (gfc_copy_array_ref): Don't copy the offset field. + * expr.c (find_array_section): Ignore the offset field. + * trans-expr.c (gfc_find_interface_mapping_to_ref): Don't apply + any interface mapping to the offset field. + * gfortran.h (struct gfc_array_ref): Remove the offset field. + +2012-08-02 Janus Weil <janus@gcc.gnu.org> + + PR fortran/54147 + * resolve.c (check_proc_interface): New routine for PROCEDURE interface + checks. + (resolve_procedure_interface,resolve_typebound_procedure, + resolve_fl_derived0): Call it. + +2012-08-01 Thomas König <tkoenig@gcc.gnu.org> + + PR fortran/54033 + * scanner.c (add_path_to_list): Emit warning if an error occurs + for an include path, if it is not present or if it is not a + directory. Do not add the path in these cases. + +2012-07-31 Janus Weil <janus@gcc.gnu.org> + + PR fortran/42418 + * decl.c (match_procedure_interface): Move some checks to + 'resolve_procedure_interface'. Set flavor if appropriate. + * expr.c (gfc_check_pointer_assign): Cleanup of 'gfc_is_intrinsic'. + * intrinsic.c (gfc_is_intrinsic): Additional checks for attributes which + identify a procedure as being non-intrinsic. + * resolve.c (resolve_procedure_interface): Checks moved here from + 'match_procedure_interface'. Minor cleanup. + (resolve_formal_arglist,resolve_symbol): Cleanup of + 'resolve_procedure_interface' + (resolve_actual_arglist,is_external_proc): Cleanup of + 'gfc_is_intrinsic'. + +2012-07-31 Janus Weil <janus@gcc.gnu.org> + + PR fortran/54134 + * dependency.c (gfc_dep_compare_expr): Check if arguments are NULL. + +2012-07-31 Tobias Burnus <burnus@net-b.de> + + * interface.c (gfc_procedure_use): Return gfc_try instead of void. + * gfortran.h (gfc_procedure_use): Update prototype. + * resolve.c (gfc_iso_c_func_interface): Allow noninteroperable + procedures for c_funloc for TS29113. + * (gfc_iso_c_sub_interface): Ditto for c_f_procpointer. Add + diagnostic for c_ptr vs. c_funptr for c_f_(proc)pointer. + +2012-07-30 Janus Weil <janus@gcc.gnu.org> + + PR fortran/51081 + * gfortran.h (gfc_resolve_intrinsic): Add prototype. + * expr.c (gfc_check_pointer_assign): Set INTRINSIC attribute if needed. + Check for invalid intrinsics. + * primary.c (gfc_match_rvalue): Check for intrinsics came too early. + Set procedure flavor if appropriate. + * resolve.c (resolve_intrinsic): Renamed to gfc_resolve_intrinsic. + (resolve_procedure_interface,resolve_procedure_expression, + resolve_function,resolve_fl_derived0,resolve_symbol): Ditto. + +2012-07-26 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/44354 + * trans-array.c (gfc_trans_array_constructor_value): + Evaluate the iteration bounds before the inner variable shadows + the outer. + +2012-07-26 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/44354 + * array.c (sought_symbol): New variable. + (expr_is_sought_symbol_ref, find_symbol_in_expr): New functions. + (resolve_array_list): Check for references to the induction + variable in the iteration bounds and issue a diagnostic if some + are found. + +2012-07-26 Alessandro Fanfarillo <fanfarillo.gcc@gmail.com> + Tobias Burnus <burnus@net-b.de> + + * module.c (mio_array_spec): Don't read as->lower for + assumed-rank arrays. + +2012-07-25 Tobias Burnus <burnus@net-b.de> + + * trans-types.c (gfc_real16_is_float128): Fix spelling + in a comment. + * trans.h (struct gfc_array_info): Ditto. + * gfortran.h (gfc_expr): Ditto. + * simplify.c (gfc_count): Ditto. + * trans-expr.c (gfc_copy_class_to_class, + conv_parent_component_references, + gfc_trans_pointer_assignment): Ditto. + * expr.c (check_pointer_assign): Fix diagnostic spelling. + * interface.c (compare_parameter): Ditto. + * parse.c (use_modules, parse_associate): Ditto. + * decl.c (match_char_length): Fix spelling of the + an function argument. + +2012-07-21 Tobias Burnus <burnus@net-b.de> + + * iso-c-binding.def (C_PTRDIFF_T): New TS29113 parameter. + * intrinsic.texi (ISO_C_BINDING): Document it. + +2012-07-21 Tobias Burnus <burnus@net-b.de> + + PR fortran/48820 + * trans-intrinsic.c (gfc_conv_intrinsic_bound): Support + lbound/ubound with dim= for assumed-rank arrays. + * array.c (gfc_set_array_spec): Reject coarrays with + assumed shape. + * decl.c (merge_array_spec): Ditto. Return gfc_try. + (match_attr_spec, match_attr_spec): Update call. + +2012-07-21 Tobias Burnus <burnus@net-b.de> + + * resolve.c (resolve_formal_arglist): Put variable + declaration before the first assignment. + +2012-07-21 Tobias Burnus <burnus@net-b.de> + + * trans-expr.c (gfc_conv_derived_to_class): Fix argument passed + to class_array_data_assign. + +2012-07-20 Tobias Burnus <burnus@net-b.de> + + * decl.c (gfc_verify_c_interop_param): Allow assumed-shape + with -std=f2008ts. + +2012-07-20 Tobias Burnus <burnus@net-b.de> + + PR fortran/48820 + * array.c (match_array_element_spec, gfc_match_array_spec, + spec_size, gfc_array_dimen_size): Add support for + assumed-rank arrays. + * check.c (dim_rank_check): Ditto. + * class.c (gfc_add_component_ref): Ditto. + (gfc_build_class_symbol): Regard assumed-rank arrays + as having GFC_MAX_DIMENSIONS. And build extra class + container for a scalar pointer class. + * decl.c (merge_array_spec): Add assert. + * dump-parse-tree.c (show_array_spec): Add support for + assumed-rank arrays. + * expr.c (gfc_is_simply_contiguous): Ditto. + * gfortran.h (array_type): Ditto. + (gfc_array_spec, gfc_expr): Add comment to "rank" field. + * interface.c (compare_type_rank, argument_rank_mismatch, + compare_parameter, gfc_procedure_use): Ditto. + (compare_actual_formal): Fix NULL() to optional-dummy + handling for polymorphic dummies. + * module.c (mio_typespec): Add support for + assumed-rank arrays. + * resolve.c (resolve_formal_arglist, resolve_actual_arglist, + resolve_elemental_actual, resolve_global_procedure, + expression_shape, resolve_variable, update_ppc_arglist, + check_typebound_baseobject, gfc_resolve_expr, + resolve_fl_var_and_proc, gfc_resolve_finalizers, + resolve_typebound_procedure, resolve_symbol): Ditto. + (assumed_type_expr_allowed): Remove static variable. + (actual_arg, first_actual_arg): New static variables. + * simplify.c (simplify_bound, gfc_simplify_range): Add + support for assumed-rank arrays. + * trans-array.c (gfc_conv_array_parameter): Ditto. + (gfc_get_descriptor_dimension): New function, which returns + the descriptor. + (gfc_conv_descriptor_dimension): Use it. + (gfc_conv_descriptor_stride_get, gfc_conv_array_parameter): + Handle GFC_ARRAY_ASSUMED_RANK_CONT and AS_ASSUMED_RANK. + * trans-array.h (gfc_get_descriptor_dimension): New prototype. + * trans-decl. (gfc_build_dummy_array_decl, + gfc_trans_deferred_vars, add_argument_checking): Add + support for assumed-rank arrays. + * trans-expr.c (gfc_conv_expr_present, gfc_conv_variable, + gfc_conv_procedure_call): Ditto. + (get_scalar_to_descriptor_type, class_array_data_assign, + conv_scalar_to_descriptor): New static functions. + (gfc_conv_derived_to_class, gfc_conv_class_to_class): Use + them. + * trans-intrinsic.c (get_rank_from_desc): New function. + (gfc_conv_intrinsic_rank, gfc_conv_associated): Use it. + * trans-types.c (gfc_array_descriptor_base_caf, + gfc_array_descriptor_base): Make space for scalar array. + (gfc_is_nodesc_array, gfc_is_nodesc_array, + gfc_build_array_type, gfc_get_array_descriptor_base): Add + support for assumed-rank arrays. + * trans.h (gfc_array_kind): Add GFC_ARRAY_ASSUMED_RANK and + GFC_ARRAY_ASSUMED_RANK_CONT. + +2012-07-19 Tobias Burnus <burnus@net-b.de> + + * trans-expr.c (gfc_conv_procedure_call): Fix handling + of polymorphic arguments. + * resolve.c (resolve_formal_arglist): Ditto, mark polymorphic + assumed-shape arrays as such. + +2012-07-19 Tobias Burnus <burnus@net-b.de> + + * interface.c (compare_parameter, compare_actual_formal): Fix + handling of polymorphic arguments. + +2012-07-17 Janus Weil <janus@gcc.gnu.org> + + PR fortran/51081 + * error.c (gfc_notify_std): Automatically print the relevant Fortran + standard version. + * arith.c (arith_power): Remove explicit standard reference string. + * array.c (gfc_match_array_spec, gfc_match_array_constructor): Ditto. + * check.c (gfc_check_a_p, gfc_check_besn, gfc_check_count, + gfc_check_float, gfc_check_fn_rc2008, gfc_check_iand, + gfc_check_ichar_iachar, gfc_check_ieor, gfc_check_index, gfc_check_ior, + gfc_check_lbound, gfc_check_len_lentrim, check_rest, gfc_check_min_max, + gfc_check_null, gfc_check_scan, gfc_check_selected_real_kind, + gfc_check_shape, gfc_check_size, gfc_check_sngl, gfc_check_ubound, + gfc_check_verify): Ditto. + * data.c (gfc_assign_data_value): Ditto. + * decl.c (var_element, char_len_param_value, match_char_length, + gfc_verify_c_interop_param, match_pointer_init, variable_decl, + gfc_match_decl_type_spec, gfc_match_import, match_attr_spec, + gfc_match_prefix, gfc_match_suffix, match_ppc_decl, + match_procedure_in_interface, gfc_match_procedure,gfc_match_entry, + gfc_match_subroutine, gfc_match_end, gfc_match_codimension, + gfc_match_protected, gfc_match_value, gfc_match_volatile, + gfc_match_asynchronous, gfc_match_modproc, gfc_get_type_attr_spec, + gfc_match_enum, match_procedure_in_type): Ditto. + * expr.c (check_elemental, gfc_check_assign, gfc_check_pointer_assign): + Ditto. + * interface.c (gfc_match_abstract_interface, check_interface0): Ditto. + * intrinsic.c (gfc_intrinsic_func_interface): Ditto. + * io.c (format_lex, resolve_tag_format, resolve_tag, + compare_to_allowed_values, gfc_match_open, gfc_match_rewind, + gfc_resolve_dt, gfc_match_wait): Ditto. + * match.c (match_arithmetic_if, gfc_match_if, gfc_match_critical, + gfc_match_do, match_exit_cycle, gfc_match_pause, gfc_match_stop, + gfc_match_lock, sync_statement, gfc_match_assign, gfc_match_goto, + gfc_match_allocate, gfc_match_return, gfc_match_st_function): Ditto. + * module.c (gfc_match_use, gfc_use_module): Ditto. + * parse.c (parse_derived_contains, parse_block_construct, + parse_associate, parse_contained): Ditto. + * primary.c (match_hollerith_constant, match_boz_constant, + match_real_constant, match_sym_complex_part, match_arg_list_function, + build_actual_constructor, gfc_convert_to_structure_constructor): Ditto. + * resolve.c (resolve_formal_arglist, resolve_entries, + resolve_common_blocks, resolve_actual_arglist, gfc_resolve_index_1, + gfc_resolve_iterator_expr, resolve_ordinary_assign, + resolve_fl_var_and_proc, resolve_fl_variable_derived, + resolve_fl_procedure, resolve_fl_derived0, resolve_fl_derived, + resolve_fl_namelist, resolve_symbol, resolve_fntype): Ditto. + * symbol.c (check_conflict, conflict, gfc_add_is_bind_c, + gfc_add_extension, gfc_check_symbol_typed): Ditto. + +2012-07-17 Tobias Burnus <burnus@net-b.de> + + PR fortran/53985 + * decl.c (gfc_verify_c_interop_param): Make warning conditional + on -Wc-binding-type works and improve the wording. + +2012-07-17 Tobias Burnus <burnus@net-b.de> + + PR fortran/52101 + * decl.c (match_char_length): Extra argument, show obsolenscent + warning only if *length is used after the typename. + (variable_decl, gfc_match_char_spec): Update call + +2012-07-17 Tobias Burnus <burnus@net-b.de> + Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/49265 + * decl.c (match_procedure_in_interface): Support "::" for + Fortran 2008 and later. + +2012-07-16 Thomas König <tkoenig@gcc.gnu.org> + + PR fortran/53824 + * resolve.c (resolve_allocate_deallocate): If both + start indices are NULL, skip the test for equality. + +2012-07-16 Steven Bosscher <steven@gcc.gnu.org> + + * f95-lang.c: Include dumpfile.h instead of tree-dump.h. + * Make-lang.in: Fix dependencies. + +2012-07-16 Janus Weil <janus@gcc.gnu.org> + + PR fortran/53956 + * gfortran.h (gfc_copy_formal_args,gfc_copy_formal_args_ppc): Modified + prototypes. + * symbol.c (gfc_copy_formal_args): New argument 'if_src'. Copy if_source + of dummy procedures. + (gfc_copy_formal_args_ppc): Ditto. + * resolve.c (resolve_procedure_interface): Pass IFSRC_DECL to + gfc_copy_formal_args. + (resolve_fl_derived0): Pass IFSRC_DECL to gfc_copy_formal_args_ppc. + +2012-07-12 Tobias Burnus <burnus@net-b.de> + + * trans-expr.c (conv_isocbinding_procedure): Generate c_f_pointer code + inline. + +2012-07-11 Steven Bosscher <steven@gcc.gnu.org> + + * trans.c: Do not include defaults.h. + * trans-intrinsic.c: Likewise. + +2012-07-08 Steven Bosscher <steven@gcc.gnu.org> + + * gfortran.h: Do not include coretypes.h here. + Make it an error to include this before coretypes.h + * openmp.c: Include coretypes.h. + * interface.c: Likewise. + * intrinsic.c: Likewise. + * symbol.c: Likewise. + * class.c: Likewise. + * decl.c: Likewise. + * matchexp.c: Likewise. + * dump-parse-tree.c: Likewise. + * array.c: Likewise. + * constructor.c: Likewise. + * error.c: Likewise. + * data.c: Likewise. + * expr.c: Likewise. + * module.c: Likewise. + * scanner.c: Likewise. + * bbt.c: Likewise. + * io.c: Likewise. + * frontend-passes.c: Likewise. + * resolve.c: Likewise. + * st.c: Likewise. + * target-memory.c: Likewise. + * match.c: Likewise. + * arith.c: Likewise. + * parse.c: Likewise. + * check.c: Likewise. + * dependency.c: Likewise. + * primary.c: Likewise. + * misc.c: Likewise. + * simplify.c: Likewise. + +2012-07-05 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/53732 + * trans-array.c (gfc_add_loop_ss_code): Disable self recursive calls + handling nested loop(s) if the subscript flag is true. + +2012-07-05 Uros Bizjak <ubizjak@gmail.com> + + PR fortran/53449 + * parse.c (gfc_parse_file): Initialize errors_before. + 2012-06-27 Janus Weil <janus@gcc.gnu.org> PR fortran/41951 @@ -308,8 +950,8 @@ 2012-05-05 Janne Blomqvist <jb@gcc.gnu.org> - * gfortran.texi (GFORTRAN_TMPDIR): Rename to TMPDIR, explain - algorithm for choosing temp directory. + * gfortran.texi (GFORTRAN_TMPDIR): Rename to TMPDIR, explain + algorithm for choosing temp directory. 2012-05-04 Tobias Burnus <burnus@net-b.de> diff --git a/gcc/fortran/Make-lang.in b/gcc/fortran/Make-lang.in index 7bcc19d3c7a..a74eb7f7278 100644 --- a/gcc/fortran/Make-lang.in +++ b/gcc/fortran/Make-lang.in @@ -329,7 +329,7 @@ $(F95_PARSER_OBJS): fortran/gfortran.h fortran/libgfortran.h \ fortran/intrinsic.h fortran/match.h fortran/constructor.h \ fortran/parse.h fortran/arith.h fortran/target-memory.h \ $(CONFIG_H) $(SYSTEM_H) $(TM_H) $(TM_P_H) coretypes.h \ - $(RTL_H) $(TREE_H) $(TREE_DUMP_H) $(GGC_H) $(EXPR_H) \ + dumpfile.h $(TREE_H) dumpfile.h $(GGC_H) \ $(FLAGS_H) $(DIAGNOSTIC_H) errors.h $(FUNCTION_H) \ fortran/iso-c-binding.def fortran/iso-fortran-env.def fortran/openmp.o: pointer-set.h $(TARGET_H) toplev.h diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c index 53a9dad42fe..6fa7c70fe9c 100644 --- a/gcc/fortran/arith.c +++ b/gcc/fortran/arith.c @@ -27,6 +27,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" +#include "coretypes.h" #include "flags.h" #include "gfortran.h" #include "arith.h" @@ -902,7 +903,7 @@ arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) if (gfc_init_expr_flag) { - if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger " + if (gfc_notify_std (GFC_STD_F2003, "Noninteger " "exponent in an initialization " "expression at %L", &op2->where) == FAILURE) return ARITH_PROHIBIT; @@ -924,7 +925,7 @@ arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) { if (gfc_init_expr_flag) { - if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger " + if (gfc_notify_std (GFC_STD_F2003, "Noninteger " "exponent in an initialization " "expression at %L", &op2->where) == FAILURE) return ARITH_PROHIBIT; diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index b36d517cff7..07fecd8aaf3 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -1,6 +1,6 @@ /* Array things - Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010 - Free Software Foundation, Inc. + Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010, + 2011, 2012 Free Software Foundation, Inc. Contributed by Andy Vaught This file is part of GCC. @@ -21,6 +21,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" +#include "coretypes.h" #include "gfortran.h" #include "match.h" #include "constructor.h" @@ -49,8 +50,6 @@ gfc_copy_array_ref (gfc_array_ref *src) dest->stride[i] = gfc_copy_expr (src->stride[i]); } - dest->offset = gfc_copy_expr (src->offset); - return dest; } @@ -160,7 +159,7 @@ gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init, match m; bool matched_bracket = false; - memset (ar, '\0', sizeof (ar)); + memset (ar, '\0', sizeof (*ar)); ar->where = gfc_current_locus; ar->as = as; @@ -389,9 +388,11 @@ match_array_element_spec (gfc_array_spec *as) { gfc_expr **upper, **lower; match m; + int rank; - lower = &as->lower[as->rank + as->corank - 1]; - upper = &as->upper[as->rank + as->corank - 1]; + rank = as->rank == -1 ? 0 : as->rank; + lower = &as->lower[rank + as->corank - 1]; + upper = &as->upper[rank + as->corank - 1]; if (gfc_match_char ('*') == MATCH_YES) { @@ -457,6 +458,20 @@ gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim) goto coarray; } + if (gfc_match (" .. )") == MATCH_YES) + { + as->type = AS_ASSUMED_RANK; + as->rank = -1; + + if (gfc_notify_std (GFC_STD_F2008_TS, "Assumed-rank array at %C") + == FAILURE) + goto cleanup; + + if (!match_codim) + goto done; + goto coarray; + } + for (;;) { as->rank++; @@ -535,6 +550,9 @@ gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim) gfc_error ("Bad specification for assumed size array at %C"); goto cleanup; + + case AS_ASSUMED_RANK: + gcc_unreachable (); } if (gfc_match_char (')') == MATCH_YES) @@ -554,7 +572,7 @@ gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim) } if (as->corank + as->rank >= 7 - && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Array " + && gfc_notify_std (GFC_STD_F2008, "Array " "specification at %C with more than 7 dimensions") == FAILURE) goto cleanup; @@ -567,7 +585,7 @@ coarray: if (gfc_match_char ('[') != MATCH_YES) goto done; - if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Coarray declaration at %C") + if (gfc_notify_std (GFC_STD_F2008, "Coarray declaration at %C") == FAILURE) goto cleanup; @@ -641,6 +659,9 @@ coarray: case AS_ASSUMED_SIZE: gfc_error ("Bad specification for assumed size array at %C"); goto cleanup; + + case AS_ASSUMED_RANK: + gcc_unreachable (); } if (gfc_match_char (']') == MATCH_YES) @@ -727,6 +748,14 @@ gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc) return SUCCESS; } + if ((sym->as->type == AS_ASSUMED_RANK && as->corank) + || (as->type == AS_ASSUMED_RANK && sym->as->corank)) + { + gfc_error ("The assumed-rank array '%s' at %L shall not have a " + "codimension", sym->name, error_loc); + return FAILURE; + } + if (as->corank) { /* The "sym" has no corank (checked via gfc_add_codimension). Thus @@ -1026,7 +1055,7 @@ gfc_match_array_constructor (gfc_expr **result) return MATCH_NO; else { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: [...] " + if (gfc_notify_std (GFC_STD_F2003, "[...] " "style array constructors at %C") == FAILURE) return MATCH_ERROR; end_delim = " ]"; @@ -1046,7 +1075,7 @@ gfc_match_array_constructor (gfc_expr **result) if (seen_ts) { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Array constructor " + if (gfc_notify_std (GFC_STD_F2003, "Array constructor " "including type specification at %C") == FAILURE) goto cleanup; @@ -1717,6 +1746,50 @@ gfc_expanded_ac (gfc_expr *e) /*************** Type resolution of array constructors ***************/ + +/* The symbol expr_is_sought_symbol_ref will try to find. */ +static const gfc_symbol *sought_symbol = NULL; + + +/* Tells whether the expression E is a variable reference to the symbol + in the static variable SOUGHT_SYMBOL, and sets the locus pointer WHERE + accordingly. + To be used with gfc_expr_walker: if a reference is found we don't need + to look further so we return 1 to skip any further walk. */ + +static int +expr_is_sought_symbol_ref (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, + void *where) +{ + gfc_expr *expr = *e; + locus *sym_loc = (locus *)where; + + if (expr->expr_type == EXPR_VARIABLE + && expr->symtree->n.sym == sought_symbol) + { + *sym_loc = expr->where; + return 1; + } + + return 0; +} + + +/* Tells whether the expression EXPR contains a reference to the symbol + SYM and in that case sets the position SYM_LOC where the reference is. */ + +static bool +find_symbol_in_expr (gfc_symbol *sym, gfc_expr *expr, locus *sym_loc) +{ + int ret; + + sought_symbol = sym; + ret = gfc_expr_walker (&expr, &expr_is_sought_symbol_ref, sym_loc); + sought_symbol = NULL; + return ret; +} + + /* Recursive array list resolution function. All of the elements must be of the same type. */ @@ -1725,14 +1798,46 @@ resolve_array_list (gfc_constructor_base base) { gfc_try t; gfc_constructor *c; + gfc_iterator *iter; t = SUCCESS; for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) { - if (c->iterator != NULL - && gfc_resolve_iterator (c->iterator, false) == FAILURE) - t = FAILURE; + iter = c->iterator; + if (iter != NULL) + { + gfc_symbol *iter_var; + locus iter_var_loc; + + if (gfc_resolve_iterator (iter, false) == FAILURE) + t = FAILURE; + + /* Check for bounds referencing the iterator variable. */ + gcc_assert (iter->var->expr_type == EXPR_VARIABLE); + iter_var = iter->var->symtree->n.sym; + if (find_symbol_in_expr (iter_var, iter->start, &iter_var_loc)) + { + if (gfc_notify_std (GFC_STD_LEGACY, "AC-IMPLIED-DO initial " + "expression references control variable " + "at %L", &iter_var_loc) == FAILURE) + t = FAILURE; + } + if (find_symbol_in_expr (iter_var, iter->end, &iter_var_loc)) + { + if (gfc_notify_std (GFC_STD_LEGACY, "AC-IMPLIED-DO final " + "expression references control variable " + "at %L", &iter_var_loc) == FAILURE) + t = FAILURE; + } + if (find_symbol_in_expr (iter_var, iter->step, &iter_var_loc)) + { + if (gfc_notify_std (GFC_STD_LEGACY, "AC-IMPLIED-DO step " + "expression references control variable " + "at %L", &iter_var_loc) == FAILURE) + t = FAILURE; + } + } if (gfc_resolve_expr (c->expr) == FAILURE) t = FAILURE; @@ -1959,6 +2064,9 @@ spec_size (gfc_array_spec *as, mpz_t *result) mpz_t size; int d; + if (as->type == AS_ASSUMED_RANK) + return FAILURE; + mpz_init_set_ui (*result, 1); for (d = 0; d < as->rank; d++) @@ -2115,6 +2223,9 @@ gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result) if (array->ts.type == BT_CLASS) return FAILURE; + if (array->rank == -1) + return FAILURE; + if (dimen < 0 || array == NULL || dimen > array->rank - 1) gfc_internal_error ("gfc_array_dimen_size(): Bad dimension"); diff --git a/gcc/fortran/bbt.c b/gcc/fortran/bbt.c index a78467be8b7..000f04bcbf8 100644 --- a/gcc/fortran/bbt.c +++ b/gcc/fortran/bbt.c @@ -38,6 +38,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" +#include "coretypes.h" #include "gfortran.h" typedef struct gfc_treap diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 7d505d5e9d9..2235b52d6d3 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -29,6 +29,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" +#include "coretypes.h" #include "flags.h" #include "gfortran.h" #include "intrinsic.h" @@ -619,6 +620,10 @@ dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed) else rank = array->rank; + /* Assumed-rank array. */ + if (rank == -1) + rank = GFC_MAX_DIMENSIONS; + if (array->expr_type == EXPR_VARIABLE) { ar = gfc_find_array_ref (array); @@ -861,7 +866,7 @@ gfc_check_a_p (gfc_expr *a, gfc_expr *p) if (a->ts.kind != p->ts.kind) { - if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L", + if (gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L", &p->where) == FAILURE) return FAILURE; } @@ -1080,7 +1085,7 @@ gfc_check_besn (gfc_expr *n, gfc_expr *x) { int i; gfc_extract_int (n, &i); - if (i < 0 && gfc_notify_std (GFC_STD_GNU, "Extension: Negative argument " + if (i < 0 && gfc_notify_std (GFC_STD_GNU, "Negative argument " "N at %L", &n->where) == FAILURE) return FAILURE; } @@ -1273,6 +1278,17 @@ gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind) if (kind_check (kind, 2, BT_COMPLEX) == FAILURE) return FAILURE; + if (!kind && gfc_option.gfc_warn_conversion + && x->ts.type == BT_REAL && x->ts.kind > gfc_default_real_kind) + gfc_warning_now ("Conversion from %s to default-kind COMPLEX(%d) at %L " + "might loose precision, consider using the KIND argument", + gfc_typename (&x->ts), gfc_default_real_kind, &x->where); + else if (y && !kind && gfc_option.gfc_warn_conversion + && y->ts.type == BT_REAL && y->ts.kind > gfc_default_real_kind) + gfc_warning_now ("Conversion from %s to default-kind COMPLEX(%d) at %L " + "might loose precision, consider using the KIND argument", + gfc_typename (&y->ts), gfc_default_real_kind, &y->where); + return SUCCESS; } @@ -1305,7 +1321,7 @@ gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind) return FAILURE; if (kind_check (kind, 2, BT_INTEGER) == FAILURE) return FAILURE; - if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic " + if (kind && gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic " "with KIND argument at %L", gfc_current_intrinsic, &kind->where) == FAILURE) return FAILURE; @@ -1663,7 +1679,7 @@ gfc_check_float (gfc_expr *a) return FAILURE; if ((a->ts.kind != gfc_default_integer_kind) - && gfc_notify_std (GFC_STD_GNU, "GNU extension: non-default INTEGER " + && gfc_notify_std (GFC_STD_GNU, "non-default INTEGER " "kind argument to %s intrinsic at %L", gfc_current_intrinsic, &a->where) == FAILURE ) return FAILURE; @@ -1723,7 +1739,7 @@ gfc_check_fn_rc2008 (gfc_expr *a) return FAILURE; if (a->ts.type == BT_COMPLEX - && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: COMPLEX argument '%s' " + && gfc_notify_std (GFC_STD_F2008, "COMPLEX argument '%s' " "argument of '%s' intrinsic at %L", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, &a->where) == FAILURE) @@ -1791,7 +1807,7 @@ gfc_check_iand (gfc_expr *i, gfc_expr *j) if (i->ts.kind != j->ts.kind) { - if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L", + if (gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L", &i->where) == FAILURE) return FAILURE; } @@ -1836,7 +1852,7 @@ gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind) if (kind_check (kind, 1, BT_INTEGER) == FAILURE) return FAILURE; - if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic " + if (kind && gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic " "with KIND argument at %L", gfc_current_intrinsic, &kind->where) == FAILURE) return FAILURE; @@ -1917,7 +1933,7 @@ gfc_check_ieor (gfc_expr *i, gfc_expr *j) if (i->ts.kind != j->ts.kind) { - if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L", + if (gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L", &i->where) == FAILURE) return FAILURE; } @@ -1939,7 +1955,7 @@ gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back, if (kind_check (kind, 3, BT_INTEGER) == FAILURE) return FAILURE; - if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic " + if (kind && gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic " "with KIND argument at %L", gfc_current_intrinsic, &kind->where) == FAILURE) return FAILURE; @@ -1991,7 +2007,7 @@ gfc_check_ior (gfc_expr *i, gfc_expr *j) if (i->ts.kind != j->ts.kind) { - if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type kinds at %L", + if (gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L", &i->where) == FAILURE) return FAILURE; } @@ -2133,7 +2149,7 @@ gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) if (kind_check (kind, 2, BT_INTEGER) == FAILURE) return FAILURE; - if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic " + if (kind && gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic " "with KIND argument at %L", gfc_current_intrinsic, &kind->where) == FAILURE) return FAILURE; @@ -2178,7 +2194,7 @@ gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind) if (kind_check (kind, 1, BT_INTEGER) == FAILURE) return FAILURE; - if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic " + if (kind && gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic " "with KIND argument at %L", gfc_current_intrinsic, &kind->where) == FAILURE) return FAILURE; @@ -2343,7 +2359,7 @@ check_rest (bt type, int kind, gfc_actual_arglist *arglist) { if (x->ts.type == type) { - if (gfc_notify_std (GFC_STD_GNU, "Extension: Different type " + if (gfc_notify_std (GFC_STD_GNU, "Different type " "kinds at %L", &x->where) == FAILURE) return FAILURE; } @@ -2380,7 +2396,7 @@ gfc_check_min_max (gfc_actual_arglist *arg) if (x->ts.type == BT_CHARACTER) { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic " + if (gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic " "with CHARACTER argument at %L", gfc_current_intrinsic, &x->where) == FAILURE) return FAILURE; @@ -2862,7 +2878,7 @@ gfc_check_null (gfc_expr *mold) } if (attr.allocatable - && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NULL intrinsic with " + && gfc_notify_std (GFC_STD_F2003, "NULL intrinsic with " "allocatable MOLD at %L", &mold->where) == FAILURE) return FAILURE; @@ -3398,7 +3414,7 @@ gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind) if (kind_check (kind, 3, BT_INTEGER) == FAILURE) return FAILURE; - if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic " + if (kind && gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic " "with KIND argument at %L", gfc_current_intrinsic, &kind->where) == FAILURE) return FAILURE; @@ -3459,7 +3475,7 @@ gfc_try gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix) { if (p == NULL && r == NULL - && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: SELECTED_REAL_KIND with" + && gfc_notify_std (GFC_STD_F2008, "SELECTED_REAL_KIND with" " neither 'P' nor 'R' argument at %L", gfc_current_intrinsic_where) == FAILURE) return FAILURE; @@ -3490,7 +3506,7 @@ gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix) if (scalar_check (radix, 1) == FAILURE) return FAILURE; - if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: '%s' intrinsic with " + if (gfc_notify_std (GFC_STD_F2008, "'%s' intrinsic with " "RADIX argument at %L", gfc_current_intrinsic, &radix->where) == FAILURE) return FAILURE; @@ -3532,7 +3548,7 @@ gfc_check_shape (gfc_expr *source, gfc_expr *kind) if (kind_check (kind, 1, BT_INTEGER) == FAILURE) return FAILURE; - if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic " + if (kind && gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic " "with KIND argument at %L", gfc_current_intrinsic, &kind->where) == FAILURE) return FAILURE; @@ -3587,7 +3603,7 @@ gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) if (kind_check (kind, 2, BT_INTEGER) == FAILURE) return FAILURE; - if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic " + if (kind && gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic " "with KIND argument at %L", gfc_current_intrinsic, &kind->where) == FAILURE) return FAILURE; @@ -3645,7 +3661,7 @@ gfc_check_sngl (gfc_expr *a) return FAILURE; if ((a->ts.kind != gfc_default_double_kind) - && gfc_notify_std (GFC_STD_GNU, "GNU extension: non double precision " + && gfc_notify_std (GFC_STD_GNU, "non double precision " "REAL argument to %s intrinsic at %L", gfc_current_intrinsic, &a->where) == FAILURE) return FAILURE; @@ -4126,7 +4142,7 @@ gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) if (kind_check (kind, 2, BT_INTEGER) == FAILURE) return FAILURE; - if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic " + if (kind && gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic " "with KIND argument at %L", gfc_current_intrinsic, &kind->where) == FAILURE) return FAILURE; @@ -4255,7 +4271,7 @@ gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind) if (kind_check (kind, 3, BT_INTEGER) == FAILURE) return FAILURE; - if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic " + if (kind && gfc_notify_std (GFC_STD_F2003, "'%s' intrinsic " "with KIND argument at %L", gfc_current_intrinsic, &kind->where) == FAILURE) return FAILURE; diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index c71aa4a7c48..21a91baec20 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -48,6 +48,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" +#include "coretypes.h" #include "gfortran.h" #include "constructor.h" @@ -219,7 +220,7 @@ gfc_add_component_ref (gfc_expr *e, const char *name) void gfc_add_class_array_ref (gfc_expr *e) { - int rank = CLASS_DATA (e)->as->rank; + int rank = CLASS_DATA (e)->as->rank; gfc_array_spec *as = CLASS_DATA (e)->as; gfc_ref *ref = NULL; gfc_add_component_ref (e, "_data"); @@ -497,6 +498,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, gfc_symbol *fclass; gfc_symbol *vtab; gfc_component *c; + int rank; if (as && *as && (*as)->type == AS_ASSUMED_SIZE) { @@ -517,11 +519,14 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, return SUCCESS; /* Determine the name of the encapsulating type. */ + rank = !(*as) || (*as)->rank == -1 ? GFC_MAX_DIMENSIONS : (*as)->rank; get_unique_hashed_string (tname, ts->u.derived); if ((*as) && attr->allocatable) - sprintf (name, "__class_%s_%d_%da", tname, (*as)->rank, (*as)->corank); + sprintf (name, "__class_%s_%d_%da", tname, rank, (*as)->corank); + else if ((*as) && attr->pointer) + sprintf (name, "__class_%s_%d_%dp", tname, rank, (*as)->corank); else if ((*as)) - sprintf (name, "__class_%s_%d_%d", tname, (*as)->rank, (*as)->corank); + sprintf (name, "__class_%s_%d_%d", tname, rank, (*as)->corank); else if (attr->pointer) sprintf (name, "__class_%s_p", tname); else if (attr->allocatable) diff --git a/gcc/fortran/constructor.c b/gcc/fortran/constructor.c index 600488d640f..182d00d165d 100644 --- a/gcc/fortran/constructor.c +++ b/gcc/fortran/constructor.c @@ -20,6 +20,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" +#include "coretypes.h" #include "gfortran.h" #include "constructor.h" diff --git a/gcc/fortran/data.c b/gcc/fortran/data.c index 67da371ad54..385ca898dcd 100644 --- a/gcc/fortran/data.c +++ b/gcc/fortran/data.c @@ -35,6 +35,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" +#include "coretypes.h" #include "gfortran.h" #include "data.h" #include "constructor.h" @@ -314,7 +315,7 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index, exprd = (LOCATION_LINE (con->expr->where.lb->location) > LOCATION_LINE (rvalue->where.lb->location)) ? con->expr : rvalue; - if (gfc_notify_std (GFC_STD_GNU,"Extension: " + if (gfc_notify_std (GFC_STD_GNU, "re-initialization of '%s' at %L", symbol->name, &exprd->where) == FAILURE) return FAILURE; @@ -480,7 +481,7 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index, expr = (LOCATION_LINE (init->where.lb->location) > LOCATION_LINE (rvalue->where.lb->location)) ? init : rvalue; - if (gfc_notify_std (GFC_STD_GNU,"Extension: " + if (gfc_notify_std (GFC_STD_GNU, "re-initialization of '%s' at %L", symbol->name, &expr->where) == FAILURE) return FAILURE; diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 26b5059cd9f..efd21dc7ec7 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -21,6 +21,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" +#include "coretypes.h" #include "gfortran.h" #include "match.h" #include "parse.h" @@ -268,7 +269,7 @@ var_element (gfc_data_variable *new_var) if (gfc_current_state () != COMP_BLOCK_DATA && sym->attr.in_common - && gfc_notify_std (GFC_STD_GNU, "Extension: initialization of " + && gfc_notify_std (GFC_STD_GNU, "initialization of " "common block variable '%s' in DATA statement at %C", sym->name) == FAILURE) return MATCH_ERROR; @@ -588,11 +589,18 @@ cleanup: /* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */ -static void +static gfc_try merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy) { int i; + if ((from->type == AS_ASSUMED_RANK && to->corank) + || (to->type == AS_ASSUMED_RANK && from->corank)) + { + gfc_error ("The assumed-rank array at %C shall not have a codimension"); + return FAILURE; + } + if (to->rank == 0 && from->rank > 0) { to->rank = from->rank; @@ -638,6 +646,8 @@ merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy) } } } + + return SUCCESS; } @@ -676,7 +686,7 @@ char_len_param_value (gfc_expr **expr, bool *deferred) if (gfc_match_char (':') == MATCH_YES) { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: deferred type " + if (gfc_notify_std (GFC_STD_F2003, "deferred type " "parameter at %C") == FAILURE) return MATCH_ERROR; @@ -722,7 +732,7 @@ syntax: char_len_param_value in parenthesis. */ static match -match_char_length (gfc_expr **expr, bool *deferred) +match_char_length (gfc_expr **expr, bool *deferred, bool obsolescent_check) { int length; match m; @@ -738,8 +748,9 @@ match_char_length (gfc_expr **expr, bool *deferred) if (m == MATCH_YES) { - if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: " - "Old-style character length at %C") == FAILURE) + if (obsolescent_check + && gfc_notify_std (GFC_STD_F95_OBS, + "Old-style character length at %C") == FAILURE) return MATCH_ERROR; *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, length); return m; @@ -880,7 +891,6 @@ get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry) return rc; sym = *result; - gfc_current_ns->refs++; if (sym && !sym->gfc_new && gfc_current_state () != COMP_INTERFACE) { @@ -1026,8 +1036,8 @@ gfc_verify_c_interop_param (gfc_symbol *sym) "because it is polymorphic", sym->name, &(sym->declared_at), sym->ns->proc_name->name); - else - gfc_warning ("Variable '%s' at %L is a parameter to the " + else if (gfc_option.warn_c_binding_type) + gfc_warning ("Variable '%s' at %L is a dummy argument of the " "BIND(C) procedure '%s' but may not be C " "interoperable", sym->name, &(sym->declared_at), @@ -1081,7 +1091,7 @@ gfc_verify_c_interop_param (gfc_symbol *sym) retval = FAILURE; } else if (sym->attr.optional == 1 - && gfc_notify_std (GFC_STD_F2008_TS, "TS29113: Variable '%s' " + && gfc_notify_std (GFC_STD_F2008_TS, "Variable '%s' " "at %L with OPTIONAL attribute in " "procedure '%s' which is BIND(C)", sym->name, &(sym->declared_at), @@ -1090,29 +1100,15 @@ gfc_verify_c_interop_param (gfc_symbol *sym) retval = FAILURE; /* Make sure that if it has the dimension attribute, that it is - either assumed size or explicit shape. */ - if (sym->as != NULL) - { - if (sym->as->type == AS_ASSUMED_SHAPE) - { - gfc_error ("Assumed-shape array '%s' at %L cannot be an " - "argument to the procedure '%s' at %L because " - "the procedure is BIND(C)", sym->name, - &(sym->declared_at), sym->ns->proc_name->name, - &(sym->ns->proc_name->declared_at)); - retval = FAILURE; - } - - if (sym->as->type == AS_DEFERRED) - { - gfc_error ("Deferred-shape array '%s' at %L cannot be an " - "argument to the procedure '%s' at %L because " - "the procedure is BIND(C)", sym->name, - &(sym->declared_at), sym->ns->proc_name->name, - &(sym->ns->proc_name->declared_at)); - retval = FAILURE; - } - } + either assumed size or explicit shape. Deferred shape is already + covered by the pointer/allocatable attribute. */ + if (sym->as != NULL && sym->as->type == AS_ASSUMED_SHAPE + && gfc_notify_std (GFC_STD_F2008_TS, "Assumed-shape array '%s' " + "at %L as dummy argument to the BIND(C) " + "procedure '%s' at %L", sym->name, + &(sym->declared_at), sym->ns->proc_name->name, + &(sym->ns->proc_name->declared_at)) == FAILURE) + retval = FAILURE; } } @@ -1737,7 +1733,7 @@ match_pointer_init (gfc_expr **init, int procptr) if (!procptr) gfc_resolve_expr (*init); - if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: non-NULL pointer " + if (gfc_notify_std (GFC_STD_F2008, "non-NULL pointer " "initialization at %C") == FAILURE) return MATCH_ERROR; @@ -1808,8 +1804,12 @@ variable_decl (int elem) if (m == MATCH_NO) as = gfc_copy_array_spec (current_as); - else if (current_as) - merge_array_spec (current_as, as, true); + else if (current_as + && merge_array_spec (current_as, as, true) == FAILURE) + { + m = MATCH_ERROR; + goto cleanup; + } if (gfc_option.flag_cray_pointer) cp_as = gfc_copy_array_spec (as); @@ -1834,7 +1834,7 @@ variable_decl (int elem) if (as->type == AS_IMPLIED_SHAPE && gfc_notify_std (GFC_STD_F2008, - "Fortran 2008: Implied-shape array at %L", + "Implied-shape array at %L", &var_locus) == FAILURE) { m = MATCH_ERROR; @@ -1848,7 +1848,7 @@ variable_decl (int elem) if (current_ts.type == BT_CHARACTER) { - switch (match_char_length (&char_len, &cl_deferred)) + switch (match_char_length (&char_len, &cl_deferred, false)) { case MATCH_YES: cl = gfc_new_charlen (gfc_current_ns, NULL); @@ -1993,7 +1993,7 @@ variable_decl (int elem) if (!colon_seen && gfc_match (" /") == MATCH_YES) { - if (gfc_notify_std (GFC_STD_GNU, "Extension: Old-style " + if (gfc_notify_std (GFC_STD_GNU, "Old-style " "initialization at %C") == FAILURE) return MATCH_ERROR; @@ -2410,7 +2410,7 @@ gfc_match_char_spec (gfc_typespec *ts) /* Try the old-style specification first. */ old_char_selector = 0; - m = match_char_length (&len, &deferred); + m = match_char_length (&len, &deferred, true); if (m != MATCH_NO) { if (m == MATCH_YES) @@ -2586,7 +2586,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) if (gfc_match (" byte") == MATCH_YES) { - if (gfc_notify_std (GFC_STD_GNU, "Extension: BYTE type at %C") + if (gfc_notify_std (GFC_STD_GNU, "BYTE type at %C") == FAILURE) return MATCH_ERROR; @@ -2617,7 +2617,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) gfc_error ("Assumed type at %C is not allowed for components"); return MATCH_ERROR; } - if (gfc_notify_std (GFC_STD_F2008_TS, "TS 29113: Assumed type " + if (gfc_notify_std (GFC_STD_F2008_TS, "Assumed type " "at %C") == FAILURE) return MATCH_ERROR; ts->type = BT_ASSUMED; @@ -2640,7 +2640,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) || (!matched_type && gfc_match (" character") == MATCH_YES)) { if (matched_type - && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with " + && gfc_notify_std (GFC_STD_F2008, "TYPE with " "intrinsic-type-spec at %C") == FAILURE) return MATCH_ERROR; @@ -2671,7 +2671,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) || (!matched_type && gfc_match (" double precision") == MATCH_YES)) { if (matched_type - && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with " + && gfc_notify_std (GFC_STD_F2008, "TYPE with " "intrinsic-type-spec at %C") == FAILURE) return MATCH_ERROR; if (matched_type && gfc_match_char (')') != MATCH_YES) @@ -2696,12 +2696,12 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) && gfc_match (" complex") == MATCH_YES))) || (!matched_type && gfc_match (" double complex") == MATCH_YES)) { - if (gfc_notify_std (GFC_STD_GNU, "Extension: DOUBLE COMPLEX at %C") + if (gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C") == FAILURE) return MATCH_ERROR; if (matched_type - && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with " + && gfc_notify_std (GFC_STD_F2008, "TYPE with " "intrinsic-type-spec at %C") == FAILURE) return MATCH_ERROR; @@ -2743,7 +2743,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) return m; ts->type = BT_CLASS; - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: CLASS statement at %C") + if (gfc_notify_std (GFC_STD_F2003, "CLASS statement at %C") == FAILURE) return MATCH_ERROR; } @@ -2851,7 +2851,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) get_kind: if (matched_type - && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with " + && gfc_notify_std (GFC_STD_F2008, "TYPE with " "intrinsic-type-spec at %C") == FAILURE) return MATCH_ERROR; @@ -3136,7 +3136,7 @@ gfc_match_import (void) return MATCH_ERROR; } - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IMPORT statement at %C") + if (gfc_notify_std (GFC_STD_F2003, "IMPORT statement at %C") == FAILURE) return MATCH_ERROR; @@ -3521,7 +3521,8 @@ match_attr_spec (void) current_as = as; else if (m == MATCH_YES) { - merge_array_spec (as, current_as, false); + if (merge_array_spec (as, current_as, false) == FAILURE) + m = MATCH_ERROR; free (as); } @@ -3632,7 +3633,7 @@ match_attr_spec (void) { if (d == DECL_ALLOCATABLE) { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ALLOCATABLE " + if (gfc_notify_std (GFC_STD_F2003, "ALLOCATABLE " "attribute at %C in a TYPE definition") == FAILURE) { @@ -3660,7 +3661,7 @@ match_attr_spec (void) && gfc_state_stack->previous && gfc_state_stack->previous->state == COMP_MODULE) { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Attribute %s " + if (gfc_notify_std (GFC_STD_F2003, "Attribute %s " "at %L in a TYPE definition", attr, &seen_at[d]) == FAILURE) @@ -3686,7 +3687,7 @@ match_attr_spec (void) case DECL_ASYNCHRONOUS: if (gfc_notify_std (GFC_STD_F2003, - "Fortran 2003: ASYNCHRONOUS attribute at %C") + "ASYNCHRONOUS attribute at %C") == FAILURE) t = FAILURE; else @@ -3699,7 +3700,7 @@ match_attr_spec (void) case DECL_CONTIGUOUS: if (gfc_notify_std (GFC_STD_F2008, - "Fortran 2008: CONTIGUOUS attribute at %C") + "CONTIGUOUS attribute at %C") == FAILURE) t = FAILURE; else @@ -3751,7 +3752,7 @@ match_attr_spec (void) break; } - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROTECTED " + if (gfc_notify_std (GFC_STD_F2003, "PROTECTED " "attribute at %C") == FAILURE) t = FAILURE; @@ -3782,7 +3783,7 @@ match_attr_spec (void) break; case DECL_VALUE: - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE attribute " + if (gfc_notify_std (GFC_STD_F2003, "VALUE attribute " "at %C") == FAILURE) t = FAILURE; @@ -3792,7 +3793,7 @@ match_attr_spec (void) case DECL_VOLATILE: if (gfc_notify_std (GFC_STD_F2003, - "Fortran 2003: VOLATILE attribute at %C") + "VOLATILE attribute at %C") == FAILURE) t = FAILURE; else @@ -4372,7 +4373,7 @@ gfc_match_prefix (gfc_typespec *ts) if (gfc_match ("impure% ") == MATCH_YES) { if (gfc_notify_std (GFC_STD_F2008, - "Fortran 2008: IMPURE procedure at %C") + "IMPURE procedure at %C") == FAILURE) goto error; @@ -4658,7 +4659,7 @@ gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result) /* Fortran 2008 draft allows BIND(C) for internal procedures. */ if (gfc_current_state () == COMP_CONTAINS && sym->ns->proc_name->attr.flavor != FL_MODULE - && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: BIND(C) attribute " + && gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute " "at %L may not be specified for an internal " "procedure", &gfc_current_locus) == FAILURE) @@ -4790,41 +4791,20 @@ match_procedure_interface (gfc_symbol **proc_if) gfc_current_ns = old_ns; *proc_if = st->n.sym; - /* Various interface checks. */ if (*proc_if) { (*proc_if)->refs++; /* Resolve interface if possible. That way, attr.procedure is only set if it is declared by a later procedure-declaration-stmt, which is - invalid per C1212. */ + invalid per F08:C1216 (cf. resolve_procedure_interface). */ while ((*proc_if)->ts.interface) *proc_if = (*proc_if)->ts.interface; - if ((*proc_if)->generic) - { - gfc_error ("Interface '%s' at %C may not be generic", - (*proc_if)->name); - return MATCH_ERROR; - } - if ((*proc_if)->attr.proc == PROC_ST_FUNCTION) - { - gfc_error ("Interface '%s' at %C may not be a statement function", - (*proc_if)->name); - return MATCH_ERROR; - } - /* Handle intrinsic procedures. */ - if (!((*proc_if)->attr.external || (*proc_if)->attr.use_assoc - || (*proc_if)->attr.if_source == IFSRC_IFBODY) - && (gfc_is_intrinsic ((*proc_if), 0, gfc_current_locus) - || gfc_is_intrinsic ((*proc_if), 1, gfc_current_locus))) - (*proc_if)->attr.intrinsic = 1; - if ((*proc_if)->attr.intrinsic - && !gfc_intrinsic_actual_ok ((*proc_if)->name, 0)) - { - gfc_error ("Intrinsic procedure '%s' not allowed " - "in PROCEDURE statement at %C", (*proc_if)->name); - return MATCH_ERROR; - } + if ((*proc_if)->attr.flavor == FL_UNKNOWN + && (*proc_if)->ts.type == BT_UNKNOWN + && gfc_add_flavor (&(*proc_if)->attr, FL_PROCEDURE, + (*proc_if)->name, NULL) == FAILURE) + return MATCH_ERROR; } got_ts: @@ -5029,7 +5009,7 @@ match_ppc_decl (void) return MATCH_ERROR; } - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure pointer " + if (gfc_notify_std (GFC_STD_F2003, "Procedure pointer " "component at %C") == FAILURE) return MATCH_ERROR; @@ -5069,6 +5049,7 @@ match_ppc_decl (void) { c->ts = ts; c->ts.interface = gfc_new_symbol ("", gfc_current_ns); + c->ts.interface->result = c->ts.interface; c->ts.interface->ts = ts; c->ts.interface->attr.flavor = FL_PROCEDURE; c->ts.interface->attr.function = 1; @@ -5107,6 +5088,7 @@ match_procedure_in_interface (void) match m; gfc_symbol *sym; char name[GFC_MAX_SYMBOL_LEN + 1]; + locus old_locus; if (current_interface.type == INTERFACE_NAMELESS || current_interface.type == INTERFACE_ABSTRACT) @@ -5115,6 +5097,19 @@ match_procedure_in_interface (void) return MATCH_ERROR; } + /* Check if the F2008 optional double colon appears. */ + gfc_gobble_whitespace (); + old_locus = gfc_current_locus; + if (gfc_match ("::") == MATCH_YES) + { + if (gfc_notify_std (GFC_STD_F2008, "double colon in " + "MODULE PROCEDURE statement at %L", &old_locus) + == FAILURE) + return MATCH_ERROR; + } + else + gfc_current_locus = old_locus; + for(;;) { m = gfc_match_name (name); @@ -5177,7 +5172,7 @@ gfc_match_procedure (void) if (m != MATCH_YES) return m; - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROCEDURE statement at %C") + if (gfc_notify_std (GFC_STD_F2003, "PROCEDURE statement at %C") == FAILURE) return MATCH_ERROR; @@ -5388,7 +5383,7 @@ gfc_match_entry (void) if (m != MATCH_YES) return m; - if (gfc_notify_std (GFC_STD_F2008_OBS, "Fortran 2008 obsolescent feature: " + if (gfc_notify_std (GFC_STD_F2008_OBS, "ENTRY statement at %C") == FAILURE) return MATCH_ERROR; @@ -5699,7 +5694,7 @@ gfc_match_subroutine (void) /* The following is allowed in the Fortran 2008 draft. */ if (gfc_current_state () == COMP_CONTAINS && sym->ns->proc_name->attr.flavor != FL_MODULE - && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: BIND(C) attribute " + && gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute " "at %L may not be specified for an internal " "procedure", &gfc_current_locus) == FAILURE) @@ -6069,7 +6064,7 @@ gfc_match_end (gfc_statement *st) { if (!eos_ok && (*st == ST_END_SUBROUTINE || *st == ST_END_FUNCTION)) { - if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: END statement " + if (gfc_notify_std (GFC_STD_F2008, "END statement " "instead of %s statement at %L", gfc_ascii_statement (*st), &old_loc) == FAILURE) goto cleanup; @@ -6595,7 +6590,7 @@ gfc_match_codimension (void) match gfc_match_contiguous (void) { - if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CONTIGUOUS statement at %C") + if (gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS statement at %C") == FAILURE) return MATCH_ERROR; @@ -6748,7 +6743,7 @@ gfc_match_protected (void) } - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROTECTED statement at %C") + if (gfc_notify_std (GFC_STD_F2003, "PROTECTED statement at %C") == FAILURE) return MATCH_ERROR; @@ -7046,7 +7041,7 @@ gfc_match_value (void) return MATCH_ERROR; } - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE statement at %C") + if (gfc_notify_std (GFC_STD_F2003, "VALUE statement at %C") == FAILURE) return MATCH_ERROR; @@ -7097,7 +7092,7 @@ gfc_match_volatile (void) gfc_symbol *sym; match m; - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VOLATILE statement at %C") + if (gfc_notify_std (GFC_STD_F2003, "VOLATILE statement at %C") == FAILURE) return MATCH_ERROR; @@ -7158,7 +7153,7 @@ gfc_match_asynchronous (void) gfc_symbol *sym; match m; - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ASYNCHRONOUS statement at %C") + if (gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS statement at %C") == FAILURE) return MATCH_ERROR; @@ -7249,7 +7244,7 @@ gfc_match_modproc (void) old_locus = gfc_current_locus; if (gfc_match ("::") == MATCH_YES) { - if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: double colon in " + if (gfc_notify_std (GFC_STD_F2008, "double colon in " "MODULE PROCEDURE statement at %L", &old_locus) == FAILURE) return MATCH_ERROR; @@ -7416,7 +7411,7 @@ gfc_get_type_attr_spec (symbol_attribute *attr, char *name) } else if (gfc_match (" , abstract") == MATCH_YES) { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ABSTRACT type at %C") + if (gfc_notify_std (GFC_STD_F2003, "ABSTRACT type at %C") == FAILURE) return MATCH_ERROR; @@ -7647,7 +7642,7 @@ gfc_match_enum (void) if (m != MATCH_YES) return m; - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ENUM and ENUMERATOR at %C") + if (gfc_notify_std (GFC_STD_F2003, "ENUM and ENUMERATOR at %C") == FAILURE) return MATCH_ERROR; @@ -8141,7 +8136,7 @@ match_procedure_in_type (void) return MATCH_ERROR; } - if (num>1 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: PROCEDURE list" + if (num>1 && gfc_notify_std (GFC_STD_F2008, "PROCEDURE list" " at %C") == FAILURE) return MATCH_ERROR; diff --git a/gcc/fortran/dependency.c b/gcc/fortran/dependency.c index a2cf21d65f1..165ab4f0abb 100644 --- a/gcc/fortran/dependency.c +++ b/gcc/fortran/dependency.c @@ -26,6 +26,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" +#include "coretypes.h" #include "gfortran.h" #include "dependency.h" #include "constructor.h" @@ -260,6 +261,9 @@ gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2) n1 = NULL; n2 = NULL; + if (e1 == NULL && e2 == NULL) + return 0; + /* Remove any integer conversion functions to larger types. */ if (e1->expr_type == EXPR_FUNCTION && e1->value.function.isym && e1->value.function.isym->id == GFC_ISYM_CONVERSION @@ -1216,7 +1220,7 @@ check_section_vs_section (gfc_array_ref *l_ar, gfc_array_ref *r_ar, int n) else start_comparison = -2; - free (one_expr); + gfc_free_expr (one_expr); /* Determine LHS upper and lower bounds. */ if (l_dir == 1) diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index 7f1d28fd7c9..cb8fab4fe35 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -33,6 +33,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" +#include "coretypes.h" #include "gfortran.h" #include "constructor.h" @@ -165,7 +166,7 @@ show_array_spec (gfc_array_spec *as) fprintf (dumpfile, "(%d [%d]", as->rank, as->corank); - if (as->rank + as->corank > 0) + if (as->rank + as->corank > 0 || as->rank == -1) { switch (as->type) { @@ -173,6 +174,7 @@ show_array_spec (gfc_array_spec *as) case AS_DEFERRED: c = "AS_DEFERRED"; break; case AS_ASSUMED_SIZE: c = "AS_ASSUMED_SIZE"; break; case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break; + case AS_ASSUMED_RANK: c = "AS_ASSUMED_RANK"; break; default: gfc_internal_error ("show_array_spec(): Unhandled array shape " "type."); @@ -567,7 +569,7 @@ show_expr (gfc_expr *p) if (p->value.function.name == NULL) { fprintf (dumpfile, "%s", p->symtree->n.sym->name); - if (gfc_is_proc_ptr_comp (p, NULL)) + if (gfc_is_proc_ptr_comp (p)) show_ref (p->ref); fputc ('[', dumpfile); show_actual_arglist (p->value.function.actual); @@ -576,7 +578,7 @@ show_expr (gfc_expr *p) else { fprintf (dumpfile, "%s", p->value.function.name); - if (gfc_is_proc_ptr_comp (p, NULL)) + if (gfc_is_proc_ptr_comp (p)) show_ref (p->ref); fputc ('[', dumpfile); fputc ('[', dumpfile); diff --git a/gcc/fortran/error.c b/gcc/fortran/error.c index e9308374ac6..dde6a0fb527 100644 --- a/gcc/fortran/error.c +++ b/gcc/fortran/error.c @@ -28,6 +28,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" +#include "coretypes.h" #include "flags.h" #include "gfortran.h" @@ -808,6 +809,8 @@ gfc_notify_std (int std, const char *gmsgid, ...) { va_list argp; bool warning; + const char *msg1, *msg2; + char *buffer; warning = ((gfc_option.warn_std & std) != 0) && !inhibit_warnings; if ((gfc_option.allow_std & std) != 0 && !warning) @@ -820,11 +823,48 @@ gfc_notify_std (int std, const char *gmsgid, ...) cur_error_buffer->flag = 1; cur_error_buffer->index = 0; - va_start (argp, gmsgid); if (warning) - error_print (_("Warning:"), _(gmsgid), argp); + msg1 = _("Warning:"); else - error_print (_("Error:"), _(gmsgid), argp); + msg1 = _("Error:"); + + switch (std) + { + case GFC_STD_F2008_TS: + msg2 = "TS 29113:"; + break; + case GFC_STD_F2008_OBS: + msg2 = _("Fortran 2008 obsolescent feature:"); + break; + case GFC_STD_F2008: + msg2 = "Fortran 2008:"; + break; + case GFC_STD_F2003: + msg2 = "Fortran 2003:"; + break; + case GFC_STD_GNU: + msg2 = _("GNU Extension:"); + break; + case GFC_STD_LEGACY: + msg2 = _("Legacy Extension:"); + break; + case GFC_STD_F95_OBS: + msg2 = _("Obsolescent feature:"); + break; + case GFC_STD_F95_DEL: + msg2 = _("Deleted feature:"); + break; + default: + gcc_unreachable (); + } + + buffer = (char *) alloca (strlen (msg1) + strlen (msg2) + 2); + strcpy (buffer, msg1); + strcat (buffer, " "); + strcat (buffer, msg2); + + va_start (argp, gmsgid); + error_print (buffer, _(gmsgid), argp); va_end (argp); error_char ('\0'); @@ -835,6 +875,7 @@ gfc_notify_std (int std, const char *gmsgid, ...) warnings++; else gfc_increment_error_count(); + cur_error_buffer->flag = 0; } return (warning && !warnings_are_errors) ? SUCCESS : FAILURE; diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 0b38cacad94..bc1f5e33c6a 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -22,6 +22,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" +#include "coretypes.h" #include "gfortran.h" #include "arith.h" #include "match.h" @@ -1489,13 +1490,10 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) /* Now clock through the array reference, calculating the index in the source constructor and transferring the elements to the new - constructor. */ + constructor. */ for (idx = 0; idx < (int) mpz_get_si (nelts); idx++) { - if (ref->u.ar.offset) - mpz_set (ptr, ref->u.ar.offset->value.integer); - else - mpz_init_set_ui (ptr, 0); + mpz_init_set_ui (ptr, 0); incr_ctr = true; for (d = 0; d < rank; d++) @@ -2404,7 +2402,7 @@ check_elemental (gfc_expr *e) if (e->ts.type != BT_INTEGER && e->ts.type != BT_CHARACTER - && gfc_notify_std (GFC_STD_F2003, "Extension: Evaluation of " + && gfc_notify_std (GFC_STD_F2003, "Evaluation of " "nonstandard initialization expression at %L", &e->where) == FAILURE) return MATCH_ERROR; @@ -2964,12 +2962,12 @@ gfc_specification_expr (gfc_expr *e) return FAILURE; } + comp = gfc_get_proc_ptr_comp (e); if (e->expr_type == EXPR_FUNCTION - && !e->value.function.isym - && !e->value.function.esym - && !gfc_pure (e->symtree->n.sym) - && (!gfc_is_proc_ptr_comp (e, &comp) - || !comp->attr.pure)) + && !e->value.function.isym + && !e->value.function.esym + && !gfc_pure (e->symtree->n.sym) + && (!comp || !comp->attr.pure)) { gfc_error ("Function '%s' at %L must be PURE", e->symtree->n.sym->name, &e->where); @@ -3163,13 +3161,13 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform) if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER && lvalue->symtree->n.sym->attr.data - && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L used to " + && gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L used to " "initialize non-integer variable '%s'", &rvalue->where, lvalue->symtree->n.sym->name) == FAILURE) return FAILURE; else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data - && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside " + && gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L outside " "a DATA statement and outside INT/REAL/DBLE/CMPLX", &rvalue->where) == FAILURE) return FAILURE; @@ -3337,7 +3335,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) return FAILURE; } - if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Bounds " + if (gfc_notify_std (GFC_STD_F2003,"Bounds " "specification for '%s' in pointer assignment " "at %L", lvalue->symtree->n.sym->name, &lvalue->where) == FAILURE) @@ -3420,6 +3418,19 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) &rvalue->where); return FAILURE; } + if (rvalue->expr_type == EXPR_VARIABLE && !attr.proc_pointer) + { + /* Check for intrinsics. */ + gfc_symbol *sym = rvalue->symtree->n.sym; + if (!sym->attr.intrinsic + && (gfc_is_intrinsic (sym, 0, sym->declared_at) + || gfc_is_intrinsic (sym, 1, sym->declared_at))) + { + sym->attr.intrinsic = 1; + gfc_resolve_intrinsic (sym, &rvalue->where); + attr = gfc_expr_attr (rvalue); + } + } if (attr.abstract) { gfc_error ("Abstract interface '%s' is invalid " @@ -3438,16 +3449,24 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) return FAILURE; } if (attr.proc == PROC_INTERNAL && - gfc_notify_std (GFC_STD_F2008, "Internal procedure '%s' is " - "invalid in procedure pointer assignment at %L", - rvalue->symtree->name, &rvalue->where) == FAILURE) + gfc_notify_std (GFC_STD_F2008, "Internal procedure " + "'%s' is invalid in procedure pointer assignment " + "at %L", rvalue->symtree->name, &rvalue->where) + == FAILURE) return FAILURE; + if (attr.intrinsic && gfc_intrinsic_actual_ok (rvalue->symtree->name, + attr.subroutine) == 0) + { + gfc_error ("Intrinsic '%s' at %L is invalid in procedure pointer " + "assignment", rvalue->symtree->name, &rvalue->where); + return FAILURE; + } } /* Check for F08:C730. */ if (attr.elemental && !attr.intrinsic) { gfc_error ("Nonintrinsic elemental procedure '%s' is invalid " - "in procedure pointer assigment at %L", + "in procedure pointer assignment at %L", rvalue->symtree->name, &rvalue->where); return FAILURE; } @@ -3476,12 +3495,14 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) } } - if (gfc_is_proc_ptr_comp (lvalue, &comp)) + comp = gfc_get_proc_ptr_comp (lvalue); + if (comp) s1 = comp->ts.interface; else s1 = lvalue->symtree->n.sym; - if (gfc_is_proc_ptr_comp (rvalue, &comp)) + comp = gfc_get_proc_ptr_comp (rvalue); + if (comp) { s2 = comp->ts.interface; name = comp->name; @@ -3561,7 +3582,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) " simply contiguous at %L", &rvalue->where); return FAILURE; } - if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Rank remapping" + if (gfc_notify_std (GFC_STD_F2008, "Rank remapping" " target is not rank 1 at %L", &rvalue->where) == FAILURE) return FAILURE; @@ -3638,6 +3659,39 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) } } + /* Warn if it is the LHS pointer may lives longer than the RHS target. */ + if (gfc_option.warn_target_lifetime + && rvalue->expr_type == EXPR_VARIABLE + && !rvalue->symtree->n.sym->attr.save + && !attr.pointer && !rvalue->symtree->n.sym->attr.host_assoc + && !rvalue->symtree->n.sym->attr.in_common + && !rvalue->symtree->n.sym->attr.use_assoc + && !rvalue->symtree->n.sym->attr.dummy) + { + bool warn; + gfc_namespace *ns; + + warn = lvalue->symtree->n.sym->attr.dummy + || lvalue->symtree->n.sym->attr.result + || lvalue->symtree->n.sym->attr.function + || lvalue->symtree->n.sym->attr.host_assoc + || lvalue->symtree->n.sym->attr.use_assoc + || lvalue->symtree->n.sym->attr.in_common; + + if (rvalue->symtree->n.sym->ns->proc_name + && rvalue->symtree->n.sym->ns->proc_name->attr.flavor != FL_PROCEDURE + && rvalue->symtree->n.sym->ns->proc_name->attr.flavor != FL_PROGRAM) + for (ns = rvalue->symtree->n.sym->ns; + ns->proc_name && ns->proc_name->attr.flavor != FL_PROCEDURE; + ns = ns->parent) + if (ns->parent == lvalue->symtree->n.sym->ns) + warn = true; + + if (warn) + gfc_warning ("Pointer at %L in pointer assignment might outlive the " + "pointer target", &lvalue->where); + } + return SUCCESS; } @@ -4056,31 +4110,35 @@ gfc_expr_set_symbols_referenced (gfc_expr *expr) } -/* Determine if an expression is a procedure pointer component. If yes, the - argument 'comp' will point to the component (provided that 'comp' was - provided). */ +/* Determine if an expression is a procedure pointer component and return + the component in that case. Otherwise return NULL. */ -bool -gfc_is_proc_ptr_comp (gfc_expr *expr, gfc_component **comp) +gfc_component * +gfc_get_proc_ptr_comp (gfc_expr *expr) { gfc_ref *ref; - bool ppc = false; if (!expr || !expr->ref) - return false; + return NULL; ref = expr->ref; while (ref->next) ref = ref->next; - if (ref->type == REF_COMPONENT) - { - ppc = ref->u.c.component->attr.proc_pointer; - if (ppc && comp) - *comp = ref->u.c.component; - } + if (ref->type == REF_COMPONENT + && ref->u.c.component->attr.proc_pointer) + return ref->u.c.component; - return ppc; + return NULL; +} + + +/* Determine if an expression is a procedure pointer component. */ + +bool +gfc_is_proc_ptr_comp (gfc_expr *expr) +{ + return (gfc_get_proc_ptr_comp (expr) != NULL); } @@ -4441,7 +4499,8 @@ gfc_is_simply_contiguous (gfc_expr *expr, bool strict) || (!part_ref && !sym->attr.contiguous && (sym->attr.pointer - || sym->as->type == AS_ASSUMED_SHAPE)))) + || sym->as->type == AS_ASSUMED_RANK + || sym->as->type == AS_ASSUMED_SHAPE)))) return false; if (!ar || ar->type == AR_FULL) diff --git a/gcc/fortran/f95-lang.c b/gcc/fortran/f95-lang.c index 7250ca2d769..6ff13561278 100644 --- a/gcc/fortran/f95-lang.c +++ b/gcc/fortran/f95-lang.c @@ -42,7 +42,7 @@ along with GCC; see the file COPYING3. If not see #include "target.h" #include "debug.h" #include "diagnostic.h" -#include "tree-dump.h" +#include "dumpfile.h" #include "cgraph.h" #include "gfortran.h" #include "cpp.h" diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c index fc32e56dfc6..437ed7ec175 100644 --- a/gcc/fortran/frontend-passes.c +++ b/gcc/fortran/frontend-passes.c @@ -20,6 +20,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" +#include "coretypes.h" #include "gfortran.h" #include "arith.h" #include "flags.h" diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index caa23bd6388..d67d57b7b13 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -29,13 +29,16 @@ along with GCC; see the file COPYING3. If not see multiple header files. Besides, Microsoft's winnt.h was 250k last time I looked, so by comparison this is perfectly reasonable. */ +#ifndef GCC_CORETYPES_H +#error "gfortran.h must be included after coretypes.h" +#endif + /* Declarations common to the front-end and library are put in libgfortran/libgfortran_frontend.h */ #include "libgfortran.h" #include "intl.h" -#include "coretypes.h" #include "input.h" #include "splay-tree.h" @@ -132,7 +135,8 @@ expr_t; /* Array types. */ typedef enum { AS_EXPLICIT = 1, AS_ASSUMED_SHAPE, AS_DEFERRED, - AS_ASSUMED_SIZE, AS_IMPLIED_SHAPE, AS_UNKNOWN + AS_ASSUMED_SIZE, AS_IMPLIED_SHAPE, AS_ASSUMED_RANK, + AS_UNKNOWN } array_type; @@ -140,9 +144,11 @@ typedef enum { AR_FULL = 1, AR_ELEMENT, AR_SECTION, AR_UNKNOWN } ar_type; -/* Statement label types. */ +/* Statement label types. ST_LABEL_DO_TARGET is used for obsolescent warnings + related to shared DO terminations and DO targets which are neither END DO + nor CONTINUE; otherwise it is identical to ST_LABEL_TARGET. */ typedef enum -{ ST_LABEL_UNKNOWN = 1, ST_LABEL_TARGET, +{ ST_LABEL_UNKNOWN = 1, ST_LABEL_TARGET, ST_LABEL_DO_TARGET, ST_LABEL_BAD_TARGET, ST_LABEL_FORMAT } gfc_sl_type; @@ -914,7 +920,7 @@ gfc_typespec; /* Array specification. */ typedef struct { - int rank; /* A rank of zero means that a variable is a scalar. */ + int rank; /* A scalar has a rank of 0, an assumed-rank array has -1. */ int corank; array_type type, cotype; struct gfc_expr *lower[GFC_MAX_DIMENSIONS], *upper[GFC_MAX_DIMENSIONS]; @@ -1260,6 +1266,7 @@ typedef struct gfc_common_head struct gfc_symbol *head; const char* binding_label; int is_bind_c; + int refs; } gfc_common_head; @@ -1511,8 +1518,6 @@ typedef struct gfc_array_ref *stride[GFC_MAX_DIMENSIONS]; enum gfc_array_ref_dimen_type dimen_type[GFC_MAX_DIMENSIONS]; - - struct gfc_expr *offset; } gfc_array_ref; @@ -1691,7 +1696,7 @@ typedef struct gfc_expr gfc_typespec ts; /* These two refer to the overall expression */ - int rank; + int rank; /* 0 indicates a scalar, -1 an assumed-rank array. */ mpz_t *shape; /* Can be NULL if shape is unknown at compile time */ /* Nonnull for functions and structure constructors, may also used to hold the @@ -1706,7 +1711,7 @@ typedef struct gfc_expr is not a variable. */ struct gfc_expr *base_expr; - /* is_boz is true if the integer is regarded as BOZ bitpatten and is_snan + /* is_boz is true if the integer is regarded as BOZ bit pattern and is_snan denotes a signalling not-a-number. */ unsigned int is_boz : 1, is_snan : 1; @@ -2221,6 +2226,8 @@ typedef struct int warn_unused_dummy_argument; int warn_realloc_lhs; int warn_realloc_lhs_all; + int warn_compare_reals; + int warn_target_lifetime; int max_errors; int flag_all_intrinsics; @@ -2635,9 +2642,9 @@ gfc_symbol* gfc_get_ultimate_derived_super_type (gfc_symbol*); bool gfc_type_is_extension_of (gfc_symbol *, gfc_symbol *); bool gfc_type_compatible (gfc_typespec *, gfc_typespec *); -void gfc_copy_formal_args (gfc_symbol *, gfc_symbol *); +void gfc_copy_formal_args (gfc_symbol *, gfc_symbol *, ifsrc); void gfc_copy_formal_args_intr (gfc_symbol *, gfc_intrinsic_sym *); -void gfc_copy_formal_args_ppc (gfc_component *, gfc_symbol *); +void gfc_copy_formal_args_ppc (gfc_component *, gfc_symbol *, ifsrc); void gfc_free_finalizer (gfc_finalizer *el); /* Needed in resolve.c, too */ @@ -2762,7 +2769,8 @@ gfc_try gfc_expr_check_typed (gfc_expr*, gfc_namespace*, bool); void gfc_expr_replace_symbols (gfc_expr *, gfc_symbol *); void gfc_expr_replace_comp (gfc_expr *, gfc_component *); -bool gfc_is_proc_ptr_comp (gfc_expr *, gfc_component **); +gfc_component * gfc_get_proc_ptr_comp (gfc_expr *); +bool gfc_is_proc_ptr_comp (gfc_expr *); bool gfc_ref_this_image (gfc_ref *ref); bool gfc_is_coindexed (gfc_expr *); @@ -2801,7 +2809,8 @@ int gfc_is_formal_arg (void); void gfc_resolve_substring_charlen (gfc_expr *); match gfc_iso_c_sub_interface(gfc_code *, gfc_symbol *); gfc_expr *gfc_expr_to_initialize (gfc_expr *); -bool gfc_type_is_extensible (gfc_symbol *sym); +bool gfc_type_is_extensible (gfc_symbol *); +gfc_try gfc_resolve_intrinsic (gfc_symbol *, locus *); /* array.c */ @@ -2844,7 +2853,7 @@ int gfc_compare_types (gfc_typespec *, gfc_typespec *); int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, const char *, int, int, char *, int, const char *, const char *); void gfc_check_interfaces (gfc_namespace *); -void gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *); +gfc_try gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *); void gfc_ppc_use (gfc_component *, gfc_actual_arglist **, locus *); gfc_symbol *gfc_search_interface (gfc_interface *, int, gfc_actual_arglist **); diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 34e1ad7f88b..482c294ecba 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -67,6 +67,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" +#include "coretypes.h" #include "gfortran.h" #include "match.h" #include "arith.h" @@ -252,7 +253,7 @@ gfc_match_abstract_interface (void) { match m; - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ABSTRACT INTERFACE at %C") + if (gfc_notify_std (GFC_STD_F2003, "ABSTRACT INTERFACE at %C") == FAILURE) return MATCH_ERROR; @@ -511,7 +512,9 @@ compare_type_rank (gfc_symbol *s1, gfc_symbol *s2) r1 = (s1->as != NULL) ? s1->as->rank : 0; r2 = (s2->as != NULL) ? s2->as->rank : 0; - if (r1 != r2) + if (r1 != r2 + && (!s1->as || s1->as->type != AS_ASSUMED_RANK) + && (!s2->as || s2->as->type != AS_ASSUMED_RANK)) return 0; /* Ranks differ. */ return gfc_compare_types (&s1->ts, &s2->ts) @@ -1003,9 +1006,8 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2, /* Check type and rank. */ if (type_must_agree && !compare_type_rank (s2, s1)) { - if (errmsg != NULL) - snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'", - s1->name); + snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'", + s1->name); return FAILURE; } @@ -1138,6 +1140,152 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2, } +/* Check if the characteristics of two function results match, + cf. F08:12.3.3. */ + +static gfc_try +check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2, + char *errmsg, int err_len) +{ + gfc_symbol *r1, *r2; + + r1 = s1->result ? s1->result : s1; + r2 = s2->result ? s2->result : s2; + + if (r1->ts.type == BT_UNKNOWN) + return SUCCESS; + + /* Check type and rank. */ + if (!compare_type_rank (r1, r2)) + { + snprintf (errmsg, err_len, "Type/rank mismatch in function result"); + return FAILURE; + } + + /* Check ALLOCATABLE attribute. */ + if (r1->attr.allocatable != r2->attr.allocatable) + { + snprintf (errmsg, err_len, "ALLOCATABLE attribute mismatch in " + "function result"); + return FAILURE; + } + + /* Check POINTER attribute. */ + if (r1->attr.pointer != r2->attr.pointer) + { + snprintf (errmsg, err_len, "POINTER attribute mismatch in " + "function result"); + return FAILURE; + } + + /* Check CONTIGUOUS attribute. */ + if (r1->attr.contiguous != r2->attr.contiguous) + { + snprintf (errmsg, err_len, "CONTIGUOUS attribute mismatch in " + "function result"); + return FAILURE; + } + + /* Check PROCEDURE POINTER attribute. */ + if (r1 != s1 && r1->attr.proc_pointer != r2->attr.proc_pointer) + { + snprintf (errmsg, err_len, "PROCEDURE POINTER mismatch in " + "function result"); + return FAILURE; + } + + /* Check string length. */ + if (r1->ts.type == BT_CHARACTER && r1->ts.u.cl && r2->ts.u.cl) + { + if (r1->ts.deferred != r2->ts.deferred) + { + snprintf (errmsg, err_len, "Character length mismatch " + "in function result"); + return FAILURE; + } + + if (r1->ts.u.cl->length) + { + int compval = gfc_dep_compare_expr (r1->ts.u.cl->length, + r2->ts.u.cl->length); + switch (compval) + { + case -1: + case 1: + case -3: + snprintf (errmsg, err_len, "Character length mismatch " + "in function result"); + return FAILURE; + + case -2: + /* FIXME: Implement a warning for this case. + snprintf (errmsg, err_len, "Possible character length mismatch " + "in function result");*/ + break; + + case 0: + break; + + default: + gfc_internal_error ("check_result_characteristics (1): Unexpected " + "result %i of gfc_dep_compare_expr", compval); + break; + } + } + } + + /* Check array shape. */ + if (!r1->attr.allocatable && !r1->attr.pointer && r1->as && r2->as) + { + int i, compval; + gfc_expr *shape1, *shape2; + + if (r1->as->type != r2->as->type) + { + snprintf (errmsg, err_len, "Shape mismatch in function result"); + return FAILURE; + } + + if (r1->as->type == AS_EXPLICIT) + for (i = 0; i < r1->as->rank + r1->as->corank; i++) + { + shape1 = gfc_subtract (gfc_copy_expr (r1->as->upper[i]), + gfc_copy_expr (r1->as->lower[i])); + shape2 = gfc_subtract (gfc_copy_expr (r2->as->upper[i]), + gfc_copy_expr (r2->as->lower[i])); + compval = gfc_dep_compare_expr (shape1, shape2); + gfc_free_expr (shape1); + gfc_free_expr (shape2); + switch (compval) + { + case -1: + case 1: + case -3: + snprintf (errmsg, err_len, "Shape mismatch in dimension %i of " + "function result", i + 1); + return FAILURE; + + case -2: + /* FIXME: Implement a warning for this case. + gfc_warning ("Possible shape mismatch in return value");*/ + break; + + case 0: + break; + + default: + gfc_internal_error ("check_result_characteristics (2): " + "Unexpected result %i of " + "gfc_dep_compare_expr", compval); + break; + } + } + } + + return SUCCESS; +} + + /* 'Compare' two formal interfaces associated with a pair of symbols. We return nonzero if there exists an actual argument list that would be ambiguous between the two interfaces, zero otherwise. @@ -1177,18 +1325,10 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2, { if (s1->attr.function && s2->attr.function) { - /* If both are functions, check result type. */ - if (s1->ts.type == BT_UNKNOWN) - return 1; - if (!compare_type_rank (s1,s2)) - { - if (errmsg != NULL) - snprintf (errmsg, err_len, "Type/rank mismatch in return value " - "of '%s'", name2); - return 0; - } - - /* FIXME: Check array bounds and string length of result. */ + /* If both are functions, check result characteristics. */ + if (check_result_characteristics (s1, s2, errmsg, err_len) + == FAILURE) + return 0; } if (s1->attr.pure && !s2->attr.pure) @@ -1312,7 +1452,7 @@ check_interface0 (gfc_interface *p, const char *interface_name) /* F2003, C1207. F2008, C1207. */ if (p->sym->attr.proc == PROC_INTERNAL - && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Internal procedure " + && gfc_notify_std (GFC_STD_F2008, "Internal procedure " "'%s' in %s at %L", p->sym->name, interface_name, &p->sym->declared_at) == FAILURE) return 1; @@ -1634,7 +1774,14 @@ static void argument_rank_mismatch (const char *name, locus *where, int rank1, int rank2) { - if (rank1 == 0) + + /* TS 29113, C407b. */ + if (rank2 == -1) + { + gfc_error ("The assumed-rank array at %L requires that the dummy argument" + " '%s' has assumed-rank", where, name); + } + else if (rank1 == 0) { gfc_error ("Rank mismatch in argument '%s' at %L " "(scalar and rank-%d)", name, where, rank2); @@ -1722,7 +1869,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, { if (where) gfc_error ("Actual argument to contiguous pointer dummy '%s' at %L " - "must be simply contigous", formal->name, &actual->where); + "must be simply contiguous", formal->name, &actual->where); return 0; } @@ -1742,7 +1889,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, } /* F2008, 12.5.2.5; IR F08/0073. */ - if (formal->ts.type == BT_CLASS + if (formal->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL && ((CLASS_DATA (formal)->attr.class_pointer && !formal->attr.intent == INTENT_IN) || CLASS_DATA (formal)->attr.allocatable)) @@ -1859,7 +2006,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, " is modified", &actual->where, formal->name); } - if (symbol_rank (formal) == actual->rank) + /* If the rank is the same or the formal argument has assumed-rank. */ + if (symbol_rank (formal) == actual->rank || symbol_rank (formal) == -1) return 1; if (actual->ts.type == BT_CLASS && CLASS_DATA (actual)->as @@ -2288,11 +2436,21 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, return 0; } - if (a->expr->expr_type == EXPR_NULL && !f->sym->attr.pointer - && (f->sym->attr.allocatable || !f->sym->attr.optional - || (gfc_option.allow_std & GFC_STD_F2008) == 0)) + if (a->expr->expr_type == EXPR_NULL + && ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer + && (f->sym->attr.allocatable || !f->sym->attr.optional + || (gfc_option.allow_std & GFC_STD_F2008) == 0)) + || (f->sym->ts.type == BT_CLASS + && !CLASS_DATA (f->sym)->attr.class_pointer + && (CLASS_DATA (f->sym)->attr.allocatable + || !f->sym->attr.optional + || (gfc_option.allow_std & GFC_STD_F2008) == 0)))) { - if (where && (f->sym->attr.allocatable || !f->sym->attr.optional)) + if (where + && (!f->sym->attr.optional + || (f->sym->ts.type != BT_CLASS && f->sym->attr.allocatable) + || (f->sym->ts.type == BT_CLASS + && CLASS_DATA (f->sym)->attr.allocatable))) gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'", where, f->sym->name); else if (where) @@ -2400,7 +2558,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, && a->expr->symtree->n.sym->attr.proc_pointer) || (a->expr->expr_type == EXPR_FUNCTION && a->expr->symtree->n.sym->result->attr.proc_pointer) - || gfc_is_proc_ptr_comp (a->expr, NULL))) + || gfc_is_proc_ptr_comp (a->expr))) { if (where) gfc_error ("Expected a procedure pointer for argument '%s' at %L", @@ -2410,7 +2568,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is provided for a procedure formal argument. */ - if (a->expr->ts.type != BT_PROCEDURE && !gfc_is_proc_ptr_comp (a->expr, NULL) + if (a->expr->ts.type != BT_PROCEDURE && !gfc_is_proc_ptr_comp (a->expr) && a->expr->expr_type == EXPR_VARIABLE && f->sym->attr.flavor == FL_PROCEDURE) { @@ -2906,7 +3064,7 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a) well, the actual argument list will also end up being properly sorted. */ -void +gfc_try gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) { /* Warn about calls with an implicit interface. Special case @@ -2933,7 +3091,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) gfc_error("The pointer object '%s' at %L must have an explicit " "function interface or be declared as array", sym->name, where); - return; + return FAILURE; } if (sym->attr.allocatable && !sym->attr.external) @@ -2941,14 +3099,14 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) gfc_error("The allocatable object '%s' at %L must have an explicit " "function interface or be declared as array", sym->name, where); - return; + return FAILURE; } if (sym->attr.allocatable) { gfc_error("Allocatable function '%s' at %L must have an explicit " "function interface", sym->name, where); - return; + return FAILURE; } for (a = *ap; a; a = a->next) @@ -2988,19 +3146,32 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) && a->expr->ts.type == BT_UNKNOWN) { gfc_error ("MOLD argument to NULL required at %L", &a->expr->where); - return; + return FAILURE; + } + + /* TS 29113, C407b. */ + if (a->expr && a->expr->expr_type == EXPR_VARIABLE + && symbol_rank (a->expr->symtree->n.sym) == -1) + { + gfc_error ("Assumed-rank argument requires an explicit interface " + "at %L", &a->expr->where); + return FAILURE; } } - return; + return SUCCESS; } if (!compare_actual_formal (ap, sym->formal, 0, sym->attr.elemental, where)) - return; + return FAILURE; + + if (check_intents (sym->formal, *ap) == FAILURE) + return FAILURE; - check_intents (sym->formal, *ap); if (gfc_option.warn_aliasing) check_some_aliasing (sym->formal, *ap); + + return SUCCESS; } @@ -3759,7 +3930,7 @@ gfc_try gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old) { locus where; - const gfc_symbol *proc_target, *old_target; + gfc_symbol *proc_target, *old_target; unsigned proc_pass_arg, old_pass_arg, argpos; gfc_formal_arglist *proc_formal, *old_formal; bool check_type; @@ -3838,45 +4009,13 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old) " FUNCTION", proc->name, &where); return FAILURE; } - - /* FIXME: Do more comprehensive checking (including, for instance, the - array-shape). */ - gcc_assert (proc_target->result && old_target->result); - if (!compare_type_rank (proc_target->result, old_target->result)) - { - gfc_error ("'%s' at %L and the overridden FUNCTION should have" - " matching result types and ranks", proc->name, &where); - return FAILURE; - } - /* Check string length. */ - if (proc_target->result->ts.type == BT_CHARACTER - && proc_target->result->ts.u.cl && old_target->result->ts.u.cl) + if (check_result_characteristics (proc_target, old_target, + err, sizeof(err)) == FAILURE) { - int compval = gfc_dep_compare_expr (proc_target->result->ts.u.cl->length, - old_target->result->ts.u.cl->length); - switch (compval) - { - case -1: - case 1: - case -3: - gfc_error ("Character length mismatch between '%s' at '%L' and " - "overridden FUNCTION", proc->name, &where); - return FAILURE; - - case -2: - gfc_warning ("Possible character length mismatch between '%s' at" - " '%L' and overridden FUNCTION", proc->name, &where); - break; - - case 0: - break; - - default: - gfc_internal_error ("gfc_check_typebound_override: Unexpected " - "result %i of gfc_dep_compare_expr", compval); - break; - } + gfc_error ("Result mismatch for the overriding procedure " + "'%s' at %L: %s", proc->name, &where, err); + return FAILURE; } } diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 88d4636bd71..6da131d8553 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -23,6 +23,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" +#include "coretypes.h" #include "flags.h" #include "gfortran.h" #include "intrinsic.h" @@ -901,9 +902,9 @@ gfc_intrinsic_actual_ok (const char *name, const bool subroutine_flag) } -/* Given a symbol, find out if it is (and is to be treated) an intrinsic. If - it's name refers to an intrinsic but this intrinsic is not included in the - selected standard, this returns FALSE and sets the symbol's external +/* Given a symbol, find out if it is (and is to be treated as) an intrinsic. + If its name refers to an intrinsic, but this intrinsic is not included in + the selected standard, this returns FALSE and sets the symbol's external attribute. */ bool @@ -912,10 +913,13 @@ gfc_is_intrinsic (gfc_symbol* sym, int subroutine_flag, locus loc) gfc_intrinsic_sym* isym; const char* symstd; - /* If INTRINSIC/EXTERNAL state is already known, return. */ + /* If INTRINSIC attribute is already known, return. */ if (sym->attr.intrinsic) return true; - if (sym->attr.external) + + /* Check for attributes which prevent the symbol from being INTRINSIC. */ + if (sym->attr.external || sym->attr.contained + || sym->attr.if_source == IFSRC_IFBODY) return false; if (subroutine_flag) @@ -4082,7 +4086,7 @@ gfc_intrinsic_func_interface (gfc_expr *expr, int error_flag) if ((isym->id == GFC_ISYM_REAL || isym->id == GFC_ISYM_DBLE || isym->id == GFC_ISYM_CMPLX) && gfc_init_expr_flag - && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Function '%s' " + && gfc_notify_std (GFC_STD_F2003, "Function '%s' " "as initialization expression at %L", name, &expr->where) == FAILURE) { @@ -4158,7 +4162,7 @@ got_specific: where each argument is an initialization expression */ if (gfc_init_expr_flag && isym->elemental && flag - && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Elemental function " + && gfc_notify_std (GFC_STD_F2003, "Elemental function " "as initialization expression with non-integer/non-" "character arguments at %L", &expr->where) == FAILURE) return MATCH_ERROR; @@ -4499,7 +4503,7 @@ gfc_warn_intrinsic_shadow (const gfc_symbol* sym, bool in_module, bool func) return; /* Emit the warning. */ - if (in_module) + if (in_module || sym->ns->proc_name) gfc_warning ("'%s' declared at %L may shadow the intrinsic of the same" " name. In order to call the intrinsic, explicit INTRINSIC" " declarations may be required.", diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index 9bc36d7d415..47a9feed68c 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -13029,11 +13029,11 @@ The @code{ISO_C_BINDING} module provides the following named constants of type default integer, which can be used as KIND type parameters. In addition to the integer named constants required by the Fortran 2003 -standard, GNU Fortran provides as an extension named constants for the -128-bit integer types supported by the C compiler: @code{C_INT128_T, -C_INT_LEAST128_T, C_INT_FAST128_T}. Furthermore, if @code{__float} is -supported in C, the named constants @code{C_FLOAT128, C_FLOAT128_COMPLEX} -are defined. +standard and @code{C_PTRDIFF_T} of TS 29113, GNU Fortran provides as an +extension named constants for the 128-bit integer types supported by the +C compiler: @code{C_INT128_T, C_INT_LEAST128_T, C_INT_FAST128_T}. +Furthermore, if @code{__float128} is supported in C, the named constants +@code{C_FLOAT128, C_FLOAT128_COMPLEX} are defined. @multitable @columnfractions .15 .35 .35 .35 @item Fortran Type @tab Named constant @tab C type @tab Extension @@ -13060,6 +13060,7 @@ are defined. @item @code{INTEGER}@tab @code{C_INT_FAST128_T} @tab @code{int_fast128_t} @tab Ext. @item @code{INTEGER}@tab @code{C_INTMAX_T} @tab @code{intmax_t} @item @code{INTEGER}@tab @code{C_INTPTR_T} @tab @code{intptr_t} +@item @code{INTEGER}@tab @code{C_PTRDIFF_T} @tab @code{intptr_t} @tab TS 29113 @item @code{REAL} @tab @code{C_FLOAT} @tab @code{float} @item @code{REAL} @tab @code{C_DOUBLE} @tab @code{double} @item @code{REAL} @tab @code{C_LONG_DOUBLE} @tab @code{long double} diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi index 658ed2375fc..d5fdee3c707 100644 --- a/gcc/fortran/invoke.texi +++ b/gcc/fortran/invoke.texi @@ -147,7 +147,7 @@ and warnings}. -Wimplicit-procedure -Wintrinsic-shadow -Wintrinsics-std @gol -Wline-truncation -Wno-align-commons -Wno-tabs -Wreal-q-constant @gol -Wsurprising -Wunderflow -Wunused-parameter -Wrealloc-lhs Wrealloc-lhs-all @gol --fmax-errors=@var{n} -fsyntax-only -pedantic -pedantic-errors +-Wtarget-lifetime -fmax-errors=@var{n} -fsyntax-only -pedantic -pedantic-errors } @item Debugging Options @@ -726,9 +726,10 @@ warnings. @cindex warnings, all Enables commonly used warning options pertaining to usage that we recommend avoiding and that we believe are easy to avoid. -This currently includes @option{-Waliasing}, @option{-Wampersand}, -@option{-Wconversion}, @option{-Wsurprising}, @option{-Wintrinsics-std}, -@option{-Wno-tabs}, @option{-Wintrinsic-shadow}, @option{-Wline-truncation}, +This currently includes @option{-Waliasing}, @option{-Wampersand}, +@option{-Wconversion}, @option{-Wsurprising}, +@option{-Wintrinsics-std}, @option{-Wno-tabs}, @option{-Wintrinsic-shadow}, +@option{-Wline-truncation}, @option{-Wtarget-lifetime}, @option{-Wreal-q-constant} and @option{-Wunused}. @item -Waliasing @@ -935,6 +936,15 @@ a scalar. See also @option{-frealloc-lhs}. Warn when the compiler inserts code to for allocation or reallocation of an allocatable variable; this includes scalars and derived types. +@item -Wcompare-reals +@opindex @code{Wcompare-reals} +Warn when comparing real or complex types for equality or inequality. + +@item -Wtarget-lifetime +@opindex @code{Wtargt-lifetime} +Warn if the pointer in a pointer assignment might be longer than the its +target. This option is implied by @option{-Wall}. + @item -Werror @opindex @code{Werror} @cindex warnings, to errors diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c index 7caadc5056c..428799c1262 100644 --- a/gcc/fortran/io.c +++ b/gcc/fortran/io.c @@ -22,6 +22,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" +#include "coretypes.h" #include "flags.h" #include "gfortran.h" #include "match.h" @@ -450,14 +451,14 @@ format_lex (void) c = next_char_not_space (&error); if (c == 'P') { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DP format " + if (gfc_notify_std (GFC_STD_F2003, "DP format " "specifier not allowed at %C") == FAILURE) return FMT_ERROR; token = FMT_DP; } else if (c == 'C') { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DC format " + if (gfc_notify_std (GFC_STD_F2003, "DC format " "specifier not allowed at %C") == FAILURE) return FMT_ERROR; token = FMT_DC; @@ -646,7 +647,7 @@ format_item_1: /* X requires a prior number if we're being pedantic. */ if (mode != MODE_FORMAT) format_locus.nextc += format_string_pos; - if (gfc_notify_std (GFC_STD_GNU, "Extension: X descriptor " + if (gfc_notify_std (GFC_STD_GNU, "X descriptor " "requires leading space count at %L", &format_locus) == FAILURE) return FAILURE; @@ -676,7 +677,7 @@ format_item_1: if (t == FMT_ERROR) goto fail; - if (gfc_notify_std (GFC_STD_GNU, "Extension: $ descriptor at %L", + if (gfc_notify_std (GFC_STD_GNU, "$ descriptor at %L", &format_locus) == FAILURE) return FAILURE; if (t != FMT_RPAREN || level > 0) @@ -823,7 +824,7 @@ data_desc: error = zero_width; goto syntax; } - if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: 'G0' in " + if (gfc_notify_std (GFC_STD_F2008, "'G0' in " "format at %L", &format_locus) == FAILURE) return FAILURE; u = format_lex (); @@ -1056,7 +1057,7 @@ between_desc: default: if (mode != MODE_FORMAT) format_locus.nextc += format_string_pos - 1; - if (gfc_notify_std (GFC_STD_GNU, "Extension: Missing comma at %L", + if (gfc_notify_std (GFC_STD_GNU, "Missing comma at %L", &format_locus) == FAILURE) return FAILURE; /* If we do not actually return a failure, we need to unwind this @@ -1119,7 +1120,7 @@ extension_optional_comma: default: if (mode != MODE_FORMAT) format_locus.nextc += format_string_pos; - if (gfc_notify_std (GFC_STD_GNU, "Extension: Missing comma at %L", + if (gfc_notify_std (GFC_STD_GNU, "Missing comma at %L", &format_locus) == FAILURE) return FAILURE; /* If we do not actually return a failure, we need to unwind this @@ -1404,7 +1405,7 @@ resolve_tag_format (const gfc_expr *e) } else if (e->ts.type == BT_INTEGER && e->expr_type == EXPR_VARIABLE) { - if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGNED " + if (gfc_notify_std (GFC_STD_F95_DEL, "ASSIGNED " "variable in FORMAT tag at %L", &e->where) == FAILURE) return FAILURE; @@ -1429,7 +1430,7 @@ resolve_tag_format (const gfc_expr *e) It may be assigned an Hollerith constant. */ if (e->ts.type != BT_CHARACTER) { - if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Non-character " + if (gfc_notify_std (GFC_STD_LEGACY, "Non-character " "in FORMAT tag at %L", &e->where) == FAILURE) return FAILURE; @@ -1495,7 +1496,7 @@ resolve_tag (const io_tag *tag, gfc_expr *e) if (tag == &tag_iomsg) { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IOMSG tag at %L", + if (gfc_notify_std (GFC_STD_F2003, "IOMSG tag at %L", &e->where) == FAILURE) return FAILURE; } @@ -1511,7 +1512,7 @@ resolve_tag (const io_tag *tag, gfc_expr *e) if (tag == &tag_exist && e->ts.kind != gfc_default_logical_kind) { - if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Nondefault LOGICAL " + if (gfc_notify_std (GFC_STD_F2008, "Nondefault LOGICAL " "in %s tag at %L", tag->name, &e->where) == FAILURE) return FAILURE; @@ -1519,7 +1520,7 @@ resolve_tag (const io_tag *tag, gfc_expr *e) if (tag == &tag_newunit) { - if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: NEWUNIT specifier" + if (gfc_notify_std (GFC_STD_F2008, "NEWUNIT specifier" " at %L", &e->where) == FAILURE) return FAILURE; } @@ -1537,7 +1538,7 @@ resolve_tag (const io_tag *tag, gfc_expr *e) if (tag == &tag_convert) { - if (gfc_notify_std (GFC_STD_GNU, "Extension: CONVERT tag at %L", + if (gfc_notify_std (GFC_STD_GNU, "CONVERT tag at %L", &e->where) == FAILURE) return FAILURE; } @@ -1731,7 +1732,7 @@ compare_to_allowed_values (const char *specifier, const char *allowed[], else if (n == ERROR) { - gfc_notify_std (GFC_STD_F2003, "Fortran 2003: %s specifier in " + gfc_notify_std (GFC_STD_F2003, "%s specifier in " "%s statement at %C has value '%s'", specifier, statement, allowed_f2003[i]); return 0; @@ -1758,7 +1759,7 @@ compare_to_allowed_values (const char *specifier, const char *allowed[], else if (n == ERROR) { - gfc_notify_std (GFC_STD_GNU, "Extension: %s specifier in " + gfc_notify_std (GFC_STD_GNU, "%s specifier in " "%s statement at %C has value '%s'", specifier, statement, allowed_gnu[i]); return 0; @@ -1893,7 +1894,7 @@ gfc_match_open (void) /* Checks on the ASYNCHRONOUS specifier. */ if (open->asynchronous) { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ASYNCHRONOUS= at %C " + if (gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS= at %C " "not allowed in Fortran 95") == FAILURE) goto cleanup; @@ -1911,7 +1912,7 @@ gfc_match_open (void) /* Checks on the BLANK specifier. */ if (open->blank) { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BLANK= at %C " + if (gfc_notify_std (GFC_STD_F2003, "BLANK= at %C " "not allowed in Fortran 95") == FAILURE) goto cleanup; @@ -1929,7 +1930,7 @@ gfc_match_open (void) /* Checks on the DECIMAL specifier. */ if (open->decimal) { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DECIMAL= at %C " + if (gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %C " "not allowed in Fortran 95") == FAILURE) goto cleanup; @@ -1961,7 +1962,7 @@ gfc_match_open (void) /* Checks on the ENCODING specifier. */ if (open->encoding) { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ENCODING= at %C " + if (gfc_notify_std (GFC_STD_F2003, "ENCODING= at %C " "not allowed in Fortran 95") == FAILURE) goto cleanup; @@ -2012,7 +2013,7 @@ gfc_match_open (void) /* Checks on the ROUND specifier. */ if (open->round) { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ROUND= at %C " + if (gfc_notify_std (GFC_STD_F2003, "ROUND= at %C " "not allowed in Fortran 95") == FAILURE) goto cleanup; @@ -2032,7 +2033,7 @@ gfc_match_open (void) /* Checks on the SIGN specifier. */ if (open->sign) { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SIGN= at %C " + if (gfc_notify_std (GFC_STD_F2003, "SIGN= at %C " "not allowed in Fortran 95") == FAILURE) goto cleanup; @@ -2478,7 +2479,7 @@ gfc_match_rewind (void) match gfc_match_flush (void) { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: FLUSH statement at %C") + if (gfc_notify_std (GFC_STD_F2003, "FLUSH statement at %C") == FAILURE) return MATCH_ERROR; @@ -2909,7 +2910,7 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc) } if (dt->extra_comma - && gfc_notify_std (GFC_STD_GNU, "Extension: Comma before i/o " + && gfc_notify_std (GFC_STD_GNU, "Comma before i/o " "item list at %L", &dt->extra_comma->where) == FAILURE) return FAILURE; @@ -3255,7 +3256,7 @@ if (condition) \ if (dt->namelist != NULL) { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Internal file " + if (gfc_notify_std (GFC_STD_F2003, "Internal file " "at %L with namelist", &expr->where) == FAILURE) m = MATCH_ERROR; @@ -3339,7 +3340,7 @@ if (condition) \ if (dt->decimal) { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DECIMAL= at %C " + if (gfc_notify_std (GFC_STD_F2003, "DECIMAL= at %C " "not allowed in Fortran 95") == FAILURE) return MATCH_ERROR; @@ -3360,7 +3361,7 @@ if (condition) \ if (dt->blank) { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BLANK= at %C " + if (gfc_notify_std (GFC_STD_F2003, "BLANK= at %C " "not allowed in Fortran 95") == FAILURE) return MATCH_ERROR; @@ -3381,7 +3382,7 @@ if (condition) \ if (dt->pad) { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PAD= at %C " + if (gfc_notify_std (GFC_STD_F2003, "PAD= at %C " "not allowed in Fortran 95") == FAILURE) return MATCH_ERROR; @@ -3402,7 +3403,7 @@ if (condition) \ if (dt->round) { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ROUND= at %C " + if (gfc_notify_std (GFC_STD_F2003, "ROUND= at %C " "not allowed in Fortran 95") == FAILURE) return MATCH_ERROR; @@ -3422,7 +3423,7 @@ if (condition) \ if (dt->sign) { /* When implemented, change the following to use gfc_notify_std F2003. - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SIGN= at %C " + if (gfc_notify_std (GFC_STD_F2003, "SIGN= at %C " "not allowed in Fortran 95") == FAILURE) return MATCH_ERROR; */ if (dt->sign->expr_type == EXPR_CONSTANT) @@ -3447,7 +3448,7 @@ if (condition) \ if (dt->delim) { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DELIM= at %C " + if (gfc_notify_std (GFC_STD_F2003, "DELIM= at %C " "not allowed in Fortran 95") == FAILURE) return MATCH_ERROR; @@ -4196,7 +4197,7 @@ gfc_match_wait (void) goto syntax; } - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: WAIT at %C " + if (gfc_notify_std (GFC_STD_F2003, "WAIT at %C " "not allowed in Fortran 95") == FAILURE) goto cleanup; diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 6d1e8b2a176..3f981d88c1b 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -134,9 +134,12 @@ resolve_bound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind, if (dim == NULL) { f->rank = 1; - f->shape = gfc_get_shape (1); - mpz_init_set_ui (f->shape[0], coarray ? gfc_get_corank (array) - : array->rank); + if (array->rank != -1) + { + f->shape = gfc_get_shape (1); + mpz_init_set_ui (f->shape[0], coarray ? gfc_get_corank (array) + : array->rank); + } } f->value.function.name = xstrdup (name); @@ -2225,8 +2228,12 @@ gfc_resolve_shape (gfc_expr *f, gfc_expr *array, gfc_expr *kind) f->ts.kind = gfc_default_integer_kind; f->rank = 1; - f->shape = gfc_get_shape (1); - mpz_init_set_ui (f->shape[0], array->rank); + if (array->rank != -1) + { + f->shape = gfc_get_shape (1); + mpz_init_set_ui (f->shape[0], array->rank); + } + f->value.function.name = gfc_get_string (PREFIX ("shape_%d"), f->ts.kind); } diff --git a/gcc/fortran/iso-c-binding.def b/gcc/fortran/iso-c-binding.def index f8673b963c8..66712ad0d30 100644 --- a/gcc/fortran/iso-c-binding.def +++ b/gcc/fortran/iso-c-binding.def @@ -61,6 +61,8 @@ NAMED_INTCST (ISOCBINDING_INTMAX_T, "c_intmax_t", \ get_int_kind_from_name (INTMAX_TYPE), GFC_STD_F2003) NAMED_INTCST (ISOCBINDING_INTPTR_T, "c_intptr_t", \ get_int_kind_from_name (INTPTR_TYPE), GFC_STD_F2003) +NAMED_INTCST (ISOCBINDING_PTRDIFF_T, "c_ptrdiff_t", \ + get_int_kind_from_name (PTRDIFF_TYPE), GFC_STD_F2008_TS) NAMED_INTCST (ISOCBINDING_SIZE_T, "c_size_t", \ gfc_index_integer_kind, GFC_STD_F2003) NAMED_INTCST (ISOCBINDING_SIGNED_CHAR, "c_signed_char", \ diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt index 3b9d29b0328..8a633464c4c 100644 --- a/gcc/fortran/lang.opt +++ b/gcc/fortran/lang.opt @@ -218,6 +218,10 @@ Wcharacter-truncation Fortran Warning Warn about truncated character expressions +Wcompare-reals +Fortran Warning +Warn about equality comparisons involving REAL or COMPLEX expressions + Wconversion Fortran Warning ; Documented in C @@ -258,6 +262,10 @@ Wrealloc-lhs-all Fortran Warning Warn when a left-hand-side variable is reallocated +Wtarget-lifetime +Fortran Warning +Warn if the pointer in a pointer assignment might outlive its target + Wreturn-type Fortran Warning ; Documented in C @@ -287,7 +295,7 @@ Fortran Negative(nocpp) Enable preprocessing cpp= -Fortran Joined Negative(nocpp) Undocumented +Fortran Joined Negative(nocpp) Undocumented NoDWARFRecord ; Internal option generated by specs from -cpp. nocpp diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 3d63510b00b..4c713a5d6cb 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -22,6 +22,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" +#include "coretypes.h" #include "flags.h" #include "gfortran.h" #include "match.h" @@ -1343,7 +1344,7 @@ gfc_match_pointer_assignment (void) } if (lvalue->symtree->n.sym->attr.proc_pointer - || gfc_is_proc_ptr_comp (lvalue, NULL)) + || gfc_is_proc_ptr_comp (lvalue)) gfc_matching_procptr_assignment = 1; else gfc_matching_ptr_assignment = 1; @@ -1392,7 +1393,7 @@ match_arithmetic_if (void) return MATCH_ERROR; } - if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Arithmetic IF " + if (gfc_notify_std (GFC_STD_F95_OBS, "Arithmetic IF " "statement at %C") == FAILURE) return MATCH_ERROR; @@ -1473,7 +1474,7 @@ gfc_match_if (gfc_statement *if_type) return MATCH_ERROR; } - if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Arithmetic IF " + if (gfc_notify_std (GFC_STD_F95_OBS, "Arithmetic IF " "statement at %C") == FAILURE) return MATCH_ERROR; @@ -1757,7 +1758,7 @@ gfc_match_critical (void) if (gfc_implicit_pure (NULL)) gfc_current_ns->proc_name->attr.implicit_pure = 0; - if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CRITICAL statement at %C") + if (gfc_notify_std (GFC_STD_F2008, "CRITICAL statement at %C") == FAILURE) return MATCH_ERROR; @@ -2381,7 +2382,7 @@ gfc_match_do (void) gfc_forall_iterator *head; gfc_expr *mask; - if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: DO CONCURRENT " + if (gfc_notify_std (GFC_STD_F2008, "DO CONCURRENT " "construct at %C") == FAILURE) return MATCH_ERROR; @@ -2399,7 +2400,7 @@ gfc_match_do (void) goto concurr_cleanup; if (label != NULL - && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE) + && gfc_reference_st_label (label, ST_LABEL_DO_TARGET) == FAILURE) goto concurr_cleanup; new_st.label1 = label; @@ -2453,7 +2454,7 @@ concurr_cleanup: done: if (label != NULL - && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE) + && gfc_reference_st_label (label, ST_LABEL_DO_TARGET) == FAILURE) goto cleanup; new_st.label1 = label; @@ -2580,7 +2581,7 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op) return MATCH_ERROR; } gcc_assert (op == EXEC_EXIT); - if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: EXIT statement with no" + if (gfc_notify_std (GFC_STD_F2008, "EXIT statement with no" " do-construct-name at %C") == FAILURE) return MATCH_ERROR; break; @@ -2771,7 +2772,7 @@ gfc_match_pause (void) m = gfc_match_stopcode (ST_PAUSE); if (m == MATCH_YES) { - if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: PAUSE statement" + if (gfc_notify_std (GFC_STD_F95_DEL, "PAUSE statement" " at %C") == FAILURE) m = MATCH_ERROR; @@ -2794,7 +2795,7 @@ gfc_match_stop (void) match gfc_match_error_stop (void) { - if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: ERROR STOP statement at %C") + if (gfc_notify_std (GFC_STD_F2008, "ERROR STOP statement at %C") == FAILURE) return MATCH_ERROR; @@ -2976,7 +2977,7 @@ cleanup: match gfc_match_lock (void) { - if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: LOCK statement at %C") + if (gfc_notify_std (GFC_STD_F2008, "LOCK statement at %C") == FAILURE) return MATCH_ERROR; @@ -2987,7 +2988,7 @@ gfc_match_lock (void) match gfc_match_unlock (void) { - if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: UNLOCK statement at %C") + if (gfc_notify_std (GFC_STD_F2008, "UNLOCK statement at %C") == FAILURE) return MATCH_ERROR; @@ -3020,7 +3021,7 @@ sync_statement (gfc_statement st) if (gfc_implicit_pure (NULL)) gfc_current_ns->proc_name->attr.implicit_pure = 0; - if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: SYNC statement at %C") + if (gfc_notify_std (GFC_STD_F2008, "SYNC statement at %C") == FAILURE) return MATCH_ERROR; @@ -3218,7 +3219,7 @@ gfc_match_assign (void) return MATCH_ERROR; if (gfc_match (" to %v%t", &expr) == MATCH_YES) { - if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGN " + if (gfc_notify_std (GFC_STD_F95_DEL, "ASSIGN " "statement at %C") == FAILURE) return MATCH_ERROR; @@ -3264,7 +3265,7 @@ gfc_match_goto (void) if (gfc_match_variable (&expr, 0) == MATCH_YES) { - if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: Assigned GOTO " + if (gfc_notify_std (GFC_STD_F95_DEL, "Assigned GOTO " "statement at %C") == FAILURE) return MATCH_ERROR; @@ -3374,7 +3375,7 @@ gfc_match_goto (void) if (gfc_match (" %e%t", &expr) != MATCH_YES) goto syntax; - if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Computed GOTO " + if (gfc_notify_std (GFC_STD_F95_OBS, "Computed GOTO " "at %C") == FAILURE) return MATCH_ERROR; @@ -3456,7 +3457,7 @@ gfc_match_allocate (void) { if (gfc_match (" :: ") == MATCH_YES) { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: typespec in " + if (gfc_notify_std (GFC_STD_F2003, "typespec in " "ALLOCATE at %L", &old_locus) == FAILURE) goto cleanup; @@ -3619,7 +3620,7 @@ alloc_opt_list: goto cleanup; if (m == MATCH_YES) { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG tag at %L", + if (gfc_notify_std (GFC_STD_F2003, "ERRMSG tag at %L", &tmp->where) == FAILURE) goto cleanup; @@ -3643,7 +3644,7 @@ alloc_opt_list: goto cleanup; if (m == MATCH_YES) { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SOURCE tag at %L", + if (gfc_notify_std (GFC_STD_F2003, "SOURCE tag at %L", &tmp->where) == FAILURE) goto cleanup; @@ -3663,7 +3664,7 @@ alloc_opt_list: } if (head->next - && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: SOURCE tag at %L" + && gfc_notify_std (GFC_STD_F2008, "SOURCE tag at %L" " with more than a single allocate object", &tmp->where) == FAILURE) goto cleanup; @@ -3681,7 +3682,7 @@ alloc_opt_list: goto cleanup; if (m == MATCH_YES) { - if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: MOLD tag at %L", + if (gfc_notify_std (GFC_STD_F2008, "MOLD tag at %L", &tmp->where) == FAILURE) goto cleanup; @@ -3943,7 +3944,7 @@ dealloc_opt_list: goto cleanup; if (m == MATCH_YES) { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG at %L", + if (gfc_notify_std (GFC_STD_F2003, "ERRMSG at %L", &tmp->where) == FAILURE) goto cleanup; @@ -4021,7 +4022,7 @@ gfc_match_return (void) goto cleanup; } - if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Alternate RETURN " + if (gfc_notify_std (GFC_STD_F95_OBS, "Alternate RETURN " "at %C") == FAILURE) return MATCH_ERROR; @@ -4051,7 +4052,7 @@ cleanup: done: gfc_enclosing_unit (&s); if (s == COMP_PROGRAM - && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in " + && gfc_notify_std (GFC_STD_GNU, "RETURN statement in " "main program at %C") == FAILURE) return MATCH_ERROR; @@ -4397,6 +4398,7 @@ gfc_match_common (void) /* Store a ref to the common block for error checking. */ sym->common_block = t; + sym->common_block->refs++; /* See if we know the current common block is bind(c), and if so, then see if we can check if the symbol is (which it'll @@ -4965,7 +4967,7 @@ gfc_match_st_function (void) sym->value = expr; - if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: " + if (gfc_notify_std (GFC_STD_F95_OBS, "Statement function at %C") == FAILURE) return MATCH_ERROR; diff --git a/gcc/fortran/matchexp.c b/gcc/fortran/matchexp.c index cd70dc0f758..12d5b2dcbab 100644 --- a/gcc/fortran/matchexp.c +++ b/gcc/fortran/matchexp.c @@ -21,6 +21,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" +#include "coretypes.h" #include "gfortran.h" #include "arith.h" #include "match.h" diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c index 012364ae774..60c3cf1ddd3 100644 --- a/gcc/fortran/misc.c +++ b/gcc/fortran/misc.c @@ -21,6 +21,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" +#include "coretypes.h" #include "gfortran.h" diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 60a74cacca4..bfd8b01ea09 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -68,6 +68,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" +#include "coretypes.h" #include "gfortran.h" #include "arith.h" #include "match.h" @@ -552,7 +553,7 @@ gfc_match_use (void) { if ((m = gfc_match (" %n ::", module_nature)) == MATCH_YES) { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: module " + if (gfc_notify_std (GFC_STD_F2003, "module " "nature in USE statement at %C") == FAILURE) goto cleanup; @@ -587,7 +588,7 @@ gfc_match_use (void) { m = gfc_match (" ::"); if (m == MATCH_YES && - gfc_notify_std (GFC_STD_F2003, "Fortran 2003: " + gfc_notify_std (GFC_STD_F2003, "\"USE :: module\" at %C") == FAILURE) goto cleanup; @@ -655,7 +656,7 @@ gfc_match_use (void) m = gfc_match (" =>"); if (type == INTERFACE_USER_OP && m == MATCH_YES - && (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Renaming " + && (gfc_notify_std (GFC_STD_F2003, "Renaming " "operators in USE statements at %C") == FAILURE)) goto cleanup; @@ -2340,6 +2341,7 @@ mio_typespec (gfc_typespec *ts) static const mstring array_spec_types[] = { minit ("EXPLICIT", AS_EXPLICIT), + minit ("ASSUMED_RANK", AS_ASSUMED_RANK), minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE), minit ("DEFERRED", AS_DEFERRED), minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE), @@ -2357,9 +2359,15 @@ mio_array_spec (gfc_array_spec **asp) if (iomode == IO_OUTPUT) { + int rank; + if (*asp == NULL) goto done; as = *asp; + + /* mio_integer expects nonnegative values. */ + rank = as->rank > 0 ? as->rank : 0; + mio_integer (&rank); } else { @@ -2370,20 +2378,23 @@ mio_array_spec (gfc_array_spec **asp) } *asp = as = gfc_get_array_spec (); + mio_integer (&as->rank); } - mio_integer (&as->rank); mio_integer (&as->corank); as->type = MIO_NAME (array_type) (as->type, array_spec_types); + if (iomode == IO_INPUT && as->type == AS_ASSUMED_RANK) + as->rank = -1; if (iomode == IO_INPUT && as->corank) as->cotype = (as->type == AS_DEFERRED) ? AS_DEFERRED : AS_EXPLICIT; - for (i = 0; i < as->rank + as->corank; i++) - { - mio_expr (&as->lower[i]); - mio_expr (&as->upper[i]); - } + if (as->rank > 0) + for (i = 0; i < as->rank + as->corank; i++) + { + mio_expr (&as->lower[i]); + mio_expr (&as->upper[i]); + } done: mio_rparen (); @@ -3796,10 +3807,7 @@ mio_symbol (gfc_symbol *sym) { mio_namespace_ref (&sym->formal_ns); if (sym->formal_ns) - { - sym->formal_ns->proc_name = sym; - sym->refs++; - } + sym->formal_ns->proc_name = sym; } /* Save/restore common block links. */ @@ -6050,7 +6058,7 @@ gfc_use_module (gfc_use_list *module) if (module_fp == NULL && !module->non_intrinsic) { if (strcmp (module_name, "iso_fortran_env") == 0 - && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ISO_FORTRAN_ENV " + && gfc_notify_std (GFC_STD_F2003, "ISO_FORTRAN_ENV " "intrinsic module at %C") != FAILURE) { use_iso_fortran_env_module (); @@ -6060,7 +6068,7 @@ gfc_use_module (gfc_use_list *module) } if (strcmp (module_name, "iso_c_binding") == 0 - && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: " + && gfc_notify_std (GFC_STD_F2003, "ISO_C_BINDING module at %C") != FAILURE) { import_iso_c_binding_module(); diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c index f5a58779c0c..e1ffa6b49f7 100644 --- a/gcc/fortran/openmp.c +++ b/gcc/fortran/openmp.c @@ -21,6 +21,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" +#include "coretypes.h" #include "flags.h" #include "gfortran.h" #include "match.h" diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c index f1721ce0a9b..764f5706ad0 100644 --- a/gcc/fortran/options.c +++ b/gcc/fortran/options.c @@ -113,6 +113,8 @@ gfc_init_options (unsigned int decoded_options_count, gfc_option.warn_unused_dummy_argument = 0; gfc_option.warn_realloc_lhs = 0; gfc_option.warn_realloc_lhs_all = 0; + gfc_option.warn_compare_reals = 0; + gfc_option.warn_target_lifetime = 0; gfc_option.max_errors = 25; gfc_option.flag_all_intrinsics = 0; @@ -473,6 +475,7 @@ set_Wall (int setting) gfc_option.warn_character_truncation = setting; gfc_option.warn_real_q_constant = setting; gfc_option.warn_unused_dummy_argument = setting; + gfc_option.warn_target_lifetime = setting; warn_return_type = setting; warn_switch = setting; @@ -638,6 +641,10 @@ gfc_handle_option (size_t scode, const char *arg, int value, gfc_option.warn_character_truncation = value; break; + case OPT_Wcompare_reals: + gfc_option.warn_compare_reals = value; + break; + case OPT_Wconversion: gfc_option.gfc_warn_conversion = value; break; @@ -682,6 +689,10 @@ gfc_handle_option (size_t scode, const char *arg, int value, gfc_option.warn_tabs = value; break; + case OPT_Wtarget_lifetime: + gfc_option.warn_target_lifetime = value; + break; + case OPT_Wunderflow: gfc_option.warn_underflow = value; break; @@ -819,7 +830,6 @@ gfc_handle_option (size_t scode, const char *arg, int value, break; case OPT_fintrinsic_modules_path: - gfc_add_include_path (arg, false, false); gfc_add_intrinsic_modules_path (arg); break; diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 4e7f691e630..5c5d38176c3 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -23,6 +23,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" #include <setjmp.h> +#include "coretypes.h" #include "gfortran.h" #include "match.h" #include "parse.h" @@ -75,7 +76,7 @@ match_word (const char *str, match (*subr) (void), locus *old_locus) } -/* Load symbols from all USE statements encounted in this scoping unit. */ +/* Load symbols from all USE statements encountered in this scoping unit. */ static void use_modules (void) @@ -1167,7 +1168,10 @@ check_statement_label (gfc_statement st) case ST_END_ASSOCIATE: case_executable: case_exec_markers: - type = ST_LABEL_TARGET; + if (st == ST_ENDDO || st == ST_CONTINUE) + type = ST_LABEL_DO_TARGET; + else + type = ST_LABEL_TARGET; break; case ST_FORMAT: @@ -1975,7 +1979,7 @@ parse_derived_contains (void) goto error; case ST_PROCEDURE: - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Type-bound" + if (gfc_notify_std (GFC_STD_F2003, "Type-bound" " procedure at %C") == FAILURE) goto error; @@ -1984,7 +1988,7 @@ parse_derived_contains (void) break; case ST_GENERIC: - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: GENERIC binding" + if (gfc_notify_std (GFC_STD_F2003, "GENERIC binding" " at %C") == FAILURE) goto error; @@ -1994,7 +1998,7 @@ parse_derived_contains (void) case ST_FINAL: if (gfc_notify_std (GFC_STD_F2003, - "Fortran 2003: FINAL procedure declaration" + "FINAL procedure declaration" " at %C") == FAILURE) goto error; @@ -2006,7 +2010,7 @@ parse_derived_contains (void) to_finish = true; if (!seen_comps - && (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Derived type " + && (gfc_notify_std (GFC_STD_F2008, "Derived type " "definition at %C with empty CONTAINS " "section") == FAILURE)) goto error; @@ -2111,7 +2115,7 @@ endType: compiling_type = 0; if (!seen_component) - gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Derived type " + gfc_notify_std (GFC_STD_F2003, "Derived type " "definition at %C without components"); accept_statement (ST_END_TYPE); @@ -2165,7 +2169,7 @@ endType: case ST_CONTAINS: gfc_notify_std (GFC_STD_F2003, - "Fortran 2003: CONTAINS block in derived type" + "CONTAINS block in derived type" " definition at %C"); accept_statement (ST_CONTAINS); @@ -2359,7 +2363,6 @@ parse_interface (void) gfc_interface_info save; gfc_state_data s1, s2; gfc_statement st; - locus proc_locus; accept_statement (ST_INTERFACE); @@ -2448,7 +2451,9 @@ loop: accept_statement (st); prog_unit = gfc_new_block; prog_unit->formal_ns = gfc_current_ns; - proc_locus = gfc_current_locus; + if (prog_unit == prog_unit->formal_ns->proc_name + && prog_unit->ns != prog_unit->formal_ns) + prog_unit->refs++; decl: /* Read data declaration statements. */ @@ -2489,7 +2494,8 @@ decl: && strcmp (current_interface.ns->proc_name->name, prog_unit->name) == 0) gfc_error ("INTERFACE procedure '%s' at %L has the same name as the " - "enclosing procedure", prog_unit->name, &proc_locus); + "enclosing procedure", prog_unit->name, + ¤t_interface.ns->proc_name->declared_at); goto loop; @@ -3267,7 +3273,7 @@ parse_critical_block (void) if (s.ext.end_do_label != NULL && s.ext.end_do_label != gfc_statement_label) gfc_error_now ("Statement label in END CRITICAL at %C does not " - "match CRITIAL label"); + "match CRITICAL label"); if (gfc_statement_label != NULL) { @@ -3334,7 +3340,7 @@ parse_block_construct (void) gfc_namespace* my_ns; gfc_state_data s; - gfc_notify_std (GFC_STD_F2008, "Fortran 2008: BLOCK construct at %C"); + gfc_notify_std (GFC_STD_F2008, "BLOCK construct at %C"); my_ns = gfc_build_block_ns (gfc_current_ns); @@ -3364,7 +3370,7 @@ parse_associate (void) gfc_statement st; gfc_association_list* a; - gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ASSOCIATE construct at %C"); + gfc_notify_std (GFC_STD_F2003, "ASSOCIATE construct at %C"); my_ns = gfc_build_block_ns (gfc_current_ns); @@ -3392,7 +3398,7 @@ parse_associate (void) however, as it may only be set on the target during resolution. Still, sometimes it helps to have it right now -- especially for parsing component references on the associate-name - in case of assication to a derived-type. */ + in case of association to a derived-type. */ sym->ts = a->target->ts; } @@ -3824,8 +3830,12 @@ parse_executable (gfc_statement st) case ST_NONE: unexpected_eof (); - case ST_FORMAT: case ST_DATA: + gfc_notify_std (GFC_STD_F95_OBS, "DATA statement at %C after the " + "first executable statement"); + /* Fall through. */ + + case ST_FORMAT: case ST_ENTRY: case_executable: accept_statement (st); @@ -4067,6 +4077,7 @@ parse_contained (int module) case ST_END_PROGRAM: case ST_END_SUBROUTINE: accept_statement (st); + gfc_current_ns->code = s1.head; break; default: @@ -4094,7 +4105,7 @@ parse_contained (int module) pop_state (); if (!contains_statements) - gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CONTAINS statement without " + gfc_notify_std (GFC_STD_F2008, "CONTAINS statement without " "FUNCTION or SUBROUTINE statement at %C"); } @@ -4512,6 +4523,7 @@ gfc_parse_file (void) gfc_global_ns_list = next = NULL; seen_program = 0; + errors_before = 0; /* Exit early for empty files. */ if (gfc_at_eof ()) diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 41e2fa81efb..cadc20c27b7 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -22,6 +22,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" +#include "coretypes.h" #include "flags.h" #include "gfortran.h" #include "arith.h" @@ -268,7 +269,7 @@ match_hollerith_constant (gfc_expr **result) if (match_integer_constant (&e, 0) == MATCH_YES && gfc_match_char ('h') == MATCH_YES) { - if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Hollerith constant " + if (gfc_notify_std (GFC_STD_LEGACY, "Hollerith constant " "at %C") == FAILURE) goto cleanup; @@ -392,7 +393,7 @@ match_boz_constant (gfc_expr **result) goto backup; if (x_hex - && (gfc_notify_std (GFC_STD_GNU, "Extension: Hexadecimal " + && (gfc_notify_std (GFC_STD_GNU, "Hexadecimal " "constant at %C uses non-standard syntax") == FAILURE)) return MATCH_ERROR; @@ -431,7 +432,7 @@ match_boz_constant (gfc_expr **result) goto backup; } - if (gfc_notify_std (GFC_STD_GNU, "Extension: BOZ constant " + if (gfc_notify_std (GFC_STD_GNU, "BOZ constant " "at %C uses non-standard postfix syntax") == FAILURE) return MATCH_ERROR; @@ -468,7 +469,7 @@ match_boz_constant (gfc_expr **result) } if (!gfc_in_match_data () - && (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BOZ used outside a DATA " + && (gfc_notify_std (GFC_STD_F2003, "BOZ used outside a DATA " "statement at %C") == FAILURE)) return MATCH_ERROR; @@ -559,7 +560,7 @@ match_real_constant (gfc_expr **result, int signflag) if (c == 'q') { - if (gfc_notify_std (GFC_STD_GNU, "Extension: exponent-letter 'q' in " + if (gfc_notify_std (GFC_STD_GNU, "exponent-letter 'q' in " "real-literal-constant at %C") == FAILURE) return MATCH_ERROR; else if (gfc_option.warn_real_q_constant) @@ -1217,7 +1218,7 @@ match_sym_complex_part (gfc_expr **result) return MATCH_ERROR; } - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PARAMETER symbol in " + if (gfc_notify_std (GFC_STD_F2003, "PARAMETER symbol in " "complex constant at %C") == FAILURE) return MATCH_ERROR; @@ -1645,7 +1646,7 @@ match_arg_list_function (gfc_actual_arglist *result) } } - if (gfc_notify_std (GFC_STD_GNU, "Extension: argument list " + if (gfc_notify_std (GFC_STD_GNU, "argument list " "function at %C") == FAILURE) { m = MATCH_ERROR; @@ -1861,7 +1862,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, if ((equiv_flag && gfc_peek_ascii_char () == '(') || gfc_peek_ascii_char () == '[' || sym->attr.codimension || (sym->attr.dimension && sym->ts.type != BT_CLASS - && !sym->attr.proc_pointer && !gfc_is_proc_ptr_comp (primary, NULL) + && !sym->attr.proc_pointer && !gfc_is_proc_ptr_comp (primary) && !(gfc_matching_procptr_assignment && sym->attr.flavor == FL_PROCEDURE)) || (sym->ts.type == BT_CLASS && sym->attr.class_ok @@ -2352,7 +2353,7 @@ build_actual_constructor (gfc_structure_ctor_component **comp_head, { if (comp->initializer) { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure" + if (gfc_notify_std (GFC_STD_F2003, "Structure" " constructor with missing optional arguments" " at %C") == FAILURE) return FAILURE; @@ -2428,7 +2429,7 @@ gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **c } if (actual->name) { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure" + if (gfc_notify_std (GFC_STD_F2003, "Structure" " constructor with named arguments at %C") == FAILURE) goto cleanup; @@ -2842,13 +2843,18 @@ gfc_match_rvalue (gfc_expr **result) /* Parse functions returning a procptr. */ goto function0; - if (gfc_is_intrinsic (sym, 0, gfc_current_locus) - || gfc_is_intrinsic (sym, 1, gfc_current_locus)) - sym->attr.intrinsic = 1; e = gfc_get_expr (); e->expr_type = EXPR_VARIABLE; e->symtree = symtree; m = gfc_match_varspec (e, 0, false, true); + if (!e->ref && sym->attr.flavor == FL_UNKNOWN + && sym->ts.type == BT_UNKNOWN + && gfc_add_flavor (&sym->attr, FL_PROCEDURE, + sym->name, NULL) == FAILURE) + { + m = MATCH_ERROR; + break; + } break; } diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 0434e0804c7..312713bcc54 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -22,6 +22,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" +#include "coretypes.h" #include "flags.h" #include "gfortran.h" #include "obstack.h" @@ -63,7 +64,13 @@ static code_stack *cs_base = NULL; static int forall_flag; static int do_concurrent_flag; -static bool assumed_type_expr_allowed = false; +/* True when we are resolving an expression that is an actual argument to + a procedure. */ +static bool actual_arg = false; +/* True when we are resolving an expression that is the first actual argument + to a procedure. */ +static bool first_actual_arg = false; + /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */ @@ -85,6 +92,7 @@ static bitmap_obstack labels_obstack; /* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */ static bool inquiry_argument = false; + int gfc_is_formal_arg (void) { @@ -130,8 +138,55 @@ resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name) } +static gfc_try +check_proc_interface (gfc_symbol *ifc, locus *where) +{ + /* Several checks for F08:C1216. */ + if (ifc->attr.procedure) + { + gfc_error ("Interface '%s' at %L is declared " + "in a later PROCEDURE statement", ifc->name, where); + return FAILURE; + } + if (ifc->generic) + { + /* For generic interfaces, check if there is + a specific procedure with the same name. */ + gfc_interface *gen = ifc->generic; + while (gen && strcmp (gen->sym->name, ifc->name) != 0) + gen = gen->next; + if (!gen) + { + gfc_error ("Interface '%s' at %L may not be generic", + ifc->name, where); + return FAILURE; + } + } + if (ifc->attr.proc == PROC_ST_FUNCTION) + { + gfc_error ("Interface '%s' at %L may not be a statement function", + ifc->name, where); + return FAILURE; + } + if (gfc_is_intrinsic (ifc, 0, ifc->declared_at) + || gfc_is_intrinsic (ifc, 1, ifc->declared_at)) + ifc->attr.intrinsic = 1; + if (ifc->attr.intrinsic && !gfc_intrinsic_actual_ok (ifc->name, 0)) + { + gfc_error ("Intrinsic procedure '%s' not allowed in " + "PROCEDURE statement at %L", ifc->name, where); + return FAILURE; + } + if (!ifc->attr.if_source && !ifc->attr.intrinsic && ifc->name[0] != '\0') + { + gfc_error ("Interface '%s' at %L must be explicit", ifc->name, where); + return FAILURE; + } + return SUCCESS; +} + + static void resolve_symbol (gfc_symbol *sym); -static gfc_try resolve_intrinsic (gfc_symbol *sym, locus *loc); /* Resolve the interface for a PROCEDURE declaration or procedure pointer. */ @@ -139,28 +194,26 @@ static gfc_try resolve_intrinsic (gfc_symbol *sym, locus *loc); static gfc_try resolve_procedure_interface (gfc_symbol *sym) { - if (sym->ts.interface == sym) + gfc_symbol *ifc = sym->ts.interface; + + if (!ifc) + return SUCCESS; + + if (ifc == sym) { gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface", sym->name, &sym->declared_at); return FAILURE; } - if (sym->ts.interface->attr.procedure) - { - gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared " - "in a later PROCEDURE statement", sym->ts.interface->name, - sym->name, &sym->declared_at); - return FAILURE; - } + if (check_proc_interface (ifc, &sym->declared_at) == FAILURE) + return FAILURE; - /* Get the attributes from the interface (now resolved). */ - if (sym->ts.interface->attr.if_source || sym->ts.interface->attr.intrinsic) + if (ifc->attr.if_source || ifc->attr.intrinsic) { - gfc_symbol *ifc = sym->ts.interface; + /* Resolve interface and copy attributes. */ resolve_symbol (ifc); - if (ifc->attr.intrinsic) - resolve_intrinsic (ifc, &ifc->declared_at); + gfc_resolve_intrinsic (ifc, &ifc->declared_at); if (ifc->result) { @@ -172,7 +225,7 @@ resolve_procedure_interface (gfc_symbol *sym) sym->ts.interface = ifc; sym->attr.function = ifc->attr.function; sym->attr.subroutine = ifc->attr.subroutine; - gfc_copy_formal_args (sym, ifc); + gfc_copy_formal_args (sym, ifc, IFSRC_DECL); sym->attr.allocatable = ifc->attr.allocatable; sym->attr.pointer = ifc->attr.pointer; @@ -184,6 +237,7 @@ resolve_procedure_interface (gfc_symbol *sym) sym->attr.always_explicit = ifc->attr.always_explicit; sym->attr.ext_attr |= ifc->attr.ext_attr; sym->attr.is_bind_c = ifc->attr.is_bind_c; + sym->attr.class_ok = ifc->attr.class_ok; /* Copy array spec. */ sym->as = gfc_copy_array_spec (ifc->as); if (sym->as) @@ -205,12 +259,6 @@ resolve_procedure_interface (gfc_symbol *sym) return FAILURE; } } - else if (sym->ts.interface->name[0] != '\0') - { - gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit", - sym->ts.interface->name, sym->name, &sym->declared_at); - return FAILURE; - } return SUCCESS; } @@ -239,7 +287,7 @@ resolve_formal_arglist (gfc_symbol *proc) if (gfc_elemental (proc) || sym->attr.pointer || sym->attr.allocatable - || (sym->as && sym->as->rank > 0)) + || (sym->as && sym->as->rank != 0)) { proc->attr.always_explicit = 1; sym->attr.always_explicit = 1; @@ -249,6 +297,8 @@ resolve_formal_arglist (gfc_symbol *proc) for (f = proc->formal; f; f = f->next) { + gfc_array_spec *as; + sym = f->sym; if (sym == NULL) @@ -264,9 +314,9 @@ resolve_formal_arglist (gfc_symbol *proc) &proc->declared_at); continue; } - else if (sym->attr.procedure && sym->ts.interface - && sym->attr.if_source != IFSRC_DECL) - resolve_procedure_interface (sym); + else if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL + && resolve_procedure_interface (sym) == FAILURE) + return; if (sym->attr.if_source != IFSRC_UNKNOWN) resolve_formal_arglist (sym); @@ -283,23 +333,34 @@ resolve_formal_arglist (gfc_symbol *proc) gfc_set_default_type (sym, 1, sym->ns); } - gfc_resolve_array_spec (sym->as, 0); + as = sym->ts.type == BT_CLASS && sym->attr.class_ok + ? CLASS_DATA (sym)->as : sym->as; + + gfc_resolve_array_spec (as, 0); /* We can't tell if an array with dimension (:) is assumed or deferred shape until we know if it has the pointer or allocatable attributes. */ - if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED - && !(sym->attr.pointer || sym->attr.allocatable) + if (as && as->rank > 0 && as->type == AS_DEFERRED + && ((sym->ts.type != BT_CLASS + && !(sym->attr.pointer || sym->attr.allocatable)) + || (sym->ts.type == BT_CLASS + && !(CLASS_DATA (sym)->attr.class_pointer + || CLASS_DATA (sym)->attr.allocatable))) && sym->attr.flavor != FL_PROCEDURE) { - sym->as->type = AS_ASSUMED_SHAPE; - for (i = 0; i < sym->as->rank; i++) - sym->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, - NULL, 1); + as->type = AS_ASSUMED_SHAPE; + for (i = 0; i < as->rank; i++) + as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); } - if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE) + if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE) + || (as && as->type == AS_ASSUMED_RANK) || sym->attr.pointer || sym->attr.allocatable || sym->attr.target + || (sym->ts.type == BT_CLASS && sym->attr.class_ok + && (CLASS_DATA (sym)->attr.class_pointer + || CLASS_DATA (sym)->attr.allocatable + || CLASS_DATA (sym)->attr.target)) || sym->attr.optional) { proc->attr.always_explicit = 1; @@ -330,7 +391,7 @@ resolve_formal_arglist (gfc_symbol *proc) if (proc->attr.function && sym->attr.intent != INTENT_IN) { if (sym->attr.value) - gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Argument '%s'" + gfc_notify_std (GFC_STD_F2008, "Argument '%s'" " of pure function '%s' at %L with VALUE " "attribute but without INTENT(IN)", sym->name, proc->name, &sym->declared_at); @@ -343,7 +404,7 @@ resolve_formal_arglist (gfc_symbol *proc) if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN) { if (sym->attr.value) - gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Argument '%s'" + gfc_notify_std (GFC_STD_F2008, "Argument '%s'" " of pure subroutine '%s' at %L with VALUE " "attribute but without INTENT", sym->name, proc->name, &sym->declared_at); @@ -722,7 +783,7 @@ resolve_entries (gfc_namespace *ns) && ts->u.cl->length->expr_type == EXPR_CONSTANT && mpz_cmp (ts->u.cl->length->value.integer, fts->u.cl->length->value.integer) != 0))) - gfc_notify_std (GFC_STD_GNU, "Extension: Function %s at %L with " + gfc_notify_std (GFC_STD_GNU, "Function %s at %L with " "entries returning variables of different " "string lengths", ns->entries->sym->name, &ns->entries->sym->declared_at); @@ -915,12 +976,12 @@ resolve_common_blocks (gfc_symtree *common_root) sym->name, &common_root->n.common->where); else if (sym->attr.result || gfc_is_function_return_value (sym, gfc_current_ns)) - gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L " + gfc_notify_std (GFC_STD_F2003, "COMMON block '%s' at %L " "that is also a function result", sym->name, &common_root->n.common->where); else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL && sym->attr.proc != PROC_ST_FUNCTION) - gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' at %L " + gfc_notify_std (GFC_STD_F2003, "COMMON block '%s' at %L " "that is also a global procedure", sym->name, &common_root->n.common->where); } @@ -1135,7 +1196,8 @@ resolve_structure_cons (gfc_expr *expr, int init) const char *name; char err[200]; - if (gfc_is_proc_ptr_comp (cons->expr, &c2)) + c2 = gfc_get_proc_ptr_comp (cons->expr); + if (c2) { s2 = c2->ts.interface; name = c2->name; @@ -1478,8 +1540,8 @@ is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context) /* Resolve an intrinsic procedure: Set its function/subroutine attribute, its typespec and formal argument list. */ -static gfc_try -resolve_intrinsic (gfc_symbol *sym, locus *loc) +gfc_try +gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc) { gfc_intrinsic_sym* isym = NULL; const char* symstd; @@ -1567,7 +1629,7 @@ resolve_procedure_expression (gfc_expr* expr) sym = expr->symtree->n.sym; if (sym->attr.intrinsic) - resolve_intrinsic (sym, &expr->where); + gfc_resolve_intrinsic (sym, &expr->where); if (sym->attr.flavor != FL_PROCEDURE || (sym->attr.function && sym->result == sym)) @@ -1598,8 +1660,11 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, gfc_symtree *parent_st; gfc_expr *e; int save_need_full_assumed_size; + gfc_try return_value = FAILURE; + bool actual_arg_sav = actual_arg, first_actual_arg_sav = first_actual_arg; - assumed_type_expr_allowed = true; + actual_arg = true; + first_actual_arg = true; for (; arg; arg = arg->next) { @@ -1613,9 +1678,10 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, { gfc_error ("Label %d referenced at %L is never defined", arg->label->value, &arg->label->where); - return FAILURE; + goto cleanup; } } + first_actual_arg = false; continue; } @@ -1623,7 +1689,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, && e->symtree->n.sym->attr.generic && no_formal_args && count_specific_procs (e) != 1) - return FAILURE; + goto cleanup; if (e->ts.type != BT_PROCEDURE) { @@ -1631,7 +1697,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, if (e->expr_type != EXPR_VARIABLE) need_full_assumed_size = 0; if (gfc_resolve_expr (e) != SUCCESS) - return FAILURE; + goto cleanup; need_full_assumed_size = save_need_full_assumed_size; goto argument_list; } @@ -1648,10 +1714,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, /* If a procedure is not already determined to be something else check if it is intrinsic. */ - if (!sym->attr.intrinsic - && !(sym->attr.external || sym->attr.use_assoc - || sym->attr.if_source == IFSRC_IFBODY) - && gfc_is_intrinsic (sym, sym->attr.subroutine, e->where)) + if (gfc_is_intrinsic (sym, sym->attr.subroutine, e->where)) sym->attr.intrinsic = 1; if (sym->attr.proc == PROC_ST_FUNCTION) @@ -1672,10 +1735,10 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, && sym->ns->proc_name->attr.flavor != FL_MODULE) { if (gfc_notify_std (GFC_STD_F2008, - "Fortran 2008: Internal procedure '%s' is" + "Internal procedure '%s' is" " used as actual argument at %L", sym->name, &e->where) == FAILURE) - return FAILURE; + goto cleanup; } if (sym->attr.elemental && !sym->attr.intrinsic) @@ -1688,8 +1751,8 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, /* Check if a generic interface has a specific procedure with the same name before emitting an error. */ if (sym->attr.generic && count_specific_procs (e) != 1) - return FAILURE; - + goto cleanup; + /* Just in case a specific was found for the expression. */ sym = e->symtree->n.sym; @@ -1710,7 +1773,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, gfc_error ("Unable to find a specific INTRINSIC procedure " "for the reference '%s' at %L", sym->name, &e->where); - return FAILURE; + goto cleanup; } sym->ts = isym->ts; sym->attr.intrinsic = 1; @@ -1718,7 +1781,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, } if (gfc_resolve_expr (e) == FAILURE) - return FAILURE; + goto cleanup; goto argument_list; } @@ -1730,7 +1793,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st)) { gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where); - return FAILURE; + goto cleanup; } if (parent_st == NULL) @@ -1744,7 +1807,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, || sym->attr.external) { if (gfc_resolve_expr (e) == FAILURE) - return FAILURE; + goto cleanup; goto argument_list; } @@ -1772,7 +1835,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, if (e->expr_type != EXPR_VARIABLE) need_full_assumed_size = 0; if (gfc_resolve_expr (e) != SUCCESS) - return FAILURE; + goto cleanup; need_full_assumed_size = save_need_full_assumed_size; argument_list: @@ -1786,14 +1849,14 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, { gfc_error ("By-value argument at %L is not of numeric " "type", &e->where); - return FAILURE; + goto cleanup; } if (e->rank) { gfc_error ("By-value argument at %L cannot be an array or " "an array section", &e->where); - return FAILURE; + goto cleanup; } /* Intrinsics are still PROC_UNKNOWN here. However, @@ -1807,7 +1870,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, { gfc_error ("By-value argument at %L is not allowed " "in this context", &e->where); - return FAILURE; + goto cleanup; } } @@ -1819,23 +1882,30 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, { gfc_error ("Passing internal procedure at %L by location " "not allowed", &e->where); - return FAILURE; + goto cleanup; } } } /* Fortran 2008, C1237. */ if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e) - && gfc_has_ultimate_pointer (e)) - { - gfc_error ("Coindexed actual argument at %L with ultimate pointer " + && gfc_has_ultimate_pointer (e)) + { + gfc_error ("Coindexed actual argument at %L with ultimate pointer " "component", &e->where); - return FAILURE; - } + goto cleanup; + } + + first_actual_arg = false; } - assumed_type_expr_allowed = false; - return SUCCESS; + return_value = SUCCESS; + +cleanup: + actual_arg = actual_arg_sav; + first_actual_arg = first_actual_arg_sav; + + return return_value; } @@ -1895,7 +1965,7 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c) /* The rank of an elemental is the rank of its array argument(s). */ for (arg = arg0; arg; arg = arg->next) { - if (arg->expr != NULL && arg->expr->rank > 0) + if (arg->expr != NULL && arg->expr->rank != 0) { rank = arg->expr->rank; if (arg->expr->expr_type == EXPR_VARIABLE @@ -2194,6 +2264,15 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, sym->name, &sym->declared_at, arg->sym->name); break; } + /* TS 29113, 6.2. */ + else if (arg->sym && arg->sym->as + && arg->sym->as->type == AS_ASSUMED_RANK) + { + gfc_error ("Procedure '%s' at %L with assumed-rank dummy " + "argument '%s' must have an explicit interface", + sym->name, &sym->declared_at, arg->sym->name); + break; + } /* F2008, 12.4.2.2 (2c) */ else if (arg->sym->attr.codimension) { @@ -2219,6 +2298,15 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, sym->name, &sym->declared_at, arg->sym->name); break; } + /* As assumed-type is unlimited polymorphic (cf. above). + See also TS 29113, Note 6.1. */ + else if (arg->sym->ts.type == BT_ASSUMED) + { + gfc_error ("Procedure '%s' at %L with assumed-type dummy " + "argument '%s' must have an explicit interface", + sym->name, &sym->declared_at, arg->sym->name); + break; + } } if (def_sym->attr.function) @@ -2552,8 +2640,7 @@ static bool is_external_proc (gfc_symbol *sym) { if (!sym->attr.dummy && !sym->attr.contained - && !(sym->attr.intrinsic - || gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at)) + && !gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at) && sym->attr.proc != PROC_ST_FUNCTION && !sym->attr.proc_pointer && !sym->attr.use_assoc @@ -2962,20 +3049,18 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, { /* TODO: Update this error message to allow for procedure pointers once they are implemented. */ - gfc_error_now ("Parameter '%s' to '%s' at %L must be a " + gfc_error_now ("Argument '%s' to '%s' at %L must be a " "procedure", args_sym->name, sym->name, &(args->expr->where)); retval = FAILURE; } - else if (args_sym->attr.is_bind_c != 1) - { - gfc_error_now ("Parameter '%s' to '%s' at %L must be " - "BIND(C)", - args_sym->name, sym->name, - &(args->expr->where)); - retval = FAILURE; - } + else if (args_sym->attr.is_bind_c != 1 + && gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable " + "argument '%s' to '%s' at %L", + args_sym->name, sym->name, + &(args->expr->where)) == FAILURE) + retval = FAILURE; } /* for c_loc/c_funloc, the new symbol is the same as the old one */ @@ -3010,11 +3095,11 @@ resolve_function (gfc_expr *expr) sym = expr->symtree->n.sym; /* If this is a procedure pointer component, it has already been resolved. */ - if (gfc_is_proc_ptr_comp (expr, NULL)) + if (gfc_is_proc_ptr_comp (expr)) return SUCCESS; - + if (sym && sym->attr.intrinsic - && resolve_intrinsic (sym, &expr->where) == FAILURE) + && gfc_resolve_intrinsic (sym, &expr->where) == FAILURE) return FAILURE; if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine)) @@ -3430,7 +3515,11 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym) /* Make sure the actual arguments are in the necessary order (based on the formal args) before resolving. */ - gfc_procedure_use (sym, &c->ext.actual, &(c->loc)); + if (gfc_procedure_use (sym, &c->ext.actual, &(c->loc)) == FAILURE) + { + c->resolved_sym = sym; + return MATCH_ERROR; + } if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) || (sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)) @@ -3441,6 +3530,15 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym) { if (c->ext.actual != NULL && c->ext.actual->next != NULL) { + if (c->ext.actual->expr->ts.type != BT_DERIVED + || c->ext.actual->expr->ts.u.derived->intmod_sym_id + != ISOCBINDING_PTR) + { + gfc_error ("Argument at %L to C_F_POINTER shall have the type" + " C_PTR", &c->ext.actual->expr->where); + m = MATCH_ERROR; + } + /* Make sure we got a third arg if the second arg has non-zero rank. We must also check that the type and rank are correct since we short-circuit this check in @@ -3466,7 +3564,26 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym) } } } - + else /* ISOCBINDING_F_PROCPOINTER. */ + { + if (c->ext.actual + && (c->ext.actual->expr->ts.type != BT_DERIVED + || c->ext.actual->expr->ts.u.derived->intmod_sym_id + != ISOCBINDING_FUNPTR)) + { + gfc_error ("Argument at %L to C_F_FUNPOINTER shall have the type " + "C_FUNPTR", &c->ext.actual->expr->where); + m = MATCH_ERROR; + } + if (c->ext.actual && c->ext.actual->next + && !gfc_expr_attr (c->ext.actual->next->expr).is_bind_c + && gfc_notify_std (GFC_STD_F2008_TS, "Noninteroperable " + "procedure-pointer at %L to C_F_FUNPOINTER", + &c->ext.actual->next->expr->where) + == FAILURE) + m = MATCH_ERROR; + } + if (m != MATCH_ERROR) { /* the 1 means to add the optional arg to formal list */ @@ -3917,6 +4034,28 @@ resolve_operator (gfc_expr *e) e->ts.type = BT_LOGICAL; e->ts.kind = gfc_default_logical_kind; + + if (gfc_option.warn_compare_reals) + { + gfc_intrinsic_op op = e->value.op.op; + + /* Type conversion has made sure that the types of op1 and op2 + agree, so it is only necessary to check the first one. */ + if ((op1->ts.type == BT_REAL || op1->ts.type == BT_COMPLEX) + && (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS + || op == INTRINSIC_NE || op == INTRINSIC_NE_OS)) + { + const char *msg; + + if (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS) + msg = "Equality comparison for %s at %L"; + else + msg = "Inequality comparison for %s at %L"; + + gfc_warning (msg, gfc_typename (&op1->ts), &op1->where); + } + } + break; } @@ -4449,7 +4588,7 @@ gfc_resolve_index_1 (gfc_expr *index, int check_scalar, } if (index->ts.type == BT_REAL) - if (gfc_notify_std (GFC_STD_LEGACY, "Extension: REAL array index at %L", + if (gfc_notify_std (GFC_STD_LEGACY, "REAL array index at %L", &index->where) == FAILURE) return FAILURE; @@ -4964,7 +5103,7 @@ expression_shape (gfc_expr *e) mpz_t array[GFC_MAX_DIMENSIONS]; int i; - if (e->rank == 0 || e->shape != NULL) + if (e->rank <= 0 || e->shape != NULL) return; for (i = 0; i < e->rank; i++) @@ -5067,23 +5206,79 @@ resolve_variable (gfc_expr *e) sym = e->symtree->n.sym; /* TS 29113, 407b. */ - if (e->ts.type == BT_ASSUMED && !assumed_type_expr_allowed) + if (e->ts.type == BT_ASSUMED) { - gfc_error ("Invalid expression with assumed-type variable %s at %L", - sym->name, &e->where); - return FAILURE; + if (!actual_arg) + { + gfc_error ("Assumed-type variable %s at %L may only be used " + "as actual argument", sym->name, &e->where); + return FAILURE; + } + else if (inquiry_argument && !first_actual_arg) + { + /* FIXME: It doesn't work reliably as inquiry_argument is not set + for all inquiry functions in resolve_function; the reason is + that the function-name resolution happens too late in that + function. */ + gfc_error ("Assumed-type variable %s at %L as actual argument to " + "an inquiry function shall be the first argument", + sym->name, &e->where); + return FAILURE; + } + } + + /* TS 29113, C535b. */ + if ((sym->ts.type == BT_CLASS && sym->attr.class_ok + && CLASS_DATA (sym)->as + && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK) + || (sym->ts.type != BT_CLASS && sym->as + && sym->as->type == AS_ASSUMED_RANK)) + { + if (!actual_arg) + { + gfc_error ("Assumed-rank variable %s at %L may only be used as " + "actual argument", sym->name, &e->where); + return FAILURE; + } + else if (inquiry_argument && !first_actual_arg) + { + /* FIXME: It doesn't work reliably as inquiry_argument is not set + for all inquiry functions in resolve_function; the reason is + that the function-name resolution happens too late in that + function. */ + gfc_error ("Assumed-rank variable %s at %L as actual argument " + "to an inquiry function shall be the first argument", + sym->name, &e->where); + return FAILURE; + } } /* TS 29113, 407b. */ if (e->ts.type == BT_ASSUMED && e->ref && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL - && e->ref->next == NULL)) + && e->ref->next == NULL)) + { + gfc_error ("Assumed-type variable %s at %L shall not have a subobject " + "reference", sym->name, &e->ref->u.ar.where); + return FAILURE; + } + + /* TS 29113, C535b. */ + if (((sym->ts.type == BT_CLASS && sym->attr.class_ok + && CLASS_DATA (sym)->as + && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK) + || (sym->ts.type != BT_CLASS && sym->as + && sym->as->type == AS_ASSUMED_RANK)) + && e->ref + && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL + && e->ref->next == NULL)) { - gfc_error ("Assumed-type variable %s with designator at %L", - sym->name, &e->ref->u.ar.where); + gfc_error ("Assumed-rank variable %s at %L shall not have a subobject " + "reference", sym->name, &e->ref->u.ar.where); return FAILURE; } + /* If this is an associate-name, it may be parsed with an array reference in error even though the target is scalar. Fail directly in this case. TODO Understand why class scalar expressions must be excluded. */ @@ -5398,7 +5593,12 @@ gfc_resolve_character_operator (gfc_expr *e) e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); if (!e1 || !e2) - return; + { + gfc_free_expr (e1); + gfc_free_expr (e2); + + return; + } e->ts.u.cl->length = gfc_add (e1, e2); e->ts.u.cl->length->ts.type = BT_INTEGER; @@ -5569,7 +5769,8 @@ update_ppc_arglist (gfc_expr* e) gfc_component *ppc; gfc_typebound_proc* tb; - if (!gfc_is_proc_ptr_comp (e, &ppc)) + ppc = gfc_get_proc_ptr_comp (e); + if (!ppc) return FAILURE; tb = ppc->tb; @@ -5584,7 +5785,7 @@ update_ppc_arglist (gfc_expr* e) return FAILURE; /* F08:R739. */ - if (po->rank > 0) + if (po->rank != 0) { gfc_error ("Passed-object at %L must be scalar", &e->where); return FAILURE; @@ -5622,6 +5823,9 @@ check_typebound_baseobject (gfc_expr* e) gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS); + if (base->ts.type == BT_CLASS && !gfc_expr_attr (base).class_ok) + return FAILURE; + /* F08:C611. */ if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract) { @@ -5632,7 +5836,7 @@ check_typebound_baseobject (gfc_expr* e) /* F08:C1230. If the procedure called is NOPASS, the base object must be scalar. */ - if (e->value.compcall.tbp->nopass && base->rank > 0) + if (e->value.compcall.tbp->nopass && base->rank != 0) { gfc_error ("Base object for NOPASS type-bound procedure call at %L must" " be scalar", &e->where); @@ -6192,10 +6396,9 @@ static gfc_try resolve_ppc_call (gfc_code* c) { gfc_component *comp; - bool b; - b = gfc_is_proc_ptr_comp (c->expr1, &comp); - gcc_assert (b); + comp = gfc_get_proc_ptr_comp (c->expr1); + gcc_assert (comp != NULL); c->resolved_sym = c->expr1->symtree->n.sym; c->expr1->expr_type = EXPR_VARIABLE; @@ -6227,10 +6430,9 @@ static gfc_try resolve_expr_ppc (gfc_expr* e) { gfc_component *comp; - bool b; - b = gfc_is_proc_ptr_comp (e, &comp); - gcc_assert (b); + comp = gfc_get_proc_ptr_comp (e); + gcc_assert (comp != NULL); /* Convert to EXPR_FUNCTION. */ e->expr_type = EXPR_FUNCTION; @@ -6294,15 +6496,22 @@ gfc_try gfc_resolve_expr (gfc_expr *e) { gfc_try t; - bool inquiry_save; + bool inquiry_save, actual_arg_save, first_actual_arg_save; if (e == NULL) return SUCCESS; /* inquiry_argument only applies to variables. */ inquiry_save = inquiry_argument; + actual_arg_save = actual_arg; + first_actual_arg_save = first_actual_arg; + if (e->expr_type != EXPR_VARIABLE) - inquiry_argument = false; + { + inquiry_argument = false; + actual_arg = false; + first_actual_arg = false; + } switch (e->expr_type) { @@ -6392,6 +6601,8 @@ gfc_resolve_expr (gfc_expr *e) fixup_charlen (e); inquiry_argument = inquiry_save; + actual_arg = actual_arg_save; + first_actual_arg = first_actual_arg_save; return t; } @@ -6419,7 +6630,7 @@ gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok, { if (real_ok) return gfc_notify_std (GFC_STD_F95_DEL, - "Deleted feature: %s at %L must be integer", + "%s at %L must be integer", _(name_msgid), &expr->where); else { @@ -7325,8 +7536,8 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) } } - /* Check that an allocate-object appears only once in the statement. - FIXME: Checking derived types is disabled. */ + /* Check that an allocate-object appears only once in the statement. */ + for (p = code->ext.alloc.list; p; p = p->next) { pe = p->expr; @@ -7376,9 +7587,10 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) { gfc_array_ref *par = &(pr->u.ar); gfc_array_ref *qar = &(qr->u.ar); - if (gfc_dep_compare_expr (par->start[0], - qar->start[0]) != 0) - break; + if ((par->start[0] != NULL || qar->start[0] != NULL) + && gfc_dep_compare_expr (par->start[0], + qar->start[0]) != 0) + break; } } else @@ -8586,7 +8798,7 @@ resolve_branch (gfc_st_label *label, gfc_code *code) return; } - if (label->defined != ST_LABEL_TARGET) + if (label->defined != ST_LABEL_TARGET && label->defined != ST_LABEL_DO_TARGET) { gfc_error ("Statement at %L is not a valid branch target statement " "for the branch statement at %L", &label->where, &code->loc); @@ -9156,7 +9368,7 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) rhs = code->expr2; if (rhs->is_boz - && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside " + && gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L outside " "a DATA statement and outside INT/REAL/DBLE/CMPLX", &code->loc) == FAILURE) return false; @@ -10319,22 +10531,22 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) if (allocatable) { - if (dimension) + if (dimension && as->type != AS_ASSUMED_RANK) { - gfc_error ("Allocatable array '%s' at %L must have " - "a deferred shape", sym->name, &sym->declared_at); + gfc_error ("Allocatable array '%s' at %L must have a deferred " + "shape or assumed rank", sym->name, &sym->declared_at); return FAILURE; } - else if (gfc_notify_std (GFC_STD_F2003, "Scalar object '%s' at %L " - "may not be ALLOCATABLE", sym->name, - &sym->declared_at) == FAILURE) + else if (gfc_notify_std (GFC_STD_F2003, "Scalar object " + "'%s' at %L may not be ALLOCATABLE", + sym->name, &sym->declared_at) == FAILURE) return FAILURE; } - if (pointer && dimension) + if (pointer && dimension && as->type != AS_ASSUMED_RANK) { - gfc_error ("Array pointer '%s' at %L must have a deferred shape", - sym->name, &sym->declared_at); + gfc_error ("Array pointer '%s' at %L must have a deferred shape or " + "assumed rank", sym->name, &sym->declared_at); return FAILURE; } } @@ -10421,7 +10633,7 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) && !sym->ns->save_all && !sym->attr.save && !sym->attr.pointer && !sym->attr.allocatable && gfc_has_default_initializer (sym->ts.u.derived) - && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Implied SAVE for " + && gfc_notify_std (GFC_STD_F2008, "Implied SAVE for " "module variable '%s' at %L, needed due to " "the default initialization", sym->name, &sym->declared_at) == FAILURE) @@ -10636,7 +10848,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) && arg->sym->ts.type == BT_DERIVED && !arg->sym->ts.u.derived->attr.use_assoc && !gfc_check_symbol_access (arg->sym->ts.u.derived) - && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' is of a " + && gfc_notify_std (GFC_STD_F2003, "'%s' is of a " "PRIVATE type and cannot be a dummy argument" " of '%s', which is PUBLIC at %L", arg->sym->name, sym->name, &sym->declared_at) @@ -10658,7 +10870,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) && arg->sym->ts.type == BT_DERIVED && !arg->sym->ts.u.derived->attr.use_assoc && !gfc_check_symbol_access (arg->sym->ts.u.derived) - && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure " + && gfc_notify_std (GFC_STD_F2003, "Procedure " "'%s' in PUBLIC interface '%s' at %L " "takes dummy arguments of '%s' which is " "PRIVATE", iface->sym->name, sym->name, @@ -10682,7 +10894,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) && arg->sym->ts.type == BT_DERIVED && !arg->sym->ts.u.derived->attr.use_assoc && !gfc_check_symbol_access (arg->sym->ts.u.derived) - && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Procedure " + && gfc_notify_std (GFC_STD_F2003, "Procedure " "'%s' in PUBLIC interface '%s' at %L " "takes dummy arguments of '%s' which is " "PRIVATE", iface->sym->name, sym->name, @@ -10770,7 +10982,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) if (!sym->attr.contained && gfc_current_form != FORM_FIXED && !sym->ts.deferred) - gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: " + gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function '%s' at %L", sym->name, &sym->declared_at); } @@ -10948,7 +11160,7 @@ gfc_resolve_finalizers (gfc_symbol* derived) } /* Warn if the procedure is non-scalar and not assumed shape. */ - if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0 + if (gfc_option.warn_surprising && arg->as && arg->as->rank != 0 && arg->as->type != AS_ASSUMED_SHAPE) gfc_warning ("Non-scalar FINAL procedure at %L should have assumed" " shape argument", &arg->declared_at); @@ -11390,17 +11602,25 @@ resolve_typebound_procedure (gfc_symtree* stree) /* Default access should already be resolved from the parser. */ gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN); - /* It should be a module procedure or an external procedure with explicit - interface. For DEFERRED bindings, abstract interfaces are ok as well. */ - if ((!proc->attr.subroutine && !proc->attr.function) - || (proc->attr.proc != PROC_MODULE - && proc->attr.if_source != IFSRC_IFBODY) - || (proc->attr.abstract && !stree->n.tb->deferred)) + if (stree->n.tb->deferred) { - gfc_error ("'%s' must be a module procedure or an external procedure with" - " an explicit interface at %L", proc->name, &where); - goto error; + if (check_proc_interface (proc, &where) == FAILURE) + goto error; } + else + { + /* Check for F08:C465. */ + if ((!proc->attr.subroutine && !proc->attr.function) + || (proc->attr.proc != PROC_MODULE + && proc->attr.if_source != IFSRC_IFBODY) + || proc->attr.abstract) + { + gfc_error ("'%s' must be a module procedure or an external procedure with" + " an explicit interface at %L", proc->name, &where); + goto error; + } + } + stree->n.tb->subroutine = proc->attr.subroutine; stree->n.tb->function = proc->attr.function; @@ -11477,7 +11697,7 @@ resolve_typebound_procedure (gfc_symtree* stree) } gcc_assert (me_arg->ts.type == BT_CLASS); - if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank > 0) + if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank != 0) { gfc_error ("Passed-object dummy argument of '%s' at %L must be" " scalar", proc->name, &where); @@ -11753,22 +11973,19 @@ resolve_fl_derived0 (gfc_symbol *sym) if (c->attr.proc_pointer && c->ts.interface) { - if (c->ts.interface->attr.procedure && !sym->attr.vtype) - gfc_error ("Interface '%s', used by procedure pointer component " - "'%s' at %L, is declared in a later PROCEDURE statement", - c->ts.interface->name, c->name, &c->loc); + gfc_symbol *ifc = c->ts.interface; - /* Get the attributes from the interface (now resolved). */ - if (c->ts.interface->attr.if_source - || c->ts.interface->attr.intrinsic) - { - gfc_symbol *ifc = c->ts.interface; + if (!sym->attr.vtype + && check_proc_interface (ifc, &c->loc) == FAILURE) + return FAILURE; + if (ifc->attr.if_source || ifc->attr.intrinsic) + { + /* Resolve interface and copy attributes. */ if (ifc->formal && !ifc->formal_ns) resolve_symbol (ifc); - if (ifc->attr.intrinsic) - resolve_intrinsic (ifc, &ifc->declared_at); + gfc_resolve_intrinsic (ifc, &ifc->declared_at); if (ifc->result) { @@ -11789,13 +12006,14 @@ resolve_fl_derived0 (gfc_symbol *sym) c->ts.interface = ifc; c->attr.function = ifc->attr.function; c->attr.subroutine = ifc->attr.subroutine; - gfc_copy_formal_args_ppc (c, ifc); + gfc_copy_formal_args_ppc (c, ifc, IFSRC_DECL); c->attr.pure = ifc->attr.pure; c->attr.elemental = ifc->attr.elemental; c->attr.recursive = ifc->attr.recursive; c->attr.always_explicit = ifc->attr.always_explicit; c->attr.ext_attr |= ifc->attr.ext_attr; + c->attr.class_ok = ifc->attr.class_ok; /* Replace symbols in array spec. */ if (c->as) { @@ -11805,25 +12023,18 @@ resolve_fl_derived0 (gfc_symbol *sym) gfc_expr_replace_comp (c->as->lower[i], c); gfc_expr_replace_comp (c->as->upper[i], c); } - } + } /* Copy char length. */ if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl) { gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl); gfc_expr_replace_comp (cl->length, c); if (cl->length && !cl->resolved - && gfc_resolve_expr (cl->length) == FAILURE) + && gfc_resolve_expr (cl->length) == FAILURE) return FAILURE; c->ts.u.cl = cl; } } - else if (!sym->attr.vtype && c->ts.interface->name[0] != '\0') - { - gfc_error ("Interface '%s' of procedure pointer component " - "'%s' at %L must be explicit", c->ts.interface->name, - c->name, &c->loc); - return FAILURE; - } } else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN) { @@ -11990,7 +12201,7 @@ resolve_fl_derived0 (gfc_symbol *sym) && !is_sym_host_assoc (c->ts.u.derived, sym->ns) && !c->ts.u.derived->attr.use_assoc && !gfc_check_symbol_access (c->ts.u.derived) - && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: the component '%s' " + && gfc_notify_std (GFC_STD_F2003, "the component '%s' " "is a PRIVATE type and cannot be a component of " "'%s', which is PUBLIC at %L", c->name, sym->name, &sym->declared_at) == FAILURE) @@ -12098,7 +12309,7 @@ resolve_fl_derived (gfc_symbol *sym) if (gen_dt && gen_dt->generic && gen_dt->generic->next && (!gen_dt->generic->sym->attr.use_assoc || gen_dt->generic->sym->module != gen_dt->generic->next->sym->module) - && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Generic name '%s' of " + && gfc_notify_std (GFC_STD_F2003, "Generic name '%s' of " "function '%s' at %L being the same name as derived " "type at %L", sym->name, gen_dt->generic->sym == sym @@ -12156,14 +12367,14 @@ resolve_fl_namelist (gfc_symbol *sym) } if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE - && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array " + && gfc_notify_std (GFC_STD_F2003, "NAMELIST array " "object '%s' with assumed shape in namelist " "'%s' at %L", nl->sym->name, sym->name, &sym->declared_at) == FAILURE) return FAILURE; if (is_non_constant_shape_array (nl->sym) - && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array " + && gfc_notify_std (GFC_STD_F2003, "NAMELIST array " "object '%s' with nonconstant shape in namelist " "'%s' at %L", nl->sym->name, sym->name, &sym->declared_at) == FAILURE) @@ -12172,7 +12383,7 @@ resolve_fl_namelist (gfc_symbol *sym) if (nl->sym->ts.type == BT_CHARACTER && (nl->sym->ts.u.cl->length == NULL || !gfc_is_constant_expr (nl->sym->ts.u.cl->length)) - && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST object " + && gfc_notify_std (GFC_STD_F2003, "NAMELIST object " "'%s' with nonconstant character length in " "namelist '%s' at %L", nl->sym->name, sym->name, &sym->declared_at) == FAILURE) @@ -12192,7 +12403,7 @@ resolve_fl_namelist (gfc_symbol *sym) && (nl->sym->ts.u.derived->attr.alloc_comp || nl->sym->ts.u.derived->attr.pointer_comp)) { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST object " + if (gfc_notify_std (GFC_STD_F2003, "NAMELIST object " "'%s' in namelist '%s' at %L with ALLOCATABLE " "or POINTER components", nl->sym->name, sym->name, &sym->declared_at) == FAILURE) @@ -12371,8 +12582,7 @@ resolve_symbol (gfc_symbol *sym) if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function) gfc_add_function (&sym->attr, sym->name, &sym->declared_at); - if (sym->attr.procedure && sym->ts.interface - && sym->attr.if_source != IFSRC_DECL + if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL && resolve_procedure_interface (sym) == FAILURE) return; @@ -12403,7 +12613,7 @@ resolve_symbol (gfc_symbol *sym) representation. This needs to be done before assigning a default type to avoid spurious warnings. */ if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic - && resolve_intrinsic (sym, &sym->declared_at) == FAILURE) + && gfc_resolve_intrinsic (sym, &sym->declared_at) == FAILURE) return; /* Resolve associate names. */ @@ -12491,6 +12701,20 @@ resolve_symbol (gfc_symbol *sym) &sym->declared_at); return; } + /* TS 29113, C535a. */ + if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy) + { + gfc_error ("Assumed-rank array at %L must be a dummy argument", + &sym->declared_at); + return; + } + if (as->type == AS_ASSUMED_RANK + && (sym->attr.codimension || sym->attr.value)) + { + gfc_error ("Assumed-rank array at %L may not have the VALUE or " + "CODIMENSION attribute", &sym->declared_at); + return; + } } /* Make sure symbols with known intent or optional are really dummy @@ -12563,6 +12787,13 @@ resolve_symbol (gfc_symbol *sym) sym->name, &sym->declared_at); return; } + if (sym->attr.intent == INTENT_OUT) + { + gfc_error ("Assumed-type variable %s at %L may not have the " + "INTENT(OUT) attribute", + sym->name, &sym->declared_at); + return; + } if (sym->attr.dimension && sym->as->type == AS_EXPLICIT) { gfc_error ("Assumed-type variable %s at %L shall not be an " @@ -12670,7 +12901,7 @@ resolve_symbol (gfc_symbol *sym) && !sym->ts.u.derived->attr.use_assoc && gfc_check_symbol_access (sym) && !gfc_check_symbol_access (sym->ts.u.derived) - && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC %s '%s' at %L " + && gfc_notify_std (GFC_STD_F2003, "PUBLIC %s '%s' at %L " "of PRIVATE derived type '%s'", (sym->attr.flavor == FL_PARAMETER) ? "parameter" : "variable", sym->name, &sym->declared_at, @@ -12860,7 +13091,8 @@ resolve_symbol (gfc_symbol *sym) if (formal) { sym->formal_ns = formal->sym->ns; - sym->formal_ns->refs++; + if (sym->ns != formal->sym->ns) + sym->formal_ns->refs++; } } @@ -13836,7 +14068,7 @@ resolve_fntype (gfc_namespace *ns) && !gfc_check_symbol_access (sym->ts.u.derived) && gfc_check_symbol_access (sym)) { - gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PUBLIC function '%s' at " + gfc_notify_std (GFC_STD_F2003, "PUBLIC function '%s' at " "%L of PRIVATE type '%s'", sym->name, &sym->declared_at, sym->ts.u.derived->name); } diff --git a/gcc/fortran/scanner.c b/gcc/fortran/scanner.c index 120d55022b8..e0556a9760a 100644 --- a/gcc/fortran/scanner.c +++ b/gcc/fortran/scanner.c @@ -43,6 +43,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" +#include "coretypes.h" #include "gfortran.h" #include "toplev.h" /* For set_src_pwd. */ #include "debug.h" @@ -306,16 +307,36 @@ gfc_scanner_done_1 (void) static void add_path_to_list (gfc_directorylist **list, const char *path, - bool use_for_modules, bool head) + bool use_for_modules, bool head, bool warn) { gfc_directorylist *dir; const char *p; - + struct stat st; + p = path; while (*p == ' ' || *p == '\t') /* someone might do "-I include" */ if (*p++ == '\0') return; + if (stat (p, &st)) + { + if (errno != ENOENT) + gfc_warning_now ("Include directory \"%s\": %s", path, + xstrerror(errno)); + else + { + /* FIXME: Also support -Wmissing-include-dirs. */ + if (warn) + gfc_warning_now ("Nonexistent include directory \"%s\"", path); + } + return; + } + else if (!S_ISDIR (st.st_mode)) + { + gfc_warning_now ("\"%s\" is not a directory", path); + return; + } + if (head || *list == NULL) { dir = XCNEW (gfc_directorylist); @@ -345,7 +366,7 @@ add_path_to_list (gfc_directorylist **list, const char *path, void gfc_add_include_path (const char *path, bool use_for_modules, bool file_dir) { - add_path_to_list (&include_dirs, path, use_for_modules, file_dir); + add_path_to_list (&include_dirs, path, use_for_modules, file_dir, true); /* For '#include "..."' these directories are automatically searched. */ if (!file_dir) @@ -356,7 +377,7 @@ gfc_add_include_path (const char *path, bool use_for_modules, bool file_dir) void gfc_add_intrinsic_modules_path (const char *path) { - add_path_to_list (&intrinsic_modules_dirs, path, true, false); + add_path_to_list (&intrinsic_modules_dirs, path, true, false, false); } diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 1578db19b94..e4ccddf967c 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -21,6 +21,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" +#include "coretypes.h" #include "flags.h" #include "gfortran.h" #include "arith.h" @@ -418,7 +419,7 @@ typedef gfc_expr* (*transformational_op)(gfc_expr*, gfc_expr*); /* Wrapper function, implements 'op1 += 1'. Only called if MASK of COUNT intrinsic is .TRUE.. - Interface and implimentation mimics arith functions as + Interface and implementation mimics arith functions as gfc_add, gfc_multiply, etc. */ static gfc_expr* gfc_count (gfc_expr *op1, gfc_expr *op2) @@ -2934,7 +2935,6 @@ gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask) } - gfc_expr * gfc_simplify_is_iostat_end (gfc_expr *x) { @@ -3380,7 +3380,8 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) done: - if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)) + if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE + || as->type == AS_ASSUMED_RANK)) return NULL; if (dim == NULL) @@ -3442,13 +3443,16 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) d = mpz_get_si (dim->value.integer); - if (d < 1 || d > array->rank + if ((d < 1 || d > array->rank) || (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper)) { gfc_error ("DIM argument at %L is out of bounds", &dim->where); return &gfc_bad_expr; } + if (as && as->type == AS_ASSUMED_RANK) + return NULL; + return simplify_bound_dim (array, kind, d, upper, as, ref, false); } } @@ -4779,6 +4783,10 @@ gfc_simplify_range (gfc_expr *e) gfc_expr * gfc_simplify_rank (gfc_expr *e) { + /* Assumed rank. */ + if (e->rank == -1) + return NULL; + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank); } @@ -5462,6 +5470,9 @@ gfc_simplify_shape (gfc_expr *source, gfc_expr *kind) gfc_try t; int k = get_kind (BT_INTEGER, kind, "SHAPE", gfc_default_integer_kind); + if (source->rank == -1) + return NULL; + result = gfc_get_array_expr (BT_INTEGER, k, &source->where); if (source->rank == 0) diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c index 932c9428af8..ed379fc44af 100644 --- a/gcc/fortran/st.c +++ b/gcc/fortran/st.c @@ -26,6 +26,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" +#include "coretypes.h" #include "gfortran.h" gfc_code new_st; diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 6ca4ca33014..5e97c4086d1 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -23,6 +23,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" +#include "coretypes.h" #include "flags.h" #include "gfortran.h" #include "parse.h" @@ -480,7 +481,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (external, subroutine); if (attr->proc_pointer && gfc_notify_std (GFC_STD_F2003, - "Fortran 2003: Procedure pointer at %C") == FAILURE) + "Procedure pointer at %C") == FAILURE) return FAILURE; conf (allocatable, pointer); @@ -771,13 +772,13 @@ conflict: conflict_std: if (name == NULL) { - return gfc_notify_std (standard, "Fortran 2003: %s attribute " + return gfc_notify_std (standard, "%s attribute " "with %s attribute at %L", a1, a2, where); } else { - return gfc_notify_std (standard, "Fortran 2003: %s attribute " + return gfc_notify_std (standard, "%s attribute " "with %s attribute in '%s' at %L", a1, a2, name, where); } @@ -1596,7 +1597,7 @@ gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where, if (where == NULL) where = &gfc_current_locus; - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BIND(C) at %L", where) + if (gfc_notify_std (GFC_STD_F2003, "BIND(C) at %L", where) == FAILURE) return FAILURE; @@ -1617,7 +1618,7 @@ gfc_add_extension (symbol_attribute *attr, locus *where) else attr->extension = 1; - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: EXTENDS at %L", where) + if (gfc_notify_std (GFC_STD_F2003, "EXTENDS at %L", where) == FAILURE) return FAILURE; @@ -2203,7 +2204,8 @@ gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus) switch (type) { case ST_LABEL_FORMAT: - if (lp->referenced == ST_LABEL_TARGET) + if (lp->referenced == ST_LABEL_TARGET + || lp->referenced == ST_LABEL_DO_TARGET) gfc_error ("Label %d at %C already referenced as branch target", labelno); else @@ -2212,12 +2214,18 @@ gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus) break; case ST_LABEL_TARGET: + case ST_LABEL_DO_TARGET: if (lp->referenced == ST_LABEL_FORMAT) gfc_error ("Label %d at %C already referenced as a format label", labelno); else - lp->defined = ST_LABEL_TARGET; + lp->defined = type; + if (lp->referenced == ST_LABEL_DO_TARGET && type != ST_LABEL_DO_TARGET + && gfc_notify_std (GFC_STD_F95_OBS, "DO termination statement " + "which is not END DO or CONTINUE with label " + "%d at %C", labelno) == FAILURE) + return; break; default: @@ -2253,14 +2261,16 @@ gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type) lp->where = gfc_current_locus; } - if (label_type == ST_LABEL_FORMAT && type == ST_LABEL_TARGET) + if (label_type == ST_LABEL_FORMAT + && (type == ST_LABEL_TARGET || type == ST_LABEL_DO_TARGET)) { gfc_error ("Label %d at %C previously used as a FORMAT label", labelno); rc = FAILURE; goto done; } - if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_BAD_TARGET) + if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_DO_TARGET + || label_type == ST_LABEL_BAD_TARGET) && type == ST_LABEL_FORMAT) { gfc_error ("Label %d at %C previously used as branch target", labelno); @@ -2268,7 +2278,13 @@ gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type) goto done; } - lp->referenced = type; + if (lp->referenced == ST_LABEL_DO_TARGET && type == ST_LABEL_DO_TARGET + && gfc_notify_std (GFC_STD_F95_OBS, "Shared DO termination label %d " + "at %C", labelno) == FAILURE) + return FAILURE; + + if (lp->referenced != ST_LABEL_DO_TARGET) + lp->referenced = type; rc = SUCCESS; done: @@ -2495,7 +2511,8 @@ gfc_free_symbol (gfc_symbol *sym) gfc_free_namelist (sym->namelist); - gfc_free_namespace (sym->formal_ns); + if (sym->ns != sym->formal_ns) + gfc_free_namespace (sym->formal_ns); if (!sym->attr.generic_copy) gfc_free_interface (sym->generic); @@ -2504,6 +2521,13 @@ gfc_free_symbol (gfc_symbol *sym) gfc_free_namespace (sym->f2k_derived); + if (sym->common_block && sym->common_block->name[0] != '\0') + { + sym->common_block->refs--; + if (sym->common_block->refs == 0) + free (sym->common_block); + } + free (sym); } @@ -2516,7 +2540,8 @@ gfc_release_symbol (gfc_symbol *sym) if (sym == NULL) return; - if (sym->formal_ns != NULL && sym->refs == 2) + if (sym->formal_ns != NULL && sym->refs == 2 && sym->formal_ns != sym->ns + && (!sym->attr.entry || !sym->module)) { /* As formal_ns contains a reference to sym, delete formal_ns just before the deletion of sym. */ @@ -4048,8 +4073,7 @@ gen_shape_param (gfc_formal_arglist **head, reference to the list of formal arguments). */ static void -add_proc_interface (gfc_symbol *sym, ifsrc source, - gfc_formal_arglist *formal) +add_proc_interface (gfc_symbol *sym, ifsrc source, gfc_formal_arglist *formal) { sym->formal = formal; @@ -4065,7 +4089,7 @@ add_proc_interface (gfc_symbol *sym, ifsrc source, args based on the args of a given named interface. */ void -gfc_copy_formal_args (gfc_symbol *dest, gfc_symbol *src) +gfc_copy_formal_args (gfc_symbol *dest, gfc_symbol *src, ifsrc if_src) { gfc_formal_arglist *head = NULL; gfc_formal_arglist *tail = NULL; @@ -4079,6 +4103,7 @@ gfc_copy_formal_args (gfc_symbol *dest, gfc_symbol *src) of the formal args). */ gfc_current_ns = gfc_get_namespace (parent_ns, 0); gfc_current_ns->proc_name = dest; + dest->formal_ns = gfc_current_ns; for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next) { @@ -4089,7 +4114,8 @@ gfc_copy_formal_args (gfc_symbol *dest, gfc_symbol *src) formal_arg->sym->attr = curr_arg->sym->attr; formal_arg->sym->ts = curr_arg->sym->ts; formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as); - gfc_copy_formal_args (formal_arg->sym, curr_arg->sym); + gfc_copy_formal_args (formal_arg->sym, curr_arg->sym, + curr_arg->sym->attr.if_source); /* If this isn't the first arg, set up the next ptr. For the last arg built, the formal_arg->next will never get set to @@ -4109,7 +4135,7 @@ gfc_copy_formal_args (gfc_symbol *dest, gfc_symbol *src) } /* Add the interface to the symbol. */ - add_proc_interface (dest, IFSRC_DECL, head); + add_proc_interface (dest, if_src, head); /* Store the formal namespace information. */ if (dest->formal != NULL) @@ -4182,7 +4208,7 @@ gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src) void -gfc_copy_formal_args_ppc (gfc_component *dest, gfc_symbol *src) +gfc_copy_formal_args_ppc (gfc_component *dest, gfc_symbol *src, ifsrc if_src) { gfc_formal_arglist *head = NULL; gfc_formal_arglist *tail = NULL; @@ -4206,7 +4232,8 @@ gfc_copy_formal_args_ppc (gfc_component *dest, gfc_symbol *src) formal_arg->sym->attr = curr_arg->sym->attr; formal_arg->sym->ts = curr_arg->sym->ts; formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as); - gfc_copy_formal_args (formal_arg->sym, curr_arg->sym); + gfc_copy_formal_args (formal_arg->sym, curr_arg->sym, + curr_arg->sym->attr.if_source); /* If this isn't the first arg, set up the next ptr. For the last arg built, the formal_arg->next will never get set to @@ -4228,7 +4255,7 @@ gfc_copy_formal_args_ppc (gfc_component *dest, gfc_symbol *src) /* Add the interface to the symbol. */ gfc_free_formal_arglist (dest->formal); dest->formal = head; - dest->attr.if_source = IFSRC_DECL; + dest->attr.if_source = if_src; /* Store the formal namespace information. */ if (dest->formal != NULL) @@ -4744,7 +4771,7 @@ gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns, } if (gfc_notify_std (GFC_STD_GNU, - "Extension: Symbol '%s' is used before" + "Symbol '%s' is used before" " it is typed at %L", sym->name, &where) == FAILURE) return FAILURE; } diff --git a/gcc/fortran/target-memory.c b/gcc/fortran/target-memory.c index 63878959b47..637811e0965 100644 --- a/gcc/fortran/target-memory.c +++ b/gcc/fortran/target-memory.c @@ -21,6 +21,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" +#include "coretypes.h" #include "flags.h" #include "machmode.h" #include "tree.h" diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index f135af1ef30..c350c3b5e3a 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -81,7 +81,7 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include "coretypes.h" #include "tree.h" -#include "gimple.h" +#include "gimple.h" /* For create_tmp_var_name. */ #include "diagnostic-core.h" /* For internal_error/fatal_error. */ #include "flags.h" #include "gfortran.h" @@ -247,12 +247,25 @@ gfc_conv_descriptor_dtype (tree desc) desc, field, NULL_TREE); } -static tree -gfc_conv_descriptor_dimension (tree desc, tree dim) + +tree +gfc_conv_descriptor_rank (tree desc) { - tree field; - tree type; tree tmp; + tree dtype; + + dtype = gfc_conv_descriptor_dtype (desc); + tmp = build_int_cst (TREE_TYPE (dtype), GFC_DTYPE_RANK_MASK); + tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (dtype), + dtype, tmp); + return fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp); +} + + +tree +gfc_get_descriptor_dimension (tree desc) +{ + tree type, field; type = TREE_TYPE (desc); gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); @@ -262,10 +275,19 @@ gfc_conv_descriptor_dimension (tree desc, tree dim) && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE); - tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), - desc, field, NULL_TREE); - tmp = gfc_build_array_ref (tmp, dim, NULL); - return tmp; + return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), + desc, field, NULL_TREE); +} + + +static tree +gfc_conv_descriptor_dimension (tree desc, tree dim) +{ + tree tmp; + + tmp = gfc_get_descriptor_dimension (desc); + + return gfc_build_array_ref (tmp, dim, NULL); } @@ -311,6 +333,7 @@ gfc_conv_descriptor_stride_get (tree desc, tree dim) if (integer_zerop (dim) && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT + ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)) return gfc_index_one_node; @@ -487,40 +510,36 @@ gfc_free_ss_chain (gfc_ss * ss) static void free_ss_info (gfc_ss_info *ss_info) { + int n; + ss_info->refcount--; if (ss_info->refcount > 0) return; gcc_assert (ss_info->refcount == 0); - free (ss_info); -} - - -/* Free a SS. */ - -void -gfc_free_ss (gfc_ss * ss) -{ - gfc_ss_info *ss_info; - int n; - - ss_info = ss->info; switch (ss_info->type) { case GFC_SS_SECTION: - for (n = 0; n < ss->dimen; n++) - { - if (ss_info->data.array.subscript[ss->dim[n]]) - gfc_free_ss_chain (ss_info->data.array.subscript[ss->dim[n]]); - } + for (n = 0; n < GFC_MAX_DIMENSIONS; n++) + if (ss_info->data.array.subscript[n]) + gfc_free_ss_chain (ss_info->data.array.subscript[n]); break; default: break; } - free_ss_info (ss_info); + free (ss_info); +} + + +/* Free a SS. */ + +void +gfc_free_ss (gfc_ss * ss) +{ + free_ss_info (ss->info); free (ss); } @@ -1511,6 +1530,9 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, bool dynamic) { tree tmp; + tree start = NULL_TREE; + tree end = NULL_TREE; + tree step = NULL_TREE; stmtblock_t body; gfc_se se; mpz_t size; @@ -1533,8 +1555,30 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, expression in an interface mapping. */ if (c->iterator) { - gfc_symbol *sym = c->iterator->var->symtree->n.sym; - tree type = gfc_typenode_for_spec (&sym->ts); + gfc_symbol *sym; + tree type; + + /* Evaluate loop bounds before substituting the loop variable + in case they depend on it. Such a case is invalid, but it is + not more expensive to do the right thing here. + See PR 44354. */ + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, c->iterator->start); + gfc_add_block_to_block (pblock, &se.pre); + start = gfc_evaluate_now (se.expr, pblock); + + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, c->iterator->end); + gfc_add_block_to_block (pblock, &se.pre); + end = gfc_evaluate_now (se.expr, pblock); + + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, c->iterator->step); + gfc_add_block_to_block (pblock, &se.pre); + step = gfc_evaluate_now (se.expr, pblock); + + sym = c->iterator->var->symtree->n.sym; + type = gfc_typenode_for_spec (&sym->ts); shadow_loopvar = gfc_create_var (type, "shadow_loopvar"); gfc_shadow_sym (sym, shadow_loopvar, &saved_loopvar); @@ -1669,8 +1713,6 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, /* Build the implied do-loop. */ stmtblock_t implied_do_block; tree cond; - tree end; - tree step; tree exit_label; tree loopbody; tree tmp2; @@ -1682,20 +1724,7 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, gfc_start_block(&implied_do_block); /* Initialize the loop. */ - gfc_init_se (&se, NULL); - gfc_conv_expr_val (&se, c->iterator->start); - gfc_add_block_to_block (&implied_do_block, &se.pre); - gfc_add_modify (&implied_do_block, shadow_loopvar, se.expr); - - gfc_init_se (&se, NULL); - gfc_conv_expr_val (&se, c->iterator->end); - gfc_add_block_to_block (&implied_do_block, &se.pre); - end = gfc_evaluate_now (se.expr, &implied_do_block); - - gfc_init_se (&se, NULL); - gfc_conv_expr_val (&se, c->iterator->step); - gfc_add_block_to_block (&implied_do_block, &se.pre); - step = gfc_evaluate_now (se.expr, &implied_do_block); + gfc_add_modify (&implied_do_block, shadow_loopvar, start); /* If this array expands dynamically, and the number of iterations is not constant, we won't have allocated space for the static @@ -1772,7 +1801,6 @@ static void get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len) { gfc_se se; - gfc_ss *ss; /* Don't bother if we already know the length is a constant. */ if (*len && INTEGER_CST_P (*len)) @@ -1788,15 +1816,14 @@ get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len) else { /* Otherwise, be brutal even if inefficient. */ - ss = gfc_walk_expr (e); gfc_init_se (&se, NULL); /* No function call, in case of side effects. */ se.no_function_call = 1; - if (ss == gfc_ss_terminator) + if (e->rank == 0) gfc_conv_expr (&se, e); else - gfc_conv_expr_descriptor (&se, e, ss); + gfc_conv_expr_descriptor (&se, e); /* Fix the value. */ *len = gfc_evaluate_now (se.string_length, &se.pre); @@ -2398,7 +2425,6 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, gfc_ss_info *ss_info; gfc_array_info *info; gfc_expr *expr; - bool skip_nested = false; int n; /* Don't evaluate the arguments for realloc_lhs_loop_for_fcn_call; otherwise, @@ -2487,12 +2513,7 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, /* Add the expressions for scalar and vector subscripts. */ for (n = 0; n < GFC_MAX_DIMENSIONS; n++) if (info->subscript[n]) - { - gfc_add_loop_ss_code (loop, info->subscript[n], true, where); - /* The recursive call will have taken care of the nested loops. - No need to do it twice. */ - skip_nested = true; - } + gfc_add_loop_ss_code (loop, info->subscript[n], true, where); set_vector_loop_bounds (ss); break; @@ -2500,7 +2521,7 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, case GFC_SS_VECTOR: /* Get the vector's descriptor and store it in SS. */ gfc_init_se (&se, NULL); - gfc_conv_expr_descriptor (&se, expr, gfc_walk_expr (expr)); + gfc_conv_expr_descriptor (&se, expr); gfc_add_block_to_block (&outer_loop->pre, &se.pre); gfc_add_block_to_block (&outer_loop->post, &se.post); info->descriptor = se.expr; @@ -2548,7 +2569,7 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, } } - if (!skip_nested) + if (!subscript) for (nested_loop = loop->nested; nested_loop; nested_loop = nested_loop->next) gfc_add_loop_ss_code (nested_loop, nested_loop->ss, subscript, where); @@ -3781,6 +3802,40 @@ done: /* Fall through to supply start and stride. */ case GFC_ISYM_LBOUND: case GFC_ISYM_UBOUND: + { + gfc_expr *arg; + + /* This is the variant without DIM=... */ + gcc_assert (expr->value.function.actual->next->expr == NULL); + + arg = expr->value.function.actual->expr; + if (arg->rank == -1) + { + gfc_se se; + tree rank, tmp; + + /* The rank (hence the return value's shape) is unknown, + we have to retrieve it. */ + gfc_init_se (&se, NULL); + se.descriptor_only = 1; + gfc_conv_expr (&se, arg); + /* This is a bare variable, so there is no preliminary + or cleanup code. */ + gcc_assert (se.pre.head == NULL_TREE + && se.post.head == NULL_TREE); + rank = gfc_conv_descriptor_rank (se.expr); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + fold_convert (gfc_array_index_type, + rank), + gfc_index_one_node); + info->end[0] = gfc_evaluate_now (tmp, &loop->pre); + info->start[0] = gfc_index_zero_node; + info->stride[0] = gfc_index_one_node; + continue; + } + /* Otherwise fall through GFC_SS_FUNCTION. */ + } case GFC_ISYM_LCOBOUND: case GFC_ISYM_UCOBOUND: case GFC_ISYM_THIS_IMAGE: @@ -4417,22 +4472,11 @@ set_loop_bounds (gfc_loopinfo *loop) continue; } - /* TODO: Pick the best bound if we have a choice between a - function and something else. */ - if (ss_type == GFC_SS_FUNCTION) - { - loopspec[n] = ss; - continue; - } - /* Avoid using an allocatable lhs in an assignment, since there might be a reallocation coming. */ if (loopspec[n] && ss->is_alloc_lhs) continue; - if (ss_type != GFC_SS_SECTION) - continue; - if (!loopspec[n]) loopspec[n] = ss; /* Criteria for choosing a loop specifier (most important first): @@ -4442,8 +4486,7 @@ set_loop_bounds (gfc_loopinfo *loop) known lower bound known upper bound */ - else if ((loopspec[n]->info->type == GFC_SS_CONSTRUCTOR && dynamic[n]) - || n >= loop->dimen) + else if (loopspec[n]->info->type == GFC_SS_CONSTRUCTOR && dynamic[n]) loopspec[n] = ss; else if (integer_onep (info->stride[dim]) && !integer_onep (specinfo->stride[spec_dim])) @@ -4452,7 +4495,11 @@ set_loop_bounds (gfc_loopinfo *loop) && !INTEGER_CST_P (specinfo->stride[spec_dim])) loopspec[n] = ss; else if (INTEGER_CST_P (info->start[dim]) - && !INTEGER_CST_P (specinfo->start[spec_dim])) + && !INTEGER_CST_P (specinfo->start[spec_dim]) + && integer_onep (info->stride[dim]) + == integer_onep (specinfo->stride[spec_dim]) + && INTEGER_CST_P (info->stride[dim]) + == INTEGER_CST_P (specinfo->stride[spec_dim])) loopspec[n] = ss; /* We don't work out the upper bound. else if (INTEGER_CST_P (info->finish[n]) @@ -4507,6 +4554,20 @@ set_loop_bounds (gfc_loopinfo *loop) gcc_assert (loop->to[n] == NULL_TREE); break; + case GFC_SS_INTRINSIC: + { + gfc_expr *expr = loopspec[n]->info->expr; + + /* The {l,u}bound of an assumed rank. */ + gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND + || expr->value.function.isym->id == GFC_ISYM_UBOUND) + && expr->value.function.actual->next->expr == NULL + && expr->value.function.actual->expr->rank == -1); + + loop->to[n] = info->end[dim]; + break; + } + default: gcc_unreachable (); } @@ -6261,6 +6322,44 @@ transposed_dims (gfc_ss *ss) return false; } + +/* Convert the last ref of a scalar coarray from an AR_ELEMENT to an + AR_FULL, suitable for the scalarizer. */ + +static gfc_ss * +walk_coarray (gfc_expr *e) +{ + gfc_ss *ss; + + gcc_assert (gfc_get_corank (e) > 0); + + ss = gfc_walk_expr (e); + + /* Fix scalar coarray. */ + if (ss == gfc_ss_terminator) + { + gfc_ref *ref; + + ref = e->ref; + while (ref) + { + if (ref->type == REF_ARRAY + && ref->u.ar.codimen > 0) + break; + + ref = ref->next; + } + + gcc_assert (ref != NULL); + if (ref->u.ar.type == AR_ELEMENT) + ref->u.ar.type = AR_SECTION; + ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref)); + } + + return ss; +} + + /* Convert an array for passing as an actual argument. Expressions and vector subscripts are evaluated and stored in a temporary, which is then passed. For whole arrays the descriptor is passed. For array sections @@ -6291,8 +6390,9 @@ transposed_dims (gfc_ss *ss) function call. */ void -gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) +gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) { + gfc_ss *ss; gfc_ss_type ss_type; gfc_ss_info *ss_info; gfc_loopinfo loop; @@ -6308,6 +6408,11 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) bool subref_array_target = false; gfc_expr *arg, *ss_expr; + if (se->want_coarray) + ss = walk_coarray (expr); + else + ss = gfc_walk_expr (expr); + gcc_assert (ss != NULL); gcc_assert (ss != gfc_ss_terminator); @@ -6315,6 +6420,16 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) ss_type = ss_info->type; ss_expr = ss_info->expr; + /* Special case: TRANSPOSE which needs no temporary. */ + while (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym + && NULL != (arg = gfc_get_noncopying_intrinsic_argument (expr))) + { + /* This is a call to transpose which has already been handled by the + scalarizer, so that we just need to get its argument's descriptor. */ + gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE); + expr = expr->value.function.actual->expr; + } + /* Special case things we know we can pass easily. */ switch (expr->expr_type) { @@ -6344,7 +6459,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) /* Create a new descriptor if the array doesn't have one. */ full = 0; } - else if (info->ref->u.ar.type == AR_FULL) + else if (info->ref->u.ar.type == AR_FULL || se->descriptor_only) full = 1; else if (se->direct_byref) full = 0; @@ -6376,24 +6491,12 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) if (expr->ts.type == BT_CHARACTER) se->string_length = gfc_get_expr_charlen (expr); + gfc_free_ss_chain (ss); return; } break; case EXPR_FUNCTION: - - /* We don't need to copy data in some cases. */ - arg = gfc_get_noncopying_intrinsic_argument (expr); - if (arg) - { - /* This is a call to transpose... */ - gcc_assert (expr->value.function.isym->id == GFC_ISYM_TRANSPOSE); - /* ... which has already been handled by the scalarizer, so - that we just need to get its argument's descriptor. */ - gfc_conv_expr_descriptor (se, expr->value.function.actual->expr, ss); - return; - } - /* A transformational function return value will be a temporary array descriptor. We still need to go through the scalarizer to create the descriptor. Elemental functions are handled as @@ -6410,6 +6513,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) gcc_assert (se->ss == ss); se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); gfc_conv_expr (se, expr); + gfc_free_ss_chain (ss); return; } @@ -6829,7 +6933,7 @@ array_parameter_size (tree desc, gfc_expr *expr, tree *size) /* TODO: Optimize passing g77 arrays. */ void -gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, +gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77, const gfc_symbol *fsym, const char *proc_name, tree *size) { @@ -6900,15 +7004,16 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) { - gfc_conv_expr_descriptor (se, expr, ss); + gfc_conv_expr_descriptor (se, expr); se->expr = gfc_conv_array_data (se->expr); return; } if (!sym->attr.pointer - && sym->as - && sym->as->type != AS_ASSUMED_SHAPE - && !sym->attr.allocatable) + && sym->as + && sym->as->type != AS_ASSUMED_SHAPE + && sym->as->type != AS_ASSUMED_RANK + && !sym->attr.allocatable) { /* Some variables are declared directly, others are declared as pointers and allocated on the heap. */ @@ -6925,7 +7030,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, { if (sym->attr.dummy || sym->attr.result) { - gfc_conv_expr_descriptor (se, expr, ss); + gfc_conv_expr_descriptor (se, expr); tmp = se->expr; } if (size) @@ -6944,10 +7049,12 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, no_pack = ((sym && sym->as && !sym->attr.pointer && sym->as->type != AS_DEFERRED + && sym->as->type != AS_ASSUMED_RANK && sym->as->type != AS_ASSUMED_SHAPE) || (ref && ref->u.ar.as && ref->u.ar.as->type != AS_DEFERRED + && ref->u.ar.as->type != AS_ASSUMED_RANK && ref->u.ar.as->type != AS_ASSUMED_SHAPE) || gfc_is_simply_contiguous (expr, false)); @@ -6967,7 +7074,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp) { - gfc_conv_expr_descriptor (se, expr, ss); + gfc_conv_expr_descriptor (se, expr); if (expr->ts.type == BT_CHARACTER) se->string_length = expr->ts.u.cl->backend_decl; if (size) @@ -6979,7 +7086,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, if (this_array_result) { /* Result of the enclosing function. */ - gfc_conv_expr_descriptor (se, expr, ss); + gfc_conv_expr_descriptor (se, expr); if (size) array_parameter_size (se->expr, expr, size); se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); @@ -6995,7 +7102,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77, { /* Every other type of array. */ se->want_pointer = 1; - gfc_conv_expr_descriptor (se, expr, ss); + gfc_conv_expr_descriptor (se, expr); if (size) array_parameter_size (build_fold_indirect_ref_loc (input_location, se->expr), @@ -8596,7 +8703,7 @@ gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr) sym = expr->symtree->n.sym; /* A function that returns arrays. */ - gfc_is_proc_ptr_comp (expr, &comp); + comp = gfc_get_proc_ptr_comp (expr); if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension) || (comp && comp->attr.dimension)) return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION); diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 9bafb9478d5..de032020261 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -131,9 +131,9 @@ void gfc_conv_tmp_array_ref (gfc_se * se); void gfc_conv_tmp_ref (gfc_se *); /* Evaluate an array expression. */ -void gfc_conv_expr_descriptor (gfc_se *, gfc_expr *, gfc_ss *); +void gfc_conv_expr_descriptor (gfc_se *, gfc_expr *); /* Convert an array for passing as an actual function parameter. */ -void gfc_conv_array_parameter (gfc_se *, gfc_expr *, gfc_ss *, bool, +void gfc_conv_array_parameter (gfc_se *, gfc_expr *, bool, const gfc_symbol *, const char *, tree *); /* Evaluate and transpose a matrix expression. */ void gfc_conv_array_transpose (gfc_se *, gfc_expr *); @@ -154,6 +154,8 @@ tree gfc_conv_descriptor_data_get (tree); tree gfc_conv_descriptor_data_addr (tree); tree gfc_conv_descriptor_offset_get (tree); tree gfc_conv_descriptor_dtype (tree); +tree gfc_conv_descriptor_rank (tree); +tree gfc_get_descriptor_dimension (tree); tree gfc_conv_descriptor_stride_get (tree, tree); tree gfc_conv_descriptor_lbound_get (tree, tree); tree gfc_conv_descriptor_ubound_get (tree, tree); diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 75a21604cff..35a859b6d6c 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -562,6 +562,12 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym) /* TODO: Don't set sym->module for result or dummy variables. */ gcc_assert (current_function_decl == NULL_TREE || sym->result == sym); /* This is the declaration of a module variable. */ + if (sym->attr.access == ACCESS_UNKNOWN + && (sym->ns->default_access == ACCESS_PRIVATE + || (sym->ns->default_access == ACCESS_UNKNOWN + && gfc_option.flag_module_private))) + sym->attr.access = ACCESS_PRIVATE; + if (sym->attr.access != ACCESS_PRIVATE || sym->attr.public_used) TREE_PUBLIC (decl) = 1; TREE_STATIC (decl) = 1; @@ -933,7 +939,8 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy) int n; bool known_size; - if (sym->attr.pointer || sym->attr.allocatable) + if (sym->attr.pointer || sym->attr.allocatable + || (sym->as && sym->as->type == AS_ASSUMED_RANK)) return dummy; /* Add to list of variables if not a fake result variable. */ @@ -1838,6 +1845,12 @@ build_function_decl (gfc_symbol * sym, bool global) the opposite of declaring a function as static in C). */ DECL_EXTERNAL (fndecl) = 0; + if (sym->attr.access == ACCESS_UNKNOWN && sym->module + && (sym->ns->default_access == ACCESS_PRIVATE + || (sym->ns->default_access == ACCESS_UNKNOWN + && gfc_option.flag_module_private))) + sym->attr.access = ACCESS_PRIVATE; + if (!current_function_decl && !sym->attr.entry_master && !sym->attr.is_main_program && (sym->attr.access != ACCESS_PRIVATE || sym->binding_label @@ -2252,7 +2265,7 @@ trans_function_start (gfc_symbol * sym) /* Create RTL for function definition. */ make_decl_rtl (fndecl); - init_function_start (fndecl); + allocate_struct_function (fndecl, false); /* function.c requires a push at the start of the function. */ pushlevel (); @@ -3669,6 +3682,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) gfc_trans_dummy_array_bias (sym, sym->backend_decl, block); break; + case AS_ASSUMED_RANK: case AS_DEFERRED: seen_trans_deferred_array = true; gfc_trans_deferred_array (sym, block); @@ -4394,7 +4408,7 @@ generate_coarray_init (gfc_namespace * ns __attribute((unused))) rest_of_decl_compilation (fndecl, 0, 0); make_decl_rtl (fndecl); - init_function_start (fndecl); + allocate_struct_function (fndecl, false); pushlevel (); gfc_init_block (&caf_init_block); @@ -4782,7 +4796,8 @@ add_argument_checking (stmtblock_t *block, gfc_symbol *sym) dummy argument is an array. (See "Sequence association" in Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */ if (fsym->attr.pointer || fsym->attr.allocatable - || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE)) + || (fsym->as && (fsym->as->type == AS_ASSUMED_SHAPE + || fsym->as->type == AS_ASSUMED_RANK))) { comparison = NE_EXPR; message = _("Actual string length does not match the declared one" @@ -4967,7 +4982,7 @@ create_main_function (tree fndecl) rest_of_decl_compilation (ftn_main, 1, 0); make_decl_rtl (ftn_main); - init_function_start (ftn_main); + allocate_struct_function (ftn_main, false); pushlevel (); gfc_init_block (&body); @@ -5522,7 +5537,7 @@ gfc_generate_constructors (void) make_decl_rtl (fndecl); - init_function_start (fndecl); + allocate_struct_function (fndecl, false); pushlevel (); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 7d1a6d43841..84a4b34bbb2 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -42,6 +42,48 @@ along with GCC; see the file COPYING3. If not see #include "dependency.h" +/* Convert a scalar to an array descriptor. To be used for assumed-rank + arrays. */ + +static tree +get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr) +{ + enum gfc_array_kind akind; + + if (attr.pointer) + akind = GFC_ARRAY_POINTER_CONT; + else if (attr.allocatable) + akind = GFC_ARRAY_ALLOCATABLE; + else + akind = GFC_ARRAY_ASSUMED_SHAPE_CONT; + + return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1, + akind, !(attr.pointer || attr.target)); +} + +static tree +conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr) +{ + tree desc, type; + + type = get_scalar_to_descriptor_type (scalar, attr); + desc = gfc_create_var (type, "desc"); + DECL_ARTIFICIAL (desc) = 1; + gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc), + gfc_get_dtype (type)); + gfc_conv_descriptor_data_set (&se->pre, desc, scalar); + + /* Copy pointer address back - but only if it could have changed and + if the actual argument is a pointer and not, e.g., NULL(). */ + if ((attr.pointer || attr.allocatable) + && attr.intent != INTENT_IN && POINTER_TYPE_P (TREE_TYPE (scalar))) + gfc_add_modify (&se->post, scalar, + fold_convert (TREE_TYPE (scalar), + gfc_conv_descriptor_data_get (desc))); + return desc; +} + + /* This is the seed for an eventual trans-class.c The following parameters should not be used directly since they might @@ -158,7 +200,34 @@ gfc_get_vptr_from_expr (tree expr) tmp = gfc_class_vptr_get (tmp); return tmp; } - + + +static void +class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc, + bool lhs_type) +{ + tree tmp, tmp2, type; + + gfc_conv_descriptor_data_set (block, lhs_desc, + gfc_conv_descriptor_data_get (rhs_desc)); + gfc_conv_descriptor_offset_set (block, lhs_desc, + gfc_conv_descriptor_offset_get (rhs_desc)); + + gfc_add_modify (block, gfc_conv_descriptor_dtype (lhs_desc), + gfc_conv_descriptor_dtype (rhs_desc)); + + /* Assign the dimension as range-ref. */ + tmp = gfc_get_descriptor_dimension (lhs_desc); + tmp2 = gfc_get_descriptor_dimension (rhs_desc); + + type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2); + tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp, + gfc_index_zero_node, NULL_TREE, NULL_TREE); + tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2, + gfc_index_zero_node, NULL_TREE, NULL_TREE); + gfc_add_modify (block, tmp, tmp2); +} + /* Takes a derived type expression and returns the address of a temporary class object of the 'declared' type. If vptr is not NULL, this is @@ -215,14 +284,32 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, { parmse->ss = NULL; gfc_conv_expr_reference (parmse, e); - tmp = fold_convert (TREE_TYPE (ctree), parmse->expr); - gfc_add_modify (&parmse->pre, ctree, tmp); + + /* Scalar to an assumed-rank array. */ + if (class_ts.u.derived->components->as) + { + tree type; + type = get_scalar_to_descriptor_type (parmse->expr, + gfc_expr_attr (e)); + gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree), + gfc_get_dtype (type)); + gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr); + } + else + { + tmp = fold_convert (TREE_TYPE (ctree), parmse->expr); + gfc_add_modify (&parmse->pre, ctree, tmp); + } } else { parmse->ss = ss; - gfc_conv_expr_descriptor (parmse, e, ss); - gfc_add_modify (&parmse->pre, ctree, parmse->expr); + gfc_conv_expr_descriptor (parmse, e); + + if (e->rank != class_ts.u.derived->components->as->rank) + class_array_data_assign (&parmse->pre, ctree, parmse->expr, true); + else + gfc_add_modify (&parmse->pre, ctree, parmse->expr); } } @@ -260,7 +347,9 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, break; } - if (ref == NULL || class_ref == ref) + if ((ref == NULL || class_ref == ref) + && (!class_ts.u.derived->components->as + || class_ts.u.derived->components->as->rank != -1)) return; /* Test for FULL_ARRAY. */ @@ -273,13 +362,42 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, /* Set the data. */ ctree = gfc_class_data_get (var); - gfc_add_modify (&parmse->pre, ctree, parmse->expr); + if (class_ts.u.derived->components->as + && e->rank != class_ts.u.derived->components->as->rank) + { + if (e->rank == 0) + { + tree type = get_scalar_to_descriptor_type (parmse->expr, + gfc_expr_attr (e)); + gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree), + gfc_get_dtype (type)); + gfc_conv_descriptor_data_set (&parmse->pre, ctree, + gfc_class_data_get (parmse->expr)); + + } + else + class_array_data_assign (&parmse->pre, ctree, parmse->expr, false); + } + else + gfc_add_modify (&parmse->pre, ctree, parmse->expr); /* Return the data component, except in the case of scalarized array references, where nullification of the cannot occur and so there is no need. */ if (!elemental && full_array) - gfc_add_modify (&parmse->post, parmse->expr, ctree); + { + if (class_ts.u.derived->components->as + && e->rank != class_ts.u.derived->components->as->rank) + { + if (e->rank == 0) + gfc_add_modify (&parmse->post, gfc_class_data_get (parmse->expr), + gfc_conv_descriptor_data_get (ctree)); + else + class_array_data_assign (&parmse->post, parmse->expr, ctree, true); + } + else + gfc_add_modify (&parmse->post, parmse->expr, ctree); + } /* Set the vptr. */ ctree = gfc_class_vptr_get (var); @@ -346,7 +464,7 @@ gfc_get_class_array_ref (tree index, tree class_decl) /* Copies one class expression to another, assuming that if either 'to' or 'from' are arrays they are packed. Should 'from' be - NULL_TREE, the inialization expression for 'to' is used, assuming + NULL_TREE, the initialization expression for 'to' is used, assuming that the _vptr is set. */ tree @@ -416,6 +534,7 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems) gfc_trans_scalarizing_loops (&loop, &loopbody); gfc_add_block_to_block (&body, &loop.pre); tmp = gfc_finish_block (&body); + gfc_cleanup_loop (&loop); } else { @@ -730,7 +849,8 @@ gfc_conv_expr_present (gfc_symbol * sym) as actual argument to denote absent dummies. For array descriptors, we thus also need to check the array descriptor. */ if (!sym->attr.pointer && !sym->attr.allocatable - && sym->as && sym->as->type == AS_ASSUMED_SHAPE + && sym->as && (sym->as->type == AS_ASSUMED_SHAPE + || sym->as->type == AS_ASSUMED_RANK) && (gfc_option.allow_std & GFC_STD_F2008) != 0) { tree tmp; @@ -1159,7 +1279,7 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref) /* This function deals with component references to components of the - parent type for derived type extensons. */ + parent type for derived type extensions. */ static void conv_parent_component_references (gfc_se * se, gfc_ref * ref) { @@ -1325,7 +1445,8 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) /* Dereference non-character pointer variables. These must be dummies, results, or scalars. */ if ((sym->attr.pointer || sym->attr.allocatable - || gfc_is_associate_pointer (sym)) + || gfc_is_associate_pointer (sym) + || (sym->as && sym->as->type == AS_ASSUMED_RANK)) && (sym->attr.dummy || sym->attr.function || sym->attr.result @@ -1392,9 +1513,9 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) separately. */ if (se->want_pointer) { - if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr, NULL)) + if (expr->ts.type == BT_CHARACTER && !gfc_is_proc_ptr_comp (expr)) gfc_conv_string_parameter (se); - else + else se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); } } @@ -2318,7 +2439,7 @@ conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr) { tree tmp; - if (gfc_is_proc_ptr_comp (expr, NULL)) + if (gfc_is_proc_ptr_comp (expr)) tmp = get_proc_ptr_comp (expr); else if (sym->attr.dummy) { @@ -2686,7 +2807,6 @@ gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping, gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]); gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]); } - gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset); break; case REF_COMPONENT: @@ -3265,8 +3385,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, gfc_actual_arglist * arg) { gfc_symbol *fsym; - gfc_ss *argss; - + if (sym->intmod_sym_id == ISOCBINDING_LOC) { if (arg->expr->rank == 0) @@ -3284,9 +3403,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, && fsym->as->type != AS_ASSUMED_SHAPE; f = f || !sym->attr.always_explicit; - argss = gfc_walk_expr (arg->expr); - gfc_conv_array_parameter (se, arg->expr, argss, f, - NULL, NULL, NULL); + gfc_conv_array_parameter (se, arg->expr, f, NULL, NULL, NULL); } /* TODO -- the following two lines shouldn't be necessary, but if @@ -3307,14 +3424,17 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, return 1; } - else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER - && arg->next->expr->rank == 0) + else if (sym->intmod_sym_id == ISOCBINDING_F_POINTER || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER) { - /* Convert c_f_pointer if fptr is a scalar - and convert c_f_procpointer. */ + /* Convert c_f_pointer and c_f_procpointer. */ gfc_se cptrse; gfc_se fptrse; + gfc_se shapese; + gfc_ss *shape_ss; + tree desc, dim, tmp, stride, offset; + stmtblock_t body, block; + gfc_loopinfo loop; gfc_init_se (&cptrse, NULL); gfc_conv_expr (&cptrse, arg->expr); @@ -3322,25 +3442,100 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, gfc_add_block_to_block (&se->post, &cptrse.post); gfc_init_se (&fptrse, NULL); - if (sym->intmod_sym_id == ISOCBINDING_F_POINTER - || gfc_is_proc_ptr_comp (arg->next->expr, NULL)) - fptrse.want_pointer = 1; + if (arg->next->expr->rank == 0) + { + if (sym->intmod_sym_id == ISOCBINDING_F_POINTER + || gfc_is_proc_ptr_comp (arg->next->expr)) + fptrse.want_pointer = 1; + + gfc_conv_expr (&fptrse, arg->next->expr); + gfc_add_block_to_block (&se->pre, &fptrse.pre); + gfc_add_block_to_block (&se->post, &fptrse.post); + if (arg->next->expr->symtree->n.sym->attr.proc_pointer + && arg->next->expr->symtree->n.sym->attr.dummy) + fptrse.expr = build_fold_indirect_ref_loc (input_location, + fptrse.expr); + se->expr = fold_build2_loc (input_location, MODIFY_EXPR, + TREE_TYPE (fptrse.expr), + fptrse.expr, + fold_convert (TREE_TYPE (fptrse.expr), + cptrse.expr)); + return 1; + } - gfc_conv_expr (&fptrse, arg->next->expr); - gfc_add_block_to_block (&se->pre, &fptrse.pre); - gfc_add_block_to_block (&se->post, &fptrse.post); - - if (arg->next->expr->symtree->n.sym->attr.proc_pointer - && arg->next->expr->symtree->n.sym->attr.dummy) - fptrse.expr = build_fold_indirect_ref_loc (input_location, - fptrse.expr); - - se->expr = fold_build2_loc (input_location, MODIFY_EXPR, - TREE_TYPE (fptrse.expr), - fptrse.expr, - fold_convert (TREE_TYPE (fptrse.expr), - cptrse.expr)); + gfc_start_block (&block); + + /* Get the descriptor of the Fortran pointer. */ + fptrse.descriptor_only = 1; + gfc_conv_expr_descriptor (&fptrse, arg->next->expr); + gfc_add_block_to_block (&block, &fptrse.pre); + desc = fptrse.expr; + + /* Set data value, dtype, and offset. */ + tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)); + gfc_conv_descriptor_data_set (&block, desc, + fold_convert (tmp, cptrse.expr)); + gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc), + gfc_get_dtype (TREE_TYPE (desc))); + + /* Start scalarization of the bounds, using the shape argument. */ + + shape_ss = gfc_walk_expr (arg->next->next->expr); + gcc_assert (shape_ss != gfc_ss_terminator); + gfc_init_se (&shapese, NULL); + + gfc_init_loopinfo (&loop); + gfc_add_ss_to_loop (&loop, shape_ss); + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop, &arg->next->expr->where); + gfc_mark_ss_chain_used (shape_ss, 1); + + gfc_copy_loopinfo_to_se (&shapese, &loop); + shapese.ss = shape_ss; + stride = gfc_create_var (gfc_array_index_type, "stride"); + offset = gfc_create_var (gfc_array_index_type, "offset"); + gfc_add_modify (&block, stride, gfc_index_one_node); + gfc_add_modify (&block, offset, gfc_index_zero_node); + + /* Loop body. */ + gfc_start_scalarized_body (&loop, &body); + + dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + loop.loopvar[0], loop.from[0]); + + /* Set bounds and stride. */ + gfc_conv_descriptor_lbound_set (&body, desc, dim, gfc_index_one_node); + gfc_conv_descriptor_stride_set (&body, desc, dim, stride); + + gfc_conv_expr (&shapese, arg->next->next->expr); + gfc_add_block_to_block (&body, &shapese.pre); + gfc_conv_descriptor_ubound_set (&body, desc, dim, shapese.expr); + gfc_add_block_to_block (&body, &shapese.post); + + /* Calculate offset. */ + gfc_add_modify (&body, offset, + fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, offset, stride)); + /* Update stride. */ + gfc_add_modify (&body, stride, + fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, stride, + fold_convert (gfc_array_index_type, + shapese.expr))); + /* Finish scalarization loop. */ + gfc_trans_scalarizing_loops (&loop, &body); + gfc_add_block_to_block (&block, &loop.pre); + gfc_add_block_to_block (&block, &loop.post); + gfc_add_block_to_block (&block, &fptrse.post); + gfc_cleanup_loop (&loop); + + gfc_add_modify (&block, offset, + fold_build1_loc (input_location, NEGATE_EXPR, + gfc_array_index_type, offset)); + gfc_conv_descriptor_offset_set (&block, desc, offset); + + se->expr = gfc_finish_block (&block); return 1; } else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED) @@ -3414,7 +3609,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, tree tmp; tree fntype; gfc_se parmse; - gfc_ss *argss; gfc_array_info *info; int byref; int parm_kind; @@ -3449,7 +3643,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && conv_isocbinding_procedure (se, sym, args)) return 0; - gfc_is_proc_ptr_comp (expr, &comp); + comp = gfc_get_proc_ptr_comp (expr); if (se->ss != NULL) { @@ -3539,10 +3733,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, parmse.string_length = build_int_cst (gfc_charlen_type_node, 0); } } - else if (arg->expr->expr_type == EXPR_NULL && fsym && !fsym->attr.pointer) + else if (arg->expr->expr_type == EXPR_NULL + && fsym && !fsym->attr.pointer + && (fsym->ts.type != BT_CLASS + || !CLASS_DATA (fsym)->attr.class_pointer)) { /* Pass a NULL pointer to denote an absent arg. */ - gcc_assert (fsym->attr.optional && !fsym->attr.allocatable); + gcc_assert (fsym->attr.optional && !fsym->attr.allocatable + && (fsym->ts.type != BT_CLASS + || !CLASS_DATA (fsym)->attr.allocatable)); gfc_init_se (&parmse, NULL); parmse.expr = null_pointer_node; if (arg->missing_arg_type == BT_CHARACTER) @@ -3612,11 +3811,20 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, } else { - /* A scalar or transformational function. */ - gfc_init_se (&parmse, NULL); + bool scalar; + gfc_ss *argss; + + /* Check whether the expression is a scalar or not; we cannot use + e->rank as it can be nonzero for functions arguments. */ argss = gfc_walk_expr (e); + scalar = argss == gfc_ss_terminator; + if (!scalar) + gfc_free_ss_chain (argss); - if (argss == gfc_ss_terminator) + /* A scalar or transformational function. */ + gfc_init_se (&parmse, NULL); + + if (scalar) { if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.cray_pointee @@ -3683,7 +3891,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, class object, if the formal argument is a class object. */ if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS - && CLASS_DATA (e)->attr.dimension) + && ((CLASS_DATA (fsym)->as + && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK) + || CLASS_DATA (e)->attr.dimension)) gfc_conv_class_to_class (&parmse, e, fsym->ts, false); if (fsym && (fsym->ts.type == BT_DERIVED @@ -3727,7 +3937,23 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_add_expr_to_block (&se->pre, tmp); } - if (fsym && e->expr_type != EXPR_NULL + /* Wrap scalar variable in a descriptor. We need to convert + the address of a pointer back to the pointer itself before, + we can assign it to the data field. */ + + if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK + && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL) + { + tmp = parmse.expr; + if (TREE_CODE (tmp) == ADDR_EXPR + && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp, 0)))) + tmp = TREE_OPERAND (tmp, 0); + parmse.expr = conv_scalar_to_descriptor (&parmse, tmp, + fsym->attr); + parmse.expr = gfc_build_addr_expr (NULL_TREE, + parmse.expr); + } + else if (fsym && e->expr_type != EXPR_NULL && ((fsym->attr.pointer && fsym->attr.flavor != FL_PROCEDURE) || (fsym->attr.proc_pointer @@ -3735,7 +3961,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && e->symtree->n.sym->attr.dummy)) || (fsym->attr.proc_pointer && e->expr_type == EXPR_VARIABLE - && gfc_is_proc_ptr_comp (e, NULL)) + && gfc_is_proc_ptr_comp (e)) || (fsym->attr.allocatable && fsym->attr.flavor != FL_PROCEDURE))) { @@ -3753,7 +3979,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, { /* Pass a class array. */ gfc_init_se (&parmse, se); - gfc_conv_expr_descriptor (&parmse, e, argss); + gfc_conv_expr_descriptor (&parmse, e); /* The conversion does not repackage the reference to a class array - _data descriptor. */ gfc_conv_class_to_class (&parmse, e, fsym->ts, false); @@ -3769,7 +3995,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, bool f; f = (fsym != NULL) && !(fsym->attr.pointer || fsym->attr.allocatable) - && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE; + && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE + && fsym->as->type != AS_ASSUMED_RANK; if (comp) f = f || !comp->attr.always_explicit; else @@ -3835,8 +4062,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, fsym ? fsym->attr.intent : INTENT_INOUT, fsym && fsym->attr.pointer); else - gfc_conv_array_parameter (&parmse, e, argss, f, fsym, - sym->name, NULL); + gfc_conv_array_parameter (&parmse, e, f, fsym, sym->name, NULL); /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is allocated on entry, it must be deallocated. */ @@ -3878,12 +4104,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, but do not always set fsym. */ if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional - && ((e->rank > 0 && sym->attr.elemental) + && ((e->rank != 0 && sym->attr.elemental) || e->representation.length || e->ts.type == BT_CHARACTER - || (e->rank > 0 + || (e->rank != 0 && (fsym == NULL || (fsym-> as && (fsym->as->type == AS_ASSUMED_SHAPE + || fsym->as->type == AS_ASSUMED_RANK || fsym->as->type == AS_DEFERRED)))))) gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts, e->representation.length); @@ -4129,7 +4356,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, tmp = caf_decl; } - if (fsym->as->type == AS_ASSUMED_SHAPE) + if (fsym->as->type == AS_ASSUMED_SHAPE + || (fsym->as->type == AS_ASSUMED_RANK && !fsym->attr.pointer + && !fsym->attr.allocatable)) { gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr))); gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE @@ -4851,6 +5080,7 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr) /* Restore the original variables. */ for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++) gfc_restore_sym (fargs->sym, &saved_vars[n]); + free (temp_vars); free (saved_vars); } @@ -5127,7 +5357,6 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr) { gfc_se se; - gfc_ss *rss; stmtblock_t block; tree offset; int n; @@ -5140,9 +5369,8 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm, gfc_init_se (&se, NULL); /* Get the descriptor for the expressions. */ - rss = gfc_walk_expr (expr); se.want_pointer = 0; - gfc_conv_expr_descriptor (&se, expr, rss); + gfc_conv_expr_descriptor (&se, expr); gfc_add_block_to_block (&block, &se.pre); gfc_add_modify (&block, dest, se.expr); @@ -5273,7 +5501,6 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) { gfc_se se; gfc_se lse; - gfc_ss *rss; stmtblock_t block; tree tmp; @@ -5290,10 +5517,9 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) gfc_conv_descriptor_data_set (&block, dest, null_pointer_node); else { - rss = gfc_walk_expr (expr); se.direct_byref = 1; se.expr = dest; - gfc_conv_expr_descriptor (&se, expr, rss); + gfc_conv_expr_descriptor (&se, expr); gfc_add_block_to_block (&block, &se.pre); gfc_add_block_to_block (&block, &se.post); } @@ -5738,25 +5964,29 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) { gfc_se lse; gfc_se rse; - gfc_ss *lss; - gfc_ss *rss; stmtblock_t block; tree desc; tree tmp; tree decl; + bool scalar; + gfc_ss *ss; gfc_start_block (&block); gfc_init_se (&lse, NULL); - lss = gfc_walk_expr (expr1); - rss = gfc_walk_expr (expr2); - if (lss == gfc_ss_terminator) + /* Check whether the expression is a scalar or not; we cannot use + expr1->rank as it can be nonzero for proc pointers. */ + ss = gfc_walk_expr (expr1); + scalar = ss == gfc_ss_terminator; + if (!scalar) + gfc_free_ss_chain (ss); + + if (scalar) { /* Scalar pointers. */ lse.want_pointer = 1; gfc_conv_expr (&lse, expr1); - gcc_assert (rss == gfc_ss_terminator); gfc_init_se (&rse, NULL); rse.want_pointer = 1; gfc_conv_expr (&rse, expr2); @@ -5780,7 +6010,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL && !expr1->ts.deferred && !expr1->symtree->n.sym->attr.proc_pointer - && !gfc_is_proc_ptr_comp (expr1, NULL)) + && !gfc_is_proc_ptr_comp (expr1)) { gcc_assert (expr2->ts.type == BT_CHARACTER); gcc_assert (lse.string_length && rse.string_length); @@ -5816,17 +6046,16 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) /* Array pointer. Find the last reference on the LHS and if it is an array section ref, we're dealing with bounds remapping. In this case, set it to AR_FULL so that gfc_conv_expr_descriptor does - not see it and process the bounds remapping afterwards explicitely. */ + not see it and process the bounds remapping afterwards explicitly. */ for (remap = expr1->ref; remap; remap = remap->next) if (!remap->next && remap->type == REF_ARRAY && remap->u.ar.type == AR_SECTION) - { - remap->u.ar.type = AR_FULL; - break; - } + break; rank_remap = (remap && remap->u.ar.end[0]); - gfc_conv_expr_descriptor (&lse, expr1, lss); + if (remap) + lse.descriptor_only = 1; + gfc_conv_expr_descriptor (&lse, expr1); strlen_lhs = lse.string_length; desc = lse.expr; @@ -5842,14 +6071,14 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_init_se (&rse, NULL); rse.direct_byref = 1; rse.byref_noassign = 1; - gfc_conv_expr_descriptor (&rse, expr2, rss); + gfc_conv_expr_descriptor (&rse, expr2); strlen_rhs = rse.string_length; } else if (expr2->expr_type == EXPR_VARIABLE) { /* Assign directly to the LHS's descriptor. */ lse.direct_byref = 1; - gfc_conv_expr_descriptor (&lse, expr2, rss); + gfc_conv_expr_descriptor (&lse, expr2); strlen_rhs = lse.string_length; /* If this is a subreference array pointer assignment, use the rhs @@ -5875,7 +6104,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) lse.expr = tmp; lse.direct_byref = 1; - gfc_conv_expr_descriptor (&lse, expr2, rss); + gfc_conv_expr_descriptor (&lse, expr2); strlen_rhs = lse.string_length; gfc_add_modify (&lse.pre, desc, tmp); } @@ -6080,11 +6309,34 @@ gfc_conv_string_parameter (gfc_se * se) /* Generate code for assignment of scalar variables. Includes character strings and derived types with allocatable components. - If you know that the LHS has no allocations, set dealloc to false. */ + If you know that the LHS has no allocations, set dealloc to false. + + DEEP_COPY has no effect if the typespec TS is not a derived type with + allocatable components. Otherwise, if it is set, an explicit copy of each + allocatable component is made. This is necessary as a simple copy of the + whole object would copy array descriptors as is, so that the lhs's + allocatable components would point to the rhs's after the assignment. + Typically, setting DEEP_COPY is necessary if the rhs is a variable, and not + necessary if the rhs is a non-pointer function, as the allocatable components + are not accessible by other means than the function's result after the + function has returned. It is even more subtle when temporaries are involved, + as the two following examples show: + 1. When we evaluate an array constructor, a temporary is created. Thus + there is theoretically no alias possible. However, no deep copy is + made for this temporary, so that if the constructor is made of one or + more variable with allocatable components, those components still point + to the variable's: DEEP_COPY should be set for the assignment from the + temporary to the lhs in that case. + 2. When assigning a scalar to an array, we evaluate the scalar value out + of the loop, store it into a temporary variable, and assign from that. + In that case, deep copying when assigning to the temporary would be a + waste of resources; however deep copies should happen when assigning from + the temporary to each array element: again DEEP_COPY should be set for + the assignment from the temporary to the lhs. */ tree gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, - bool l_is_temp, bool r_is_var, bool dealloc) + bool l_is_temp, bool deep_copy, bool dealloc) { stmtblock_t block; tree tmp; @@ -6118,9 +6370,9 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, else if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp) { cond = NULL_TREE; - + /* Are the rhs and the lhs the same? */ - if (r_is_var) + if (deep_copy) { cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, gfc_build_addr_expr (NULL_TREE, lse->expr), @@ -6136,7 +6388,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, { tmp = gfc_evaluate_now (lse->expr, &lse->pre); tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0); - if (r_is_var) + if (deep_copy) tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location), tmp); gfc_add_expr_to_block (&lse->post, tmp); @@ -6150,7 +6402,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, /* Do a deep copy if the rhs is a variable, if it is not the same as the lhs. */ - if (r_is_var) + if (deep_copy) { tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0); tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location), @@ -6464,7 +6716,7 @@ static tree gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) { gfc_se se; - gfc_ss *ss; + gfc_ss *ss = NULL; gfc_component *comp = NULL; gfc_loopinfo loop; @@ -6473,19 +6725,17 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic functions. */ + comp = gfc_get_proc_ptr_comp (expr2); gcc_assert (expr2->value.function.isym - || (gfc_is_proc_ptr_comp (expr2, &comp) - && comp && comp->attr.dimension) + || (comp && comp->attr.dimension) || (!comp && gfc_return_by_reference (expr2->value.function.esym) && expr2->value.function.esym->result->attr.dimension)); - ss = gfc_walk_expr (expr1); - gcc_assert (ss != gfc_ss_terminator); gfc_init_se (&se, NULL); gfc_start_block (&se.pre); se.want_pointer = 1; - gfc_conv_array_parameter (&se, expr1, ss, false, NULL, NULL, NULL); + gfc_conv_array_parameter (&se, expr1, false, NULL, NULL, NULL); if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp) @@ -6519,6 +6769,9 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) if (!expr2->value.function.isym) { + ss = gfc_walk_expr (expr1); + gcc_assert (ss != gfc_ss_terminator); + realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop); ss->is_alloc_lhs = 1; } @@ -6529,6 +6782,11 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) gfc_conv_function_expr (&se, expr2); gfc_add_block_to_block (&se.pre, &se.post); + if (ss) + gfc_cleanup_loop (&loop); + else + gfc_free_ss_chain (se.ss); + return gfc_finish_block (&se.pre); } @@ -6711,6 +6969,8 @@ static bool expr_is_variable (gfc_expr *expr) { gfc_expr *arg; + gfc_component *comp; + gfc_symbol *func_ifc; if (expr->expr_type == EXPR_VARIABLE) return true; @@ -6722,7 +6982,50 @@ expr_is_variable (gfc_expr *expr) return expr_is_variable (arg); } + /* A data-pointer-returning function should be considered as a variable + too. */ + if (expr->expr_type == EXPR_FUNCTION + && expr->ref == NULL) + { + if (expr->value.function.isym != NULL) + return false; + + if (expr->value.function.esym != NULL) + { + func_ifc = expr->value.function.esym; + goto found_ifc; + } + else + { + gcc_assert (expr->symtree); + func_ifc = expr->symtree->n.sym; + goto found_ifc; + } + + gcc_unreachable (); + } + + comp = gfc_get_proc_ptr_comp (expr); + if ((expr->expr_type == EXPR_PPC || expr->expr_type == EXPR_FUNCTION) + && comp) + { + func_ifc = comp->ts.interface; + goto found_ifc; + } + + if (expr->expr_type == EXPR_COMPCALL) + { + gcc_assert (!expr->value.compcall.tbp->is_generic); + func_ifc = expr->value.compcall.tbp->u.specific->n.sym; + goto found_ifc; + } + return false; + +found_ifc: + gcc_assert (func_ifc->attr.function + && func_ifc->result != NULL); + return func_ifc->result->attr.pointer; } diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index c74e81a011e..add4baaa311 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -39,7 +39,6 @@ along with GCC; see the file COPYING3. If not see #include "trans-const.h" #include "trans-types.h" #include "trans-array.h" -#include "defaults.h" /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */ #include "trans-stmt.h" @@ -924,43 +923,6 @@ gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr) } -/* Convert the last ref of a scalar coarray from an AR_ELEMENT to an - AR_FULL, suitable for the scalarizer. */ - -static gfc_ss * -walk_coarray (gfc_expr *e) -{ - gfc_ss *ss; - - gcc_assert (gfc_get_corank (e) > 0); - - ss = gfc_walk_expr (e); - - /* Fix scalar coarray. */ - if (ss == gfc_ss_terminator) - { - gfc_ref *ref; - - ref = e->ref; - while (ref) - { - if (ref->type == REF_ARRAY - && ref->u.ar.codimen > 0) - break; - - ref = ref->next; - } - - gcc_assert (ref != NULL); - if (ref->u.ar.type == AR_ELEMENT) - ref->u.ar.type = AR_SECTION; - ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref)); - } - - return ss; -} - - static void trans_this_image (gfc_se * se, gfc_expr *expr) { @@ -968,7 +930,6 @@ trans_this_image (gfc_se * se, gfc_expr *expr) tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var, lbound, ubound, extent, ml; gfc_se argse; - gfc_ss *ss; int rank, corank; /* The case -fcoarray=single is handled elsewhere. */ @@ -992,10 +953,8 @@ trans_this_image (gfc_se * se, gfc_expr *expr) /* Obtain the descriptor of the COARRAY. */ gfc_init_se (&argse, NULL); - ss = walk_coarray (expr->value.function.actual->expr); - gcc_assert (ss != gfc_ss_terminator); argse.want_coarray = 1; - gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr, ss); + gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr); gfc_add_block_to_block (&se->pre, &argse.pre); gfc_add_block_to_block (&se->post, &argse.post); desc = argse.expr; @@ -1187,7 +1146,6 @@ trans_image_index (gfc_se * se, gfc_expr *expr) tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc, tmp, invalid_bound; gfc_se argse, subse; - gfc_ss *ss, *subss; int rank, corank, codim; type = gfc_get_int_type (gfc_default_integer_kind); @@ -1196,20 +1154,15 @@ trans_image_index (gfc_se * se, gfc_expr *expr) /* Obtain the descriptor of the COARRAY. */ gfc_init_se (&argse, NULL); - ss = walk_coarray (expr->value.function.actual->expr); - gcc_assert (ss != gfc_ss_terminator); argse.want_coarray = 1; - gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr, ss); + gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr); gfc_add_block_to_block (&se->pre, &argse.pre); gfc_add_block_to_block (&se->post, &argse.post); desc = argse.expr; /* Obtain a handle to the SUB argument. */ gfc_init_se (&subse, NULL); - subss = gfc_walk_expr (expr->value.function.actual->next->expr); - gcc_assert (subss != gfc_ss_terminator); - gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr, - subss); + gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr); gfc_add_block_to_block (&se->pre, &subse.pre); gfc_add_block_to_block (&se->post, &subse.post); subdesc = build_fold_indirect_ref_loc (input_location, @@ -1320,25 +1273,16 @@ static void gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr) { gfc_se argse; - gfc_ss *ss; - tree dtype, tmp; - ss = gfc_walk_expr (expr->value.function.actual->expr); - gcc_assert (ss != gfc_ss_terminator); gfc_init_se (&argse, NULL); argse.data_not_needed = 1; - argse.want_pointer = 1; + argse.descriptor_only = 1; - gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr, ss); + gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr); gfc_add_block_to_block (&se->pre, &argse.pre); gfc_add_block_to_block (&se->post, &argse.post); - argse.expr = build_fold_indirect_ref_loc (input_location, argse.expr); - argse.expr = build_fold_indirect_ref_loc (input_location, argse.expr); - dtype = gfc_conv_descriptor_dtype (argse.expr); - tmp = build_int_cst (TREE_TYPE (dtype), GFC_DTYPE_RANK_MASK); - tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (dtype), - dtype, tmp); - se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp); + + se->expr = gfc_conv_descriptor_rank (argse.expr); } @@ -1358,8 +1302,8 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) tree ubound; tree lbound; gfc_se argse; - gfc_ss *ss; gfc_array_spec * as; + bool assumed_rank_lb_one; arg = expr->value.function.actual; arg2 = arg->next; @@ -1392,36 +1336,43 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) /* TODO: don't re-evaluate the descriptor on each iteration. */ /* Get a descriptor for the first parameter. */ - ss = gfc_walk_expr (arg->expr); - gcc_assert (ss != gfc_ss_terminator); gfc_init_se (&argse, NULL); - gfc_conv_expr_descriptor (&argse, arg->expr, ss); + gfc_conv_expr_descriptor (&argse, arg->expr); gfc_add_block_to_block (&se->pre, &argse.pre); gfc_add_block_to_block (&se->post, &argse.post); desc = argse.expr; + as = gfc_get_full_arrayspec_from_expr (arg->expr); + if (INTEGER_CST_P (bound)) { int hi, low; hi = TREE_INT_CST_HIGH (bound); low = TREE_INT_CST_LOW (bound); - if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))) + if (hi || low < 0 + || ((!as || as->type != AS_ASSUMED_RANK) + && low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))) + || low > GFC_MAX_DIMENSIONS) gfc_error ("'dim' argument of %s intrinsic at %L is not a valid " "dimension index", upper ? "UBOUND" : "LBOUND", &expr->where); } - else + + if (!INTEGER_CST_P (bound) || (as && as->type == AS_ASSUMED_RANK)) { if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) { bound = gfc_evaluate_now (bound, &se->pre); cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, bound, build_int_cst (TREE_TYPE (bound), 0)); - tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))]; + if (as && as->type == AS_ASSUMED_RANK) + tmp = gfc_conv_descriptor_rank (desc); + else + tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))]; tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, - bound, tmp); + bound, fold_convert(TREE_TYPE (bound), tmp)); cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp); gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, @@ -1429,11 +1380,19 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) } } + /* Take care of the lbound shift for assumed-rank arrays, which are + nonallocatable and nonpointers. Those has a lbound of 1. */ + assumed_rank_lb_one = as && as->type == AS_ASSUMED_RANK + && ((arg->expr->ts.type != BT_CLASS + && !arg->expr->symtree->n.sym->attr.allocatable + && !arg->expr->symtree->n.sym->attr.pointer) + || (arg->expr->ts.type == BT_CLASS + && !CLASS_DATA (arg->expr)->attr.allocatable + && !CLASS_DATA (arg->expr)->attr.class_pointer)); + ubound = gfc_conv_descriptor_ubound_get (desc, bound); lbound = gfc_conv_descriptor_lbound_get (desc, bound); - as = gfc_get_full_arrayspec_from_expr (arg->expr); - /* 13.14.53: Result value for LBOUND Case (i): For an array section or for an array expression other than a @@ -1455,7 +1414,9 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) not have size zero and has value zero if dimension DIM has size zero. */ - if (as) + if (!upper && assumed_rank_lb_one) + se->expr = gfc_index_one_node; + else if (as) { tree stride = gfc_conv_descriptor_stride_get (desc, bound); @@ -1481,9 +1442,19 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node, cond, cond5); + if (assumed_rank_lb_one) + { + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, ubound, lbound); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, tmp, gfc_index_one_node); + } + else + tmp = ubound; + se->expr = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond, - ubound, gfc_index_zero_node); + tmp, gfc_index_zero_node); } else { @@ -1532,7 +1503,6 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr) gfc_actual_arglist *arg; gfc_actual_arglist *arg2; gfc_se argse; - gfc_ss *ss; tree bound, resbound, resbound2, desc, cond, tmp; tree type; int corank; @@ -1547,12 +1517,10 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr) gcc_assert (arg->expr->expr_type == EXPR_VARIABLE); corank = gfc_get_corank (arg->expr); - ss = walk_coarray (arg->expr); - gcc_assert (ss != gfc_ss_terminator); gfc_init_se (&argse, NULL); argse.want_coarray = 1; - gfc_conv_expr_descriptor (&argse, arg->expr, ss); + gfc_conv_expr_descriptor (&argse, arg->expr); gfc_add_block_to_block (&se->pre, &argse.pre); gfc_add_block_to_block (&se->post, &argse.post); desc = argse.expr; @@ -4557,7 +4525,7 @@ conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr, sym = gfc_get_symbol_for_expr (expr); gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, append_args); - free (sym); + gfc_free_symbol (sym); } @@ -4571,7 +4539,6 @@ gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr) gfc_symbol *sym; gfc_se argse; gfc_expr *arg; - gfc_ss *ss; gcc_assert (!se->ss); @@ -4613,12 +4580,11 @@ gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr) default: /* Anybody stupid enough to do this deserves inefficient code. */ - ss = gfc_walk_expr (arg); gfc_init_se (&argse, se); - if (ss == gfc_ss_terminator) + if (arg->rank == 0) gfc_conv_expr (&argse, arg); else - gfc_conv_expr_descriptor (&argse, arg, ss); + gfc_conv_expr_descriptor (&argse, arg); gfc_add_block_to_block (&se->pre, &argse.pre); gfc_add_block_to_block (&se->post, &argse.post); len = argse.string_length; @@ -5075,7 +5041,6 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) tree fncall0; tree fncall1; gfc_se argse; - gfc_ss *ss; gfc_init_se (&argse, NULL); actual = expr->value.function.actual; @@ -5083,11 +5048,9 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) if (actual->expr->ts.type == BT_CLASS) gfc_add_class_array_ref (actual->expr); - ss = gfc_walk_expr (actual->expr); - gcc_assert (ss != gfc_ss_terminator); argse.want_pointer = 1; argse.data_not_needed = 1; - gfc_conv_expr_descriptor (&argse, actual->expr, ss); + gfc_conv_expr_descriptor (&argse, actual->expr); gfc_add_block_to_block (&se->pre, &argse.pre); gfc_add_block_to_block (&se->post, &argse.post); arg1 = gfc_evaluate_now (argse.expr, &se->pre); @@ -5190,7 +5153,6 @@ static void gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr) { gfc_expr *arg; - gfc_ss *ss; gfc_se argse; tree source_bytes; tree type; @@ -5202,9 +5164,8 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr) arg = expr->value.function.actual->expr; gfc_init_se (&argse, NULL); - ss = gfc_walk_expr (arg); - if (ss == gfc_ss_terminator) + if (arg->rank == 0) { if (arg->ts.type == BT_CLASS) gfc_add_data_component (arg); @@ -5225,7 +5186,7 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr) { source_bytes = gfc_create_var (gfc_array_index_type, "bytes"); argse.want_pointer = 0; - gfc_conv_expr_descriptor (&argse, arg, ss); + gfc_conv_expr_descriptor (&argse, arg); type = gfc_get_element_type (TREE_TYPE (argse.expr)); /* Obtain the argument's word length. */ @@ -5262,7 +5223,6 @@ static void gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr) { gfc_expr *arg; - gfc_ss *ss; gfc_se argse,eight; tree type, result_type, tmp; @@ -5271,10 +5231,9 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr) gfc_conv_expr (&eight, gfc_get_int_expr (expr->ts.kind, NULL, 8)); gfc_init_se (&argse, NULL); - ss = gfc_walk_expr (arg); result_type = gfc_get_int_type (expr->ts.kind); - if (ss == gfc_ss_terminator) + if (arg->rank == 0) { if (arg->ts.type == BT_CLASS) { @@ -5292,7 +5251,7 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr) else { argse.want_pointer = 0; - gfc_conv_expr_descriptor (&argse, arg, ss); + gfc_conv_expr_descriptor (&argse, arg); type = gfc_get_element_type (TREE_TYPE (argse.expr)); } @@ -5386,7 +5345,6 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) tree stmt; gfc_actual_arglist *arg; gfc_se argse; - gfc_ss *ss; gfc_array_info *info; stmtblock_t block; int n; @@ -5412,12 +5370,11 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) arg->expr->value.function.name = "__transfer_in_transfer"; gfc_init_se (&argse, NULL); - ss = gfc_walk_expr (arg->expr); source_bytes = gfc_create_var (gfc_array_index_type, NULL); /* Obtain the pointer to source and the length of source in bytes. */ - if (ss == gfc_ss_terminator) + if (arg->expr->rank == 0) { gfc_conv_expr_reference (&argse, arg->expr); source = argse.expr; @@ -5436,7 +5393,7 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) else { argse.want_pointer = 0; - gfc_conv_expr_descriptor (&argse, arg->expr, ss); + gfc_conv_expr_descriptor (&argse, arg->expr); source = gfc_conv_descriptor_data_get (argse.expr); source_type = gfc_get_element_type (TREE_TYPE (argse.expr)); @@ -5510,11 +5467,10 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) arg = arg->next; gfc_init_se (&argse, NULL); - ss = gfc_walk_expr (arg->expr); scalar_mold = arg->expr->rank == 0; - if (ss == gfc_ss_terminator) + if (arg->expr->rank == 0) { gfc_conv_expr_reference (&argse, arg->expr); mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location, @@ -5524,7 +5480,7 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) { gfc_init_se (&argse, NULL); argse.want_pointer = 0; - gfc_conv_expr_descriptor (&argse, arg->expr, ss); + gfc_conv_expr_descriptor (&argse, arg->expr); mold_type = gfc_get_element_type (TREE_TYPE (argse.expr)); } @@ -5717,7 +5673,6 @@ gfc_conv_allocated (gfc_se *se, gfc_expr *expr) { gfc_actual_arglist *arg1; gfc_se arg1se; - gfc_ss *ss1; tree tmp; gfc_init_se (&arg1se, NULL); @@ -5734,9 +5689,7 @@ gfc_conv_allocated (gfc_se *se, gfc_expr *expr) gfc_add_data_component (arg1->expr); } - ss1 = gfc_walk_expr (arg1->expr); - - if (ss1 == gfc_ss_terminator) + if (arg1->expr->rank == 0) { /* Allocatable scalar. */ arg1se.want_pointer = 1; @@ -5747,7 +5700,7 @@ gfc_conv_allocated (gfc_se *se, gfc_expr *expr) { /* Allocatable array. */ arg1se.descriptor_only = 1; - gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1); + gfc_conv_expr_descriptor (&arg1se, arg1->expr); tmp = gfc_conv_descriptor_data_get (arg1se.expr); } @@ -5774,7 +5727,8 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) tree tmp; tree nonzero_charlen; tree nonzero_arraylen; - gfc_ss *ss1, *ss2; + gfc_ss *ss; + bool scalar; gfc_init_se (&arg1se, NULL); gfc_init_se (&arg2se, NULL); @@ -5782,12 +5736,18 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) if (arg1->expr->ts.type == BT_CLASS) gfc_add_data_component (arg1->expr); arg2 = arg1->next; - ss1 = gfc_walk_expr (arg1->expr); + + /* Check whether the expression is a scalar or not; we cannot use + arg1->expr->rank as it can be nonzero for proc pointers. */ + ss = gfc_walk_expr (arg1->expr); + scalar = ss == gfc_ss_terminator; + if (!scalar) + gfc_free_ss_chain (ss); if (!arg2->expr) { /* No optional target. */ - if (ss1 == gfc_ss_terminator) + if (scalar) { /* A pointer to a scalar. */ arg1se.want_pointer = 1; @@ -5801,7 +5761,7 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) else { /* A pointer to an array. */ - gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1); + gfc_conv_expr_descriptor (&arg1se, arg1->expr); tmp2 = gfc_conv_descriptor_data_get (arg1se.expr); } gfc_add_block_to_block (&se->pre, &arg1se.pre); @@ -5815,7 +5775,6 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) /* An optional target. */ if (arg2->expr->ts.type == BT_CLASS) gfc_add_data_component (arg2->expr); - ss2 = gfc_walk_expr (arg2->expr); nonzero_charlen = NULL_TREE; if (arg1->expr->ts.type == BT_CHARACTER) @@ -5823,11 +5782,9 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) boolean_type_node, arg1->expr->ts.u.cl->backend_decl, integer_zero_node); - - if (ss1 == gfc_ss_terminator) + if (scalar) { /* A pointer to a scalar. */ - gcc_assert (ss2 == gfc_ss_terminator); arg1se.want_pointer = 1; gfc_conv_expr (&arg1se, arg1->expr); if (arg1->expr->symtree->n.sym->attr.proc_pointer @@ -5856,19 +5813,25 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) present. */ arg1se.descriptor_only = 1; gfc_conv_expr_lhs (&arg1se, arg1->expr); - tmp = gfc_conv_descriptor_stride_get (arg1se.expr, - gfc_rank_cst[arg1->expr->rank - 1]); + if (arg1->expr->rank == -1) + { + tmp = gfc_conv_descriptor_rank (arg1se.expr); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + TREE_TYPE (tmp), tmp, gfc_index_one_node); + } + else + tmp = gfc_rank_cst[arg1->expr->rank - 1]; + tmp = gfc_conv_descriptor_stride_get (arg1se.expr, tmp); nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp, build_int_cst (TREE_TYPE (tmp), 0)); /* A pointer to an array, call library function _gfor_associated. */ - gcc_assert (ss2 != gfc_ss_terminator); arg1se.want_pointer = 1; - gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1); + gfc_conv_expr_descriptor (&arg1se, arg1->expr); arg2se.want_pointer = 1; - gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2); + gfc_conv_expr_descriptor (&arg2se, arg2->expr); gfc_add_block_to_block (&se->pre, &arg2se.pre); gfc_add_block_to_block (&se->post, &arg2se.post); se->expr = build_call_expr_loc (input_location, @@ -6223,16 +6186,14 @@ gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr) { tree temp_var; gfc_expr *arg_expr; - gfc_ss *ss; gcc_assert (!se->ss); arg_expr = expr->value.function.actual->expr; - ss = gfc_walk_expr (arg_expr); - if (ss == gfc_ss_terminator) + if (arg_expr->rank == 0) gfc_conv_expr_reference (se, arg_expr); else - gfc_conv_array_parameter (se, arg_expr, ss, true, NULL, NULL, NULL); + gfc_conv_array_parameter (se, arg_expr, true, NULL, NULL, NULL); se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr); /* Create a temporary variable for loc return value. Without this, @@ -7271,7 +7232,6 @@ conv_intrinsic_move_alloc (gfc_code *code) gfc_expr *from_expr, *to_expr; gfc_expr *to_expr2, *from_expr2 = NULL; gfc_se from_se, to_se; - gfc_ss *from_ss, *to_ss; tree tmp; bool coarray; @@ -7397,19 +7357,15 @@ conv_intrinsic_move_alloc (gfc_code *code) } } + /* Deallocate "to". */ - if (from_expr->rank != 0) - { - to_ss = gfc_walk_expr (to_expr); - from_ss = gfc_walk_expr (from_expr); - } - else + if (from_expr->rank == 0) { - to_ss = walk_coarray (to_expr); - from_ss = walk_coarray (from_expr); + to_se.want_coarray = 1; + from_se.want_coarray = 1; } - gfc_conv_expr_descriptor (&to_se, to_expr, to_ss); - gfc_conv_expr_descriptor (&from_se, from_expr, from_ss); + gfc_conv_expr_descriptor (&to_se, to_expr); + gfc_conv_expr_descriptor (&from_se, from_expr); /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC is an image control "statement", cf. IR F08/0040 in 12-006A. */ diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index 8218f85a98d..34db6fd5a11 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -664,7 +664,7 @@ gfc_convert_array_to_string (gfc_se * se, gfc_expr * e) return; } - gfc_conv_array_parameter (se, e, gfc_walk_expr (e), true, NULL, NULL, &size); + gfc_conv_array_parameter (se, e, true, NULL, NULL, &size); se->string_length = fold_convert (gfc_charlen_type_node, size); } @@ -780,8 +780,6 @@ set_internal_unit (stmtblock_t * block, stmtblock_t * post_block, /* Character array. */ else if (e->rank > 0) { - se.ss = gfc_walk_expr (e); - if (is_subref_array (e)) { /* Use a temporary for components of arrays of derived types @@ -796,7 +794,7 @@ set_internal_unit (stmtblock_t * block, stmtblock_t * post_block, else { /* Return the data pointer and rank from the descriptor. */ - gfc_conv_expr_descriptor (&se, e, se.ss); + gfc_conv_expr_descriptor (&se, e); tmp = gfc_conv_descriptor_data_get (se.expr); se.expr = gfc_build_addr_expr (pchar_type_node, se.expr); } @@ -2236,12 +2234,10 @@ gfc_trans_transfer (gfc_code * code) gfc_init_block (&body); expr = code->expr1; - ss = gfc_walk_expr (expr); - ref = NULL; gfc_init_se (&se, NULL); - if (ss == gfc_ss_terminator) + if (expr->rank == 0) { /* Transfer a scalar value. */ gfc_conv_expr_reference (&se, expr); @@ -2252,7 +2248,7 @@ gfc_trans_transfer (gfc_code * code) /* Transfer an array. If it is an array of an intrinsic type, pass the descriptor to the library. Otherwise scalarize the transfer. */ - if (expr->ref && !gfc_is_proc_ptr_comp (expr, NULL)) + if (expr->ref && !gfc_is_proc_ptr_comp (expr)) { for (ref = expr->ref; ref && ref->type != REF_ARRAY; ref = ref->next); @@ -2281,15 +2277,16 @@ gfc_trans_transfer (gfc_code * code) else { /* Get the descriptor. */ - gfc_conv_expr_descriptor (&se, expr, ss); + gfc_conv_expr_descriptor (&se, expr); tmp = gfc_build_addr_expr (NULL_TREE, se.expr); } transfer_array_desc (&se, &expr->ts, tmp); goto finish_block_label; } - + /* Initialize the scalarizer. */ + ss = gfc_walk_expr (expr); gfc_init_loopinfo (&loop); gfc_add_ss_to_loop (&loop, ss); diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 323fca382c3..8bc491655be 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -109,7 +109,8 @@ gfc_trans_label_assign (gfc_code * code) label_tree = gfc_get_label_decl (code->label1); - if (code->label1->defined == ST_LABEL_TARGET) + if (code->label1->defined == ST_LABEL_TARGET + || code->label1->defined == ST_LABEL_DO_TARGET) { label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree); len_tree = integer_minus_one_node; @@ -273,7 +274,7 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse, /* Obtain the argument descriptor for unpacking. */ gfc_init_se (&parmse, NULL); parmse.want_pointer = 1; - gfc_conv_expr_descriptor (&parmse, e, gfc_walk_expr (e)); + gfc_conv_expr_descriptor (&parmse, e); gfc_add_block_to_block (&se->pre, &parmse.pre); /* If we've got INTENT(INOUT) or a derived type with INTENT(OUT), @@ -863,9 +864,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type) "implemented for image-set at %L", gfc_c_int_kind, &code->expr1->where); - gfc_conv_array_parameter (&se, code->expr1, - gfc_walk_expr (code->expr1), true, NULL, - NULL, &len); + gfc_conv_array_parameter (&se, code->expr1, true, NULL, NULL, &len); images = se.expr; tmp = gfc_typenode_for_spec (&code->expr1->ts); @@ -1159,7 +1158,6 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) && (sym->as->type == AS_DEFERRED || sym->assoc->variable)) { gfc_se se; - gfc_ss *ss; tree desc; desc = sym->backend_decl; @@ -1167,13 +1165,12 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) /* If association is to an expression, evaluate it and create temporary. Otherwise, get descriptor of target for pointer assignment. */ gfc_init_se (&se, NULL); - ss = gfc_walk_expr (e); if (sym->assoc->variable) { se.direct_byref = 1; se.expr = desc; } - gfc_conv_expr_descriptor (&se, e, ss); + gfc_conv_expr_descriptor (&se, e); /* If we didn't already do the pointer assignment, set associate-name descriptor to the one generated for the temporary. */ @@ -1228,7 +1225,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension) { /* For a class array we need a descriptor for the selector. */ - gfc_conv_expr_descriptor (&se, e, gfc_walk_expr (e)); + gfc_conv_expr_descriptor (&se, e); /* Obtain a temporary class container for the result. */ gfc_conv_class_to_class (&se, e, sym->ts, false); @@ -1788,7 +1785,7 @@ gfc_trans_do_while (gfc_code * code) gfc_conv_expr_val (&cond, code->expr1); gfc_add_block_to_block (&block, &cond.pre); cond.expr = fold_build1_loc (code->expr1->where.lb->location, - TRUTH_NOT_EXPR, boolean_type_node, cond.expr); + TRUTH_NOT_EXPR, TREE_TYPE (cond.expr), cond.expr); /* Build "IF (! cond) GOTO exit_label". */ tmp = build1_v (GOTO_EXPR, exit_label); @@ -3501,8 +3498,7 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, gfc_init_se (&lse, NULL); lse.expr = gfc_build_array_ref (tmp1, count, NULL); lse.direct_byref = 1; - rss = gfc_walk_expr (expr2); - gfc_conv_expr_descriptor (&lse, expr2, rss); + gfc_conv_expr_descriptor (&lse, expr2); gfc_add_block_to_block (&body, &lse.pre); gfc_add_block_to_block (&body, &lse.post); @@ -3523,9 +3519,8 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, gfc_add_modify (block, count, gfc_index_zero_node); parm = gfc_build_array_ref (tmp1, count, NULL); - lss = gfc_walk_expr (expr1); gfc_init_se (&lse, NULL); - gfc_conv_expr_descriptor (&lse, expr1, lss); + gfc_conv_expr_descriptor (&lse, expr1); gfc_add_modify (&lse.pre, lse.expr, parm); gfc_start_block (&body); gfc_add_block_to_block (&body, &lse.pre); diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index aa50e3d0b21..3286a5a6fd6 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -80,8 +80,8 @@ bool gfc_real16_is_float128 = false; static GTY(()) tree gfc_desc_dim_type; static GTY(()) tree gfc_max_array_element_size; -static GTY(()) tree gfc_array_descriptor_base[2 * GFC_MAX_DIMENSIONS]; -static GTY(()) tree gfc_array_descriptor_base_caf[2 * GFC_MAX_DIMENSIONS]; +static GTY(()) tree gfc_array_descriptor_base[2 * (GFC_MAX_DIMENSIONS+1)]; +static GTY(()) tree gfc_array_descriptor_base_caf[2 * (GFC_MAX_DIMENSIONS+1)]; /* Arrays for all integral and real kinds. We'll fill this in at runtime after the target has a chance to process command-line options. */ @@ -1272,12 +1272,13 @@ gfc_is_nodesc_array (gfc_symbol * sym) return 0; /* We want a descriptor for associate-name arrays that do not have an - explicitely known shape already. */ + explicitly known shape already. */ if (sym->assoc && sym->as->type != AS_EXPLICIT) return 0; if (sym->attr.dummy) - return sym->as->type != AS_ASSUMED_SHAPE; + return sym->as->type != AS_ASSUMED_SHAPE + && sym->as->type != AS_ASSUMED_RANK; if (sym->attr.result || sym->attr.function) return 0; @@ -1299,6 +1300,13 @@ gfc_build_array_type (tree type, gfc_array_spec * as, tree ubound[GFC_MAX_DIMENSIONS]; int n; + if (as->type == AS_ASSUMED_RANK) + for (n = 0; n < GFC_MAX_DIMENSIONS; n++) + { + lbound[n] = NULL_TREE; + ubound[n] = NULL_TREE; + } + for (n = 0; n < as->rank; n++) { /* Create expressions for the known bounds of the array. */ @@ -1323,7 +1331,12 @@ gfc_build_array_type (tree type, gfc_array_spec * as, if (as->type == AS_ASSUMED_SHAPE) akind = contiguous ? GFC_ARRAY_ASSUMED_SHAPE_CONT : GFC_ARRAY_ASSUMED_SHAPE; - return gfc_get_array_type_bounds (type, as->rank, as->corank, lbound, + else if (as->type == AS_ASSUMED_RANK) + akind = contiguous ? GFC_ARRAY_ASSUMED_RANK_CONT + : GFC_ARRAY_ASSUMED_RANK; + return gfc_get_array_type_bounds (type, as->rank == -1 + ? GFC_MAX_DIMENSIONS : as->rank, + as->corank, lbound, ubound, 0, akind, restricted); } @@ -1682,9 +1695,15 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted, { tree fat_type, decl, arraytype, *chain = NULL; char name[16 + 2*GFC_RANK_DIGITS + 1 + 1]; - int idx = 2 * (codimen + dimen - 1) + restricted; + int idx; + + /* Assumed-rank array. */ + if (dimen == -1) + dimen = GFC_MAX_DIMENSIONS; + + idx = 2 * (codimen + dimen) + restricted; - gcc_assert (codimen + dimen >= 1 && codimen + dimen <= GFC_MAX_DIMENSIONS); + gcc_assert (codimen + dimen >= 0 && codimen + dimen <= GFC_MAX_DIMENSIONS); if (gfc_option.coarray == GFC_FCOARRAY_LIB && codimen) { @@ -1721,16 +1740,18 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted, TREE_NO_WARNING (decl) = 1; /* Build the array type for the stride and bound components. */ - arraytype = - build_array_type (gfc_get_desc_dim_type (), - build_range_type (gfc_array_index_type, - gfc_index_zero_node, - gfc_rank_cst[codimen + dimen - 1])); + if (dimen + codimen > 0) + { + arraytype = + build_array_type (gfc_get_desc_dim_type (), + build_range_type (gfc_array_index_type, + gfc_index_zero_node, + gfc_rank_cst[codimen + dimen - 1])); - decl = gfc_add_field_to_struct_1 (fat_type, - get_identifier ("dim"), - arraytype, &chain); - TREE_NO_WARNING (decl) = 1; + decl = gfc_add_field_to_struct_1 (fat_type, get_identifier ("dim"), + arraytype, &chain); + TREE_NO_WARNING (decl) = 1; + } if (gfc_option.coarray == GFC_FCOARRAY_LIB && codimen && akind == GFC_ARRAY_ALLOCATABLE) diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h index 2ab94b3f184..29cdf089b49 100644 --- a/gcc/fortran/trans-types.h +++ b/gcc/fortran/trans-types.h @@ -40,7 +40,7 @@ extern GTY(()) tree complex_float128_type_node; and runtime library. */ extern GTY(()) tree gfc_charlen_type_node; -/* The following flags give us information on the correspondance of +/* The following flags give us information on the correspondence of real (and complex) kinds with C floating-point types long double and __float128. */ extern bool gfc_real16_is_float128; diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 3313be92df8..ff0b243a202 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -26,7 +26,6 @@ along with GCC; see the file COPYING3. If not see #include "gimple.h" /* For create_tmp_var_raw. */ #include "tree-iterator.h" #include "diagnostic-core.h" /* For internal_error. */ -#include "defaults.h" #include "flags.h" #include "gfortran.h" #include "trans.h" diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 3b77281568a..9818ceb1f4a 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -109,7 +109,7 @@ typedef enum gfc_coarray_type; -/* The array-specific scalarization informations. The array members of +/* The array-specific scalarization information. The array members of this struct are indexed by actual array index, and thus can be sparse. */ typedef struct gfc_array_info @@ -765,6 +765,8 @@ enum gfc_array_kind GFC_ARRAY_UNKNOWN, GFC_ARRAY_ASSUMED_SHAPE, GFC_ARRAY_ASSUMED_SHAPE_CONT, + GFC_ARRAY_ASSUMED_RANK, + GFC_ARRAY_ASSUMED_RANK_CONT, GFC_ARRAY_ALLOCATABLE, GFC_ARRAY_POINTER, GFC_ARRAY_POINTER_CONT |