diff options
Diffstat (limited to 'gcc/fortran')
48 files changed, 6013 insertions, 1058 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index aa6d6cb..b84ce2f 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,1155 @@ +2025-10-13 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/121191 + * trans-array.cc (has_parameterized_comps): New function which + checks if a derived type has parameterized components. + ( gfc_deallocate_pdt_comp): Use it to prevent deallocation of + PDTs if there are no parameterized components. + +2025-10-12 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/95543 + PR fortran/103748 + * decl.cc (insert_parameter_exprs): Guard param->expr before + using it. + (gfc_get_pdt_instance): Substitute paramaters in kind default + initializers. + (gfc_match_decl_type_spec): Emit an error if a type paramter + specification list appears in a variable declaraion with a + non-parameterized type. + * primary.cc (gfc_match_rvalue): Emit an error if a type spec + list is empty. + +2025-10-11 Harald Anlauf <anlauf@gmx.de> + + PR fortran/50377 + PR fortran/122257 + * resolve.cc (resolve_actual_arglist): Initialize variable. + +2025-10-10 Harald Anlauf <anlauf@gmx.de> + + PR fortran/50377 + * resolve.cc (resolve_actual_arglist): Check procedure actual + arguments. + +2025-10-09 Harald Anlauf <anlauf@gmx.de> + + PR fortran/122206 + * trans-types.cc (gfc_get_function_type): Do not clobber an + existing procedure interface. + +2025-10-09 David Malcolm <dmalcolm@redhat.com> + + * error.cc: Define INCLUDE_VECTOR. + +2025-10-08 Harald Anlauf <anlauf@gmx.de> + + PR fortran/49111 + * decl.cc (verify_bind_c_sym): Modify condition for generation of + accessibility warning, and adjust warning message. + +2025-10-08 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/93175 + PR fortran/102240 + PR fortran/102686 + * array.cc (match_array_element_spec): For pdt templates, call + gfc_correct_parm_expr to elimante extraneous symbols from the + bound expressions. + * decl.cc (correct_parm_expr, gfc_correct_parm_expr): New fcns + that remove symbols that are not PDT parameters from the type + specification expressions. + (insert_parameter_exprs): Process function symbols as if they + are variables in the substitution with parameter expressions. + (gfc_get_pdt_instance): Make sure that the parameter list of + PDT components is updated as the instance is built. Move the + construction of pdt_strings down a bit in the function and + remove the tie up with pdt_arrays. + * gfortran.h: Add prototype for gfc_correct_parm_expr. + * resolve.cc (resolve_component): Skip testing for constant + specification expressions in pdt_template component string + lengths and pdt_strings. + * trans-array.cc (structure_alloc_comps): Remove testing for + deferred parameters and instead make sure that components of + PDT type have parameters substituted with the parameter exprs + of the enclosing PDT. + +2025-10-07 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/102901 + * trans-array.cc (structure_alloc_comps): Do not use + gfc_check_pdt_dummy with pointer or allocatable components. + +2025-10-04 Harald Anlauf <anlauf@gmx.de> + + PR fortran/107968 + * trans-io.cc (gfc_trans_transfer): Also scalarize I/O of section + of an array pointer. + +2025-10-03 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/122089 + * decl.cc (gfc_get_pdt_instance): If gfc_extract_int is true an + error has occurred because the kind expr was not provided. Use + the template in this case and return MATCH_YES. + +2025-10-01 Harald Anlauf <anlauf@gmx.de> + + PR fortran/122080 + * trans-array.cc (gfc_conv_array_parameter): Wrap the derivation of + bounds and strides for the descriptor of an optional dummy array + argument by a test on argument presence when it is supposed to be + passed to an optional argument. + +2025-10-01 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/122089 + * decl.cc (gfc_get_pdt_instance): If the pdt_template is use + associated, 'module' field should be copied to this instance. + +2025-09-30 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/102241 + * gfortran.h: Add symbol attribute 'pdt_comp'. + * module.cc : Add 'pdt_comp' to 'ab_attribute' and 'attr_bits'. + (mio_symbol_attribute): Set 'pdt_comp'. + * resolve.cc (resolve_component): If a PDT component is found + in a non-PDT type, generate the PDT instance, if necessary, and + set the 'pdt_comp' attribute. Fix some whitespace issues. + * trans-decl.cc (gfc_get_symbol_decl, gfc_trans_deferred_vars): + If 'pdt_comp' set, initialize the PDT components. + * trans-stmt.cc (gfc_trans_deallocate): Verify that a typespec + parameter list is available for PDT components of ordinary + derived types. + +2025-09-27 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/87908 + * interface.cc (check_interface0): Revert changes. + +2025-09-26 Harald Anlauf <anlauf@gcc.gnu.org> + + PR fortran/122002 + * decl.cc (gfc_get_pdt_instance): Initialize 'instance' to NULL + and set 'kind_value' to zero before calling gfc_extract_int. + * primary.cc (gfc_match_rvalue): Intitialize 'ctr_arglist' to + NULL and test for default values if gfc_get_pdt_instance + returns NULL. + +2025-09-25 Harald Anlauf <anlauf@gmx.de> + + PR fortran/121939 + * trans-types.cc (gfc_init_types): Set string flag for all + character types. + +2025-09-24 Mikael Morin <morin-mikael@orange.fr> + + PR fortran/122046 + * symbol.cc (gfc_get_procedure_ns): Try to find the namespace + among the list of contained namespaces before returning the + value from the formal_ns field. + +2025-09-24 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/87908 + * interface.cc (check_interface0): If a vtable is found in the + interface list, check that it is either a subroutine or a + function. Let resolve.cc do any further checking. + +2025-09-22 Steve Kargl <pault@gcc.gnu.org> + + PR fortran/103508 + * decl.cc (gfc_match_end): Remove only the current partial + rather than removing the entire sibling chain. + +2025-09-21 Harald Anlauf <anlauf@gmx.de> + + PR fortran/109010 + * st.cc (gfc_free_statement): Also free components expr3 and expr4. + +2025-09-21 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/121161 + * invoke.texi: Mention that -ffrontend-optimize is required + for -fexternal-blas64. + * options.cc (gfc_post_options): Fatal error if -fexternal-blas64 + is specified without -ffrontend-optimize. + * trans-types.cc (gfc_init_kinds): Fatal error if -fexternal-blas64 + is specified on a system which does not have 64-bit ptrdiff_t. + +2025-09-21 Harald Anlauf <anlauf@gmx.de> + + PR fortran/108581 + * trans-array.cc (gfc_conv_expr_descriptor): Take the dynamic + string length into account when deriving the dataptr offset for + a deferred-length character array. + +2025-09-20 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/83746 + * trans-decl.cc (gfc_trans_deferred_vars): If a procedure with + an non-allocatable, non-pointer explicit PDT result has no + default initializer, the parameterized components should be + allocated. + +2025-09-19 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/83746 + * trans-array.cc (structure_alloc_comps): Add the pre and post + blocks to 'fnblock' for all the evaluations of parameterized + expressions in PDT component allocatation. + +2025-09-18 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/121948 + * decl.cc (gfc_get_pdt_instance): Copy the contents of 'tb' and + not the pointer. + * primary.cc (gfc_match_rvalue): If there is only one actual + argument list, use if for the type spec parameter values. If + this fails try the default type specification values and use + the actual arguments for the component values. + * resolve.cc (build_init_assign): Don't initialize implicit PDT + function results. + +2025-09-17 Thomas Koenig <tkoenig@gcc.gnu.org> + + * frontend-passes.cc (optimize_namespace): Handle + flag_external_blas64. + (call_external_blas): If flag_external_blas is set, use + gfc_integer_4_kind as the argument kind, gfc_integer_8_kind otherwise. + * gfortran.h (gfc_integer_8_kind): Define. + * invoke.texi: Document -fexternal-blas64. + * lang.opt: Add -fexternal-blas64. + * lang.opt.urls: Regenerated. + * options.cc (gfc_post_options): -fexternal-blas is incompatible + with -fexternal-blas64. + +2025-09-15 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/83763 + * trans-decl.cc (gfc_trans_deferred_vars): Ensure that the + parameterized components of PDTs that do not have allocatable + components are deallocated on leaving scope. + * trans-expr.cc (gfc_trans_assignment_1): Do a dependency check + on PDT assignments. If there is a dependency between lhs and + rhs, deallocate the lhs parameterized components after the rhs + has been evaluated. + +2025-09-14 Yuao Ma <c8ef@outlook.com> + + * dump-parse-tree.cc (show_expr): Add support for EXPR_CONDITIONAL. + * expr.cc (gfc_get_conditional_expr): Add cond-expr constructor. + (gfc_copy_expr, free_expr0, gfc_is_constant_expr, + simplify_conditional, gfc_simplify_expr, gfc_check_init_expr, + check_restricted, gfc_traverse_expr): Add support for EXPR_CONDITIONAL. + * frontend-passes.cc (gfc_expr_walker): Ditto. + * gfortran.h (enum expr_t): Add EXPR_CONDITIONAL. + (gfc_get_operator_expr): Format fix. + (gfc_get_conditional_expr): New decl. + * matchexp.cc + (match_conditional, match_primary): Parsing for EXPR_CONDITIONAL. + * module.cc (mio_expr): Add support for EXPR_CONDITIONAL. + * resolve.cc (resolve_conditional, gfc_resolve_expr): Ditto. + * trans-array.cc (gfc_walk_conditional_expr, gfc_walk_subexpr): Ditto. + * trans-expr.cc + (gfc_conv_conditional_expr): Codegen for EXPR_CONDITIONAL. + (gfc_apply_interface_mapping_to_expr, gfc_conv_expr, + gfc_conv_expr_reference): Add support for EXPR_CONDITIONAL. + +2025-09-11 Harald Anlauf <anlauf@gmx.de> + + PR fortran/121616 + * primary.cc (gfc_variable_attr): Properly set dimension attribute + from a component ref. + +2025-09-09 Harald Anlauf <anlauf@gmx.de> + + * trans-intrinsic.cc (conv_intrinsic_fstat_lstat_stat_sub): Init + some variables. + +2025-09-09 Harald Anlauf <anlauf@gmx.de> + + PR fortran/82480 + * check.cc (error_unsupported_kind): Helper function to report an + unsupported kind of an argument. + (check_minrange4): Helper function to report if an integer variable + does not have a decimal range of at least four. + (gfc_check_fstat): Adjust checks for generalization of instrinsic + function FSTAT. + (gfc_check_fstat_sub): Likewise for subroutine FSTAT. + (gfc_check_stat): Likewise for functio STAT. + (gfc_check_stat_sub): Likewise for subroutine STAT. + * intrinsic.texi: Document generalized versions of intrinsics + STAT/LSTAT/FSTAT. + * iresolve.cc (gfc_resolve_stat): STAT function result shall have + the same kind as the VALUES argument. + (gfc_resolve_lstat): Likewise for LSTAT. + (gfc_resolve_fstat): Likewise for FSTAT. + (gfc_resolve_stat_sub): Resolve proper library subroutine for STAT. + (gfc_resolve_lstat_sub): Likewise for LSTAT. + * trans-decl.cc (gfc_build_intrinsic_function_decls): Declare + fndecls for required subroutines in runtine library. + * trans-intrinsic.cc (conv_intrinsic_fstat_lstat_stat_sub): Emit + runtime wrapper code for the library functions, taking care of + possible kind conversion of the optional STATUS argument of the + subroutine versions of the intrinsics. + (gfc_conv_intrinsic_subroutine): Use it. + * trans.h (GTY): Declare prototypes. + +2025-09-08 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/84008 + * decl.cc (insert_parameter_exprs): Correct the typespec of new + variable declarations, where the type is set to BT_PROCEDURE as + a precaution for resolution of the whole program unit. + +2025-09-06 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/84119 + * resolve.cc (reset_array_ref_to_scalar): New function using + chunk broken out from gfc_resolve_ref. + (gfc_resolve_ref): Call the new function, the first time for + PDT type parameters and the second time for LEN inquiry refs. + +2025-09-05 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/84432 + PR fortran/114815 + * expr.cc (gfc_check_assign_symbol): Check that components in a + PDT with a default initializer have type and length parameters + that reduce to constant integer expressions. + * trans-expr.cc (gfc_trans_assignment_1): Parameterized + components cannot have default initializers so they must be + allocated after initialization. + +2025-09-05 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/83762 + PR fortran/102457 + * decl.cc (gfc_get_pdt_instance): Check that variable PDT parm + expressions are of type integer. Note that the symbol must be + tested since the expression often appears as BT_PROCEDURE. + +2025-09-03 Harald Anlauf <anlauf@gmx.de> + + PR fortran/121263 + * trans-intrinsic.cc (gfc_conv_intrinsic_transfer): For an + unlimited polymorphic SOURCE to TRANSFER use saved descriptor + if possible. + +2025-09-02 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/89707 + * decl.cc (gfc_get_pdt_instance): Copy the typebound procedure + field from the PDT template. If the template interface has + kind=0, provide the new instance with an interface with a type + spec that points to that of the parameterized component. + (match_ppc_decl): When 'saved_kind_expr' this is a PDT and the + expression should be copied to the component kind_expr. + * gfortran.h: Define gfc_get_tbp. + +2025-09-02 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/87669 + * expr.cc (gfc_spec_list_type): If no LEN components are seen, + unconditionally return 'SPEC_ASSUMED'. This suppresses an + invalid error in match.cc(gfc_match_type_is). + +2025-09-01 Harald Anlauf <anlauf@gmx.de> + + PR fortran/121727 + * trans-expr.cc (gfc_const_length_character_type_p): New helper + function. + (conv_dummy_value): Use it to determine if a character actual + argument has a constant length. If a character actual argument is + constant and longer than the dummy, truncate it at compile time. + +2025-08-31 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/99709 + * trans-array.cc (structure_alloc_comps): For the case + COPY_ALLOC_COMP, do a deep copy of non-allocatable PDT arrays + Suppress the use of 'duplicate_allocatable' for PDT arrays. + * trans-expr.cc (conv_dummy_value): When passing to a PDT dummy + with the VALUE attribute, do a deep copy to ensure that + parameterized components are reallocated. + +2025-08-29 Harald Anlauf <anlauf@gmx.de> + + PR fortran/93330 + * interface.cc (get_sym_storage_size): Add argument size_known to + indicate that the storage size could be successfully determined. + (get_expr_storage_size): Likewise. + (gfc_compare_actual_formal): Use them to handle zero-sized dummy + and actual arguments. + If a character formal argument has the pointer or allocatable + attribute, or is an array that is not assumed or explicit size, + we generate an error by default unless -std=legacy is specified, + which falls back to just giving a warning. + If -Wcharacter-truncation is given, warn on a character actual + argument longer than the dummy. Generate an error for too short + scalar character arguments if -std=f* is given instead of just a + warning. + +2025-08-28 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/82843 + * intrinsic.cc (gfc_convert_type_warn): If the 'from_ts' is a + PDT instance, copy the derived type to the target ts. + * resolve.cc (gfc_resolve_ref): A PDT component in a component + reference can be that of the pdt_template. Unconditionally use + component of the PDT instance to ensure that the backend_decl + is set during translation. Likewise if a component is + encountered that is a PDT template type, use the component + parmeters to convert to the correct PDT instance. + +2025-08-28 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/82205 + * decl.cc (gfc_get_pdt_instance): Copy the default initializer + for components that are not PDT parameters or parameterized. If + any component is a pointer or allocatable set the attributes + 'pointer_comp' or 'alloc_comp' of the new PDT instance. + * primary.cc (gfc_match_rvalue): Implement the correct form of + PDT constructors with 'name (type parms)(component values)'. + * trans-array.cc (structure_alloc_comps): Apply scalar default + initializers. Array initializers await the coming change in PDT + representation. + * trans-io.cc (transfer_expr): Do not output the type parms of + a PDT in list directed output. + +2025-08-27 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/114611 + * io.cc: Issue an error on use of the H descriptor in + a format with -std=f95 or higher. Otherwise, issue a + warning. + +2025-08-26 Sandra Loosemore <sloosemore@baylibre.com> + + PR middle-end/118839 + * trans-openmp.cc (gfc_trans_omp_declare_variant): Error if variant + is the same as base. + +2025-08-26 Sandra Loosemore <sloosemore@baylibre.com> + + * openmp.cc (gfc_match_omp_declare_variant): Make check for a + missing "match" clause unconditional. + +2025-08-21 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/121627 + * module.cc (create_int_parameter_array): Avoid NULL + pointer dereference and enhance error message. + +2025-08-21 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/84122 + PR fortran/85942 + * parse.cc (parse_derived): PDT type parameters are not allowed + an explicit access specification and must appear before a + PRIVATE statement. If a PRIVATE statement is seen, mark all the + other components as PRIVATE. + * simplify.cc (get_kind): Convert a PDT KIND component into a + specification expression using the default initializer. + +2025-08-20 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + * intrinsic.texi: Correct the example given for FRACTION. + Move the TEAM_NUMBER section to after the TANPI to align + with the order gven in the index. + +2025-08-16 H.J. Lu <hjl.tools@gmail.com> + + PR fortran/107421 + * trans-common.cc (build_common_decl): Call set_decl_tls_model + after processing a variable. + * trans-decl.cc (gfc_finish_var_decl): Likewise. + (get_proc_pointer_decl): Likewise. + +2025-08-13 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/89092 + * resolve.cc (was_declared): Add subroutine attribute. + +2025-08-12 Yuao Ma <c8ef@outlook.com> + + * check.cc (gfc_check_c_f_pointer): Check lower arg legitimacy. + * intrinsic.cc (add_subroutines): Teach c_f_pointer about lower arg. + * intrinsic.h (gfc_check_c_f_pointer): Add lower arg. + * intrinsic.texi: Update lower arg for c_f_pointer. + * trans-intrinsic.cc (conv_isocbinding_subroutine): Add logic handle lower. + +2025-08-11 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/121398 + * resolve.cc (check_pdt_args): New function. + (check_generic_tbp_ambiguity): Use it to ensure that args to + typebound procedures that do not have the same declared type as + the containing derived type have 'pass1/2' set to null. This + avoids false ambiguity errors. + (resolve_typebound_procedure): Do not generate a wrong type + error for typebound procedures marked as pass if they are of a + different declared type to the containing pdt_type. + +2025-08-11 Jakub Jelinek <jakub@redhat.com> + + * gfortran.h (gfc_case): Fix comment typo, singe -> single. + +2025-08-09 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/121182 + * decl.cc (match_generic_stmt): New function based on original + gfc_match_generic but feeding namespace rather than typebound + generics. + (match_typebound_generic): Renamed original gfc_match_generic. + (gfc_match_generic): New function that selects between type + bound generic and other generic statements and calls one of the + above two functions as appropriate. + * parse.cc (decode_specification_statement): Allow generic + statements. + (parse_spec): Accept a generic statement in a specification + block. + +2025-08-05 Mikael Morin <morin-mikael@orange.fr> + + * trans-stmt.cc (trans_associate_var): Remove overwrite of + the polymorphic associate variable's array descriptor offset. + +2025-08-05 Mikael Morin <morin-mikael@orange.fr> + + * trans-array.cc (trans_array_constructor): Remove the update of + the array descriptor upper bound after array constructor + expansion. + +2025-08-05 Mikael Morin <morin-mikael@orange.fr> + + * trans-array.cc (gfc_conv_expr_descriptor): Remove + isolated initialization of the span field before passing to + the function that will do the initialization. + +2025-08-05 Mikael Morin <morin-mikael@orange.fr> + + * trans-decl.cc (gfc_trans_deferred_vars): Don't default + initialize the span of local pointer arrays. + +2025-08-05 Mikael Morin <morin-mikael@orange.fr> + + * trans-stmt.cc (trans_associate_var): Remove overwrite of the + span field of the associate variable's array descriptor. + +2025-08-05 Mikael Morin <morin-mikael@orange.fr> + + * trans-expr.cc (gfc_trans_pointer_assignment): Remove overwrite + of the span after assignment of the array descriptor in the + polymorphic function result to non-polymorphic pointer case. + +2025-08-05 Mikael Morin <mikael@gcc.gnu.org> + + * trans.h (gfc_se): Remove field use_offset. + * trans-expr.cc (gfc_conv_intrinsic_to_class): Remove use_offset + initialization. + (gfc_conv_procedure_call): Likewise. + * trans-stmt.cc (trans_associate_var): Likewise. + +2025-08-05 Mikael Morin <mikael@gcc.gnu.org> + + * trans-array.cc (gfc_alloc_allocatable_for_assignment): Use the + offset setter instead of generating a write to the offset. + (gfc_conv_array_parameter): Use the offset setter instead of + generating a write to the value returned by the offset getter. + * trans-expr.cc (gfc_trans_alloc_subarray_assign): Likewise. + +2025-08-05 Mikael Morin <mikael@gcc.gnu.org> + + * trans-array.cc (gfc_conv_descriptor_data_addr): Remove. + * trans-array.h (gfc_conv_descriptor_data_addr): Remove. + * trans-decl.cc (gfc_trans_deferred_vars): Use + gfc_conv_descriptor_data_get. + +2025-08-05 Mikael Morin <mikael@gcc.gnu.org> + + * trans.cc (gfc_finalize_tree_expr): Use the data setter instead + of writing to the value returned by the data getter. + * trans-decl.cc (gfc_trans_deferred_vars): Likewise. + * trans-stmt.cc (trans_associate_var): Use the data setter + instead of writing to the value dereferenced from the data + address. + +2025-08-01 Mikael Morin <mikael@gcc.gnu.org> + + * trans-decl.cc (gfc_trans_deferred_vars): Fix closing brace in + a comment. + +2025-07-31 Mikael Morin <morin-mikael@orange.fr> + + PR fortran/121342 + * trans-expr.cc (gfc_conv_subref_array_arg): Remove offset + update. + (gfc_conv_procedure_call): For polymorphic functions, move the + scalarizer descriptor information... + * trans-array.cc (gfc_add_loop_ss_code): ... here, and evaluate + the bounds to fresh variables. + (get_class_info_from_ss): Remove offset update. + (gfc_conv_ss_startstride): Don't set a zero value for function + result upper bounds. + (late_set_loop_bounds): New. + (gfc_conv_loop_setup): If the bounds of a function result have + been set, and no other array provided loop bounds for a + dimension, use the function result bounds as loop bounds for + that dimension. + (gfc_set_delta): Don't skip delta setting for polymorphic + function results. + +2025-07-30 Mikael Morin <morin-mikael@orange.fr> + + * trans-array.cc (gfc_array_init_size): Remove the nelems + argument. + (gfc_array_allocate): Update caller. Remove the nelems + argument. + * trans-stmt.cc (gfc_trans_allocate): Update caller. Remove the + nelems variable. + * trans-array.h (gfc_array_allocate): Update prototype. + +2025-07-30 Yuao Ma <c8ef@outlook.com> + + * check.cc (gfc_check_split): Argument check for SPLIT. + * gfortran.h (enum gfc_isym_id): Define GFC_ISYM_SPLIT. + * intrinsic.cc (add_subroutines): Register SPLIT intrinsic. + * intrinsic.h (gfc_check_split): New decl. + (gfc_resolve_split): Ditto. + * intrinsic.texi: SPLIT documentation. + * iresolve.cc (gfc_resolve_split): Add resolved_sym for SPLIT. + * trans-decl.cc (gfc_build_intrinsic_function_decls): Add decl for + SPLIT in libgfortran. + * trans-intrinsic.cc (conv_intrinsic_split): SPLIT codegen. + (gfc_conv_intrinsic_subroutine): Handle SPLIT case. + * trans.h (GTY): Declare gfor_fndecl_string_split{, _char4}. + +2025-07-27 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/121185 + * trans-expr.cc (gfc_trans_assignment_1): Use the same condition + to set the is_alloc_lhs flag and to decide to generate + reallocation code. Add explicit call to gfc_fix_class_refs + before evaluating the condition. + +2025-07-27 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/121185 + * trans-array.cc (set_factored_descriptor_value): Also trigger + the saving of the previously selected reference on encountering + an INDIRECT_REF. Extract the saving code... + (save_ref): ... here as a new function. + +2025-07-27 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/121185 + * trans-expr.cc (gfc_get_class_from_expr): Give up class + container lookup on the second COMPONENT_REF after an array + descriptor. + +2025-07-25 David Malcolm <dmalcolm@redhat.com> + + * error.cc: Make diagnostics::context::m_source_printing private. + +2025-07-25 David Malcolm <dmalcolm@redhat.com> + + * cpp.cc: Update usage of "diagnostic_info" to explicitly refer to + "diagnostics::diagnostic_info". + * error.cc: Likewise. + +2025-07-25 David Malcolm <dmalcolm@redhat.com> + + * cpp.cc: Update for diagnostic_t becoming + enum class diagnostics::kind. + * error.cc: Likewise. + * options.cc: Likewise. + +2025-07-25 David Malcolm <dmalcolm@redhat.com> + + * cpp.cc: Update for renaming of + diagnostic_option_id to diagnostics::option_id. + +2025-07-25 David Malcolm <dmalcolm@redhat.com> + + * error.cc: Update for move of diagnostic-color.h to + diagnostics/color.h. + +2025-07-25 David Malcolm <dmalcolm@redhat.com> + + * error.cc: Update for diagnostic_context becoming + diagnostics::context. + +2025-07-25 David Malcolm <dmalcolm@redhat.com> + + * error.cc: Update to add "m_" prefix to fields of + diagnostic_info throughout. + +2025-07-25 David Malcolm <dmalcolm@redhat.com> + + * error.cc: Update for move of diagnostics output formats into + namespace "diagnostics" as "sinks". + * gfortran.h: Likewise. + +2025-07-23 Harald Anlauf <anlauf@gmx.de> + + PR fortran/121203 + * trans-expr.cc (gfc_conv_procedure_call): Obtain the character + length of an assumed character length procedure from the typespec + of the actual argument even if there is no explicit interface. + +2025-07-21 Mikael Morin <mikael@gcc.gnu.org> + + * trans-decl.cc (gfc_trans_deferred_vars): Fix indentation. + +2025-07-21 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/119106 + * expr.cc (simplify_constructor): Do not simplify constants. + (gfc_simplify_expr): Continue to simplify expression when an + iterator is present. + +2025-07-21 Mikael Morin <mikael@gcc.gnu.org> + + * trans-array.cc (gfc_conv_ss_descriptor): Move the descriptor + expression initialisation... + (set_factored_descriptor_value): ... to this new function. + Before initialisation, walk the reference expression passed as + argument and save some of its subexpressions to a variable. + (substitute_t): New struct. + (maybe_substitute_expr): New function. + (substitute_subexpr_in_expr): New function. + +2025-07-18 Harald Anlauf <anlauf@gmx.de> + + PR fortran/121145 + * trans-expr.cc (gfc_conv_procedure_call): Do not create pointer + check for proc-pointer actual passed to optional dummy. + +2025-07-16 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/121060 + * interface.cc (matching_typebound_op): Defer determination of + specific procedure until resolution by returning NULL. + +2025-07-16 Steve Kargl <sgk@troutmask.apl.washington.edu> + + * decl.cc (gfc_match_import): Correct minor whitespace snafu + and fix NULL pointer dereferences in two places. + +2025-07-15 Kwok Cheung Yeung <kcyeung@baylibre.com> + + PR fortran/104428 + * trans-openmp.cc (gfc_trans_omp_declare_variant): Check that proc_st + is non-NULL before dereferencing. Add line number to error message. + +2025-07-15 Mikael Morin <mikael@gcc.gnu.org> + + * gfortran.h (gfc_symbol): Remove field allocated_in_scope. + * trans-array.cc (gfc_array_allocate): Don't set it. + (gfc_alloc_allocatable_for_assignment): Likewise. + Generate the unallocated descriptor bounds initialisation + before the opening of the reallocation code block. Create a + variable and use it as additional condition to the unallocated + descriptor bounds initialisation. + +2025-07-15 Mikael Morin <mikael@gcc.gnu.org> + + * trans-array.cc (gfc_conv_ss_descriptor): Don't evaluate + offset and data to a variable if is_alloc_lhs is set. Move the + existing evaluation decision condition for data... + (save_descriptor_data): ... here as a new predicate. + (evaluate_bound): Add argument save_value. Omit the evaluation + of the value to a variable if that argument isn't set. + (gfc_conv_expr_descriptor): Update caller. + (gfc_conv_section_startstride): Update caller. Set save_value + if is_alloc_lhs is not set. Omit the evaluation of stride to a + variable if save_value isn't set. + (gfc_set_delta): Omit the evaluation of delta to a variable + if is_alloc_lhs is set. + (gfc_is_reallocatable_lhs): Return false if flag_realloc_lhs + isn't set. + (gfc_alloc_allocatable_for_assignment): Don't update + the variables that may be stored in saved_offset, delta, and + data. Call instead... + (update_reallocated_descriptor): ... this new procedure. + * trans-expr.cc (gfc_trans_assignment_1): Don't omit setting the + is_alloc_lhs flag if the right hand side is an intrinsic + function. Clear the flag if the right hand side is scalar. + +2025-07-15 Mikael Morin <mikael@gcc.gnu.org> + + * trans-expr.cc (gfc_trans_assignment_1): Generate array + reallocation code before entering the scalarisation loops. + +2025-07-15 Filip Kastl <fkastl@suse.cz> + + * resolve.cc (resolve_select_type): Fix indentation. + +2025-07-12 Tobias Burnus <tburnus@baylibre.com> + + * invoke.texi (-Wsurprising): Note about OpenACC warning + related to PARAMATER. + * openmp.cc (resolve_omp_clauses, gfc_resolve_oacc_declare): + Accept PARAMETER for OpenACC but add surprising warning. + * trans-openmp.cc (gfc_trans_omp_variable_list, + gfc_trans_omp_clauses): Ignore PARAMETER inside clauses. + +2025-07-11 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/106035 + * decl.cc (build_sym): Emit an error if a symbol associated by + an IMPORT, ONLY or IMPORT, all statement is being redeclared. + (gfc_match_import): Parse and check the F2018 versions of the + IMPORT statement. For scopes other than and interface body, if + the symbol cannot be found in the host scope, generate it and + set it up such that gfc_fixup_sibling_symbols can transfer its + 'imported attribute' if it turnes out to be a not yet parsed + procedure. Test for violations of C897-8100. + * gfortran.h : Add 'import_only' to the gfc_symtree structure. + Add the enum, 'importstate', which is used for values the new + field 'import_state' in gfc_namespace. + * parse.cc (gfc_fixup_sibling_symbols): Transfer the attribute + 'imported' to the new symbol. + * resolve.cc (check_sym_import_status, check_import_status): + New functions to test symbols and expressions for violations of + F2018:C8102. + (resolve_call): Test the 'resolved_sym' against C8102 by a call + to 'check_sym_import_status'. + (gfc_resolve_expr): If the expression is OK and an IMPORT + statement has been registered in the current scope, test C102 + by calling 'check_import_status'. + (resolve_select_type): Test the declared derived type in TYPE + IS and CLASS IS statements. + +2025-07-08 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/120637 + * class.cc (finalize_component): Return true, when a finalizable + component was detect and do not free it. + +2025-07-07 Mikael Morin <mikael@gcc.gnu.org> + + * trans-intrinsic.cc (conv_intrinsic_move_alloc): Add pre and + post code for the FROM and TO arguments. + +2025-07-04 Martin Jambor <mjambor@suse.cz> + + * io.cc (format_asterisk): Add a brace around static initialization + location part of the field locus. + +2025-07-03 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/120843 + * resolve.cc (resolve_operator): Remove conformability check, + because it is not in the standard. + +2025-07-01 Harald Anlauf <anlauf@gmx.de> + + * coarray.cc (check_add_new_component): Treat pure and elemental + intrinsic functions the same as non-intrinsic ones. + (create_caf_add_data_parameter_type): Fix front-end memleaks. + * trans-intrinsic.cc (conv_caf_func_index): Likewise. + +2025-07-01 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/120847 + * coarray.cc (check_add_new_comp_handle_array): Make the count + of components static to be able to create more than one. Create + an array component only for array expressions. + +2025-07-01 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/120843 + * resolve.cc (resolve_operator): Report inconsistent coranks + only when not referencing this_image. + (gfc_op_rank_conformable): Treat coranks as inconformable only + when a coindex other then implicit this_image is used. + +2025-06-27 Harald Anlauf <anlauf@gmx.de> + + PR fortran/120784 + * interface.cc (gfc_match_end_interface): Detect empty local_name. + +2025-06-26 Martin Jambor <mjambor@suse.cz> + + * match.cc (gfc_match_nullify): Initialize p to NULL; + +2025-06-26 Andre Vehreschild <vehre@gcc.gnu.org> + + * trans.cc (gfc_allocate_using_malloc): Prevent possible memory + leak when allocation was already done. + +2025-06-26 Andre Vehreschild <vehre@gcc.gnu.org> + + * resolve.cc (resolve_fl_derived0): Do not create the token + component when not in coarray lib mode. + * trans-types.cc: Do not access the token when not in coarray + lib mode. + +2025-06-26 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/120711 + * trans-array.cc (gfc_trans_array_ctor_element): Store the value + of the offset for reuse. + +2025-06-24 Tobias Burnus <tburnus@baylibre.com> + + * trans-stmt.cc (gfc_trans_call_acc_attach_detach): New. + (gfc_trans_call): Call it. + +2025-06-24 Harald Anlauf <anlauf@gmx.de> + Jerry DeLisle <jvdelisle@gcc.gnu.org> + Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/120743 + * trans-expr.cc (gfc_conv_substring): Substring indices are of + type gfc_charlen_type_node. Convert to size_type_node for + pointer arithmetic only after offset adjustments have been made. + +2025-06-24 Mikael Morin <morin-mikael@orange.fr> + + * misc.cc (gfc_var_name_for_select_type_temp): New function. + * gfortran.h (gfc_var_name_for_select_type_temp): Declare it. + * resolve.cc (resolve_select_type): Pick a discriminating name + from the SELECT TYPE variable reference and use it in the name + of the temporary variable that is generated. Truncate name to + the buffer size. + * match.cc (select_type_set_tmp): Likewise. Pass the + discriminating name... + (select_intrinsic_set_tmp): ... to this function. Use the + discriminating name likewise. Augment the buffer size to match + that of select_type_set_tmp and resolve_select_type. + +2025-06-23 Tobias Burnus <tburnus@baylibre.com> + + * openmp.cc (OACC_WAIT_CLAUSES): Add if clause. + * trans-openmp.cc (gfc_trans_oacc_wait_directive): Handle it. + +2025-06-23 Harald Anlauf <anlauf@gmx.de> + + PR fortran/120784 + * interface.cc (gfc_match_end_interface): If a use-associated + symbol is renamed, use the local_name for checking. + +2025-06-19 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/120713 + * trans-array.cc (gfc_trans_deferred_array): Statically + initialize deferred length variable for SAVEd character arrays. + +2025-06-18 Harald Anlauf <anlauf@gmx.de> + + PR fortran/82480 + * check.cc (gfc_check_fstat): Extend checks to INTENT(OUT) arguments. + (gfc_check_fstat_sub): Likewise. + (gfc_check_stat): Likewise. + (gfc_check_stat_sub): Likewise. + * intrinsic.texi: Adjust documentation. + +2025-06-16 Harald Anlauf <anlauf@gmx.de> + + PR fortran/51961 + * resolve.cc (conformable_arrays): Use modified rank check when + MOLD= expression is given. + +2025-06-12 Yuao Ma <c8ef@outlook.com> + Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/113152 + * intrinsic.texi: Document new half-revolution trigonometric + functions. Reorder doc for atand. + +2025-06-06 Tobias Burnus <tburnus@baylibre.com> + Sandra Loosemore <sloosemore@baylibre.com> + + * f95-lang.cc (ATTR_PURE_NOTHROW_LIST): Define. + * trans-expr.cc (get_builtin_fn): Handle omp_get_num_devices + and omp_get_intrinsic_device. + * gfortran.h (gfc_option_t): Add disable_omp_... for them. + * options.cc (gfc_handle_option): Handle them with + -fno-builtin-. + +2025-06-04 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/120483 + * trans-expr.cc (gfc_conv_substring): Use pointer arithmetic on + static allocatable char arrays. + +2025-06-03 Harald Anlauf <anlauf@gmx.de> + + PR fortran/99838 + * data.cc (gfc_assign_data_value): For a new initializer use the + location from the constructor as fallback. + +2025-05-30 Harald Anlauf <anlauf@gmx.de> + + PR fortran/102599 + PR fortran/114022 + * expr.cc (simplify_complex_array_inquiry_ref): Helper function for + simplification of inquiry references (%re/%im) of constant complex + arrays. + (find_inquiry_ref): Use it for handling %re/%im inquiry references + of complex arrays. + (scalarize_intrinsic_call): Fix frontend memleak. + * primary.cc (gfc_match_varspec): When the reference is NULL, the + previous simplification has succeeded in evaluating inquiry + references also of arrays. + +2025-05-30 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/120355 + * interface.cc (compare_parameter): If the global function has a + result clause, take typespec from there for the comparison against + the dummy argument. + +2025-05-30 Julian Brown <julian@codesourcery.com> + Tobias Burnus <tburnus@baylibre.com> + + * parse.cc (tree.h, fold-const.h, tree-hash-traits.h): Add includes + (for additions to omp-general.h). + +2025-05-29 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/120049 + * check.cc(check_c_ptr_2): Rephrase error message + for clarity. + +2025-05-28 Tobias Burnus <tburnus@baylibre.com> + + PR fortran/113152 + * simplify.cc (gfc_simplify_cospi, gfc_simplify_sinpi): Avoid using + mpfr_fmod_ui in the MPFR < 4.2.0 version. + +2025-05-28 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/119856 + * io.cc: Set missing comma error checks to STD_STD_LEGACY. + +2025-05-28 Yuao Ma <c8ef@outlook.com> + Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/113152 + * gfortran.h (enum gfc_isym_id): Add new enum. + * intrinsic.cc (add_functions): Register new intrinsics. Changing the call + from gfc_resolve_trigd{,2} to gfc_resolve_trig{,2}. + * intrinsic.h (gfc_simplify_acospi, gfc_simplify_asinpi, + gfc_simplify_asinpi, gfc_simplify_atanpi, gfc_simplify_atan2pi, + gfc_simplify_cospi, gfc_simplify_sinpi, gfc_simplify_tanpi): New. + (gfc_resolve_trig): Rename from gfc_resolve_trigd. + (gfc_resolve_trig2): Rename from gfc_resolve_trigd2. + * iresolve.cc (gfc_resolve_trig): Rename from gfc_resolve_trigd. + (gfc_resolve_trig2): Rename from gfc_resolve_trigd2. + * mathbuiltins.def: Add 7 new math builtins and re-align. + * simplify.cc (gfc_simplify_acos, gfc_simplify_asin, + gfc_simplify_acosd, gfc_simplify_asind): Revise error message. + (gfc_simplify_acospi, gfc_simplify_asinpi, + gfc_simplify_asinpi, gfc_simplify_atanpi, gfc_simplify_atan2pi, + gfc_simplify_cospi, gfc_simplify_sinpi, gfc_simplify_tanpi): New. + +2025-05-27 Harald Anlauf <anlauf@gmx.de> + + PR fortran/101735 + * primary.cc (gfc_match_varspec): Correct order of logic. + +2025-05-27 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/120049 + * check.cc (gfc_check_c_associated): Use new helper functions. + Only call check_c_ptr_1 if optional c_ptr_2 tests succeed. + (check_c_ptr_1): Handle only c_ptr_1 checks. + (check_c_ptr_2): Expand checks for c_ptr_2 and handle cases + where there is no derived pointer in the gfc_expr and check + the inmod_sym_id only if it exists. + * misc.cc (gfc_typename): Handle the case for BT_VOID rather + than throw an internal error. + +2025-05-27 Harald Anlauf <anlauf@gmx.de> + + PR fortran/101735 + * expr.cc (find_inquiry_ref): If an inquiry reference applies to + a substring, use that, and calculate substring length if needed. + * primary.cc (extend_ref): Also handle attaching to end of + reference chain for appending. + (gfc_match_varspec): Discrimate between arrays of character and + substrings of them. If a substring is taken from a character + component of a derived type, get the proper typespec so that + inquiry references work correctly. + (gfc_match_rvalue): Handle corner case where we hit a seemingly + dangling '%' and missed an inquiry reference. Try another match. + +2025-05-27 David Malcolm <dmalcolm@redhat.com> + + PR other/116792 + * error.cc (gfc_diagnostic_start_span): Update for diagnostic.h + changes. + +2025-05-19 Harald Anlauf <anlauf@gmx.de> + + PR fortran/120099 + * trans-types.cc (gfc_return_by_reference): Intrinsic functions + returning complex numbers may return their result by reference + with -ff2c. + +2025-05-15 Harald Anlauf <anlauf@gmx.de> + + PR fortran/85750 + * resolve.cc (resolve_symbol): Reorder conditions when to apply + default-initializers. + +2025-05-15 Tobias Burnus <tburnus@baylibre.com> + + * trans-openmp.cc (gfc_omp_deep_mapping_do): Handle SSA_NAME if + a def_stmt is available. + +2025-05-14 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/120139 + * dump-parse-tree.cc (get_c_type_name): If no constant + size of an array exists, output an asterisk. + +2025-05-14 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/120107 + * dump-parse-tree.cc (write_type): Do not dump non-interoperable + types. + +2025-05-14 Tobias Burnus <tburnus@baylibre.com> + + PR fortran/120225 + * simplify.cc (gfc_simplify_cotand): Fix used argument in + mpfr_tanu call. + +2025-05-14 Tobias Burnus <tburnus@baylibre.com> + + PR fortran/120225 + * simplify.cc: Include "trigd_fe.inc" only with MPFR < 4.2.0. + (rad2deg, rad2deg): Only define if MPFR < 4.2.0. + (gfc_simplify_acosd, gfc_simplify_asind, gfc_simplify_atand, + gfc_simplify_atan2d, gfc_simplify_cosd, gfc_simplify_tand, + gfc_simplify_cotand): Use mpfr_...u functions with MPFR >= 4.2.0. + +2025-05-13 Yuao Ma <c8ef@outlook.com> + Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/113413 + * intrinsic.cc (do_check): Minor doc polish. + (add_functions): Add atand(y, x) mapping. + * intrinsic.texi: Update atand example. + +2025-05-13 Jakub Jelinek <jakub@redhat.com> + Daniil Kochergin <daniil2472s@gmail.com> + Tobias Burnus <tburnus@baylibre.com> + + PR fortran/120191 + * trans-intrinsic.cc (strip_kind_from_actual): Remove. + (gfc_conv_intrinsic_minmaxloc): Don't call strip_kind_from_actual. + Free and clear kind_arg->expr if non-NULL. Set back_arg->name to + "%VAL" instead of a loop looking for last argument. Remove actual + variable, use array_arg instead. Free and clear dim_arg->expr if + non-NULL for BT_CHARACTER cases instead of using a loop. + 2025-05-11 Thomas Koenig <tkoenig@gcc.gnu.org> PR fortran/120163 diff --git a/gcc/fortran/array.cc b/gcc/fortran/array.cc index fa177fa..8f00049 100644 --- a/gcc/fortran/array.cc +++ b/gcc/fortran/array.cc @@ -566,6 +566,7 @@ match_array_element_spec (gfc_array_spec *as) gfc_expr **upper, **lower; match m; int rank; + bool is_pdt_template; rank = as->rank == -1 ? 0 : as->rank; lower = &as->lower[rank + as->corank - 1]; @@ -613,6 +614,13 @@ match_array_element_spec (gfc_array_spec *as) return AS_UNKNOWN; } + is_pdt_template = gfc_current_block () + && gfc_current_block ()->attr.pdt_template + && gfc_current_block ()->f2k_derived; + + if ((*upper)->expr_type != EXPR_CONSTANT && is_pdt_template) + gfc_correct_parm_expr (gfc_current_block (), upper); + if (gfc_match_char (':') == MATCH_NO) { *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); @@ -645,6 +653,9 @@ match_array_element_spec (gfc_array_spec *as) return AS_UNKNOWN; } + if ((*upper)->expr_type != EXPR_CONSTANT && is_pdt_template) + gfc_correct_parm_expr (gfc_current_block (), upper); + return AS_EXPLICIT; } diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc index f02a2a3..1f17013 100644 --- a/gcc/fortran/check.cc +++ b/gcc/fortran/check.cc @@ -1107,6 +1107,36 @@ kind_value_check (gfc_expr *e, int n, int k) } +/* Error message for an actual argument with an unsupported kind value. */ + +static void +error_unsupported_kind (gfc_expr *e, int n) +{ + gfc_error ("Not supported: %qs argument of %qs intrinsic at %L with kind %d", + gfc_current_intrinsic_arg[n]->name, + gfc_current_intrinsic, &e->where, e->ts.kind); + return; +} + + +/* Check if the decimal exponent range of an integer variable is at least four + so that it is large enough to e.g. hold errno values and the values of + LIBERROR_* from libgfortran.h. */ + +static bool +check_minrange4 (gfc_expr *e, int n) +{ + if (e->ts.kind >= 2) + return true; + + gfc_error ("%qs argument of %qs intrinsic at %L must have " + "a decimal exponent range of at least four", + gfc_current_intrinsic_arg[n]->name, + gfc_current_intrinsic, &e->where); + return false; +} + + /* Make sure an expression is a variable. */ static bool @@ -5559,6 +5589,27 @@ gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind) return true; } +bool +gfc_check_split (gfc_expr *string, gfc_expr *set, gfc_expr *pos, gfc_expr *back) +{ + if (!type_check (string, 0, BT_CHARACTER)) + return false; + + if (!type_check (set, 1, BT_CHARACTER)) + return false; + + if (!type_check (pos, 2, BT_INTEGER) || !scalar_check (pos, 2)) + return false; + + if (back != NULL + && (!type_check (back, 3, BT_LOGICAL) || !scalar_check (back, 3))) + return false; + + if (!same_type_check (string, 0, set, 1)) + return false; + + return true; +} bool gfc_check_secnds (gfc_expr *r) @@ -5952,54 +6003,116 @@ gfc_check_c_sizeof (gfc_expr *arg) } -bool -gfc_check_c_associated (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2) +/* Helper functions check_c_ptr_1 and check_c_ptr_2 + used in gfc_check_c_associated. */ + +static inline +bool check_c_ptr_1 (gfc_expr *c_ptr_1) { - if (c_ptr_1) - { - if (c_ptr_1->expr_type == EXPR_FUNCTION && c_ptr_1->ts.type == BT_VOID) - return true; + if ((c_ptr_1->ts.type == BT_VOID) + && (c_ptr_1->expr_type == EXPR_FUNCTION)) + return true; - if (c_ptr_1->ts.type != BT_DERIVED - || c_ptr_1->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING - || (c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR - && c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR)) - { - gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the " - "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1->where); - return false; - } - } + if (c_ptr_1->ts.type != BT_DERIVED + || c_ptr_1->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING + || (c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR + && c_ptr_1->ts.u.derived->intmod_sym_id != ISOCBINDING_FUNPTR)) + goto check_1_error; + + if ((c_ptr_1->ts.type == BT_DERIVED) + && (c_ptr_1->expr_type == EXPR_STRUCTURE) + && (c_ptr_1->ts.u.derived->intmod_sym_id + == ISOCBINDING_NULL_FUNPTR)) + goto check_1_error; - if (!scalar_check (c_ptr_1, 0)) + if (scalar_check (c_ptr_1, 0)) + return true; + else + /* Return since the check_1_error message may not apply here. */ return false; - if (c_ptr_2) - { - if (c_ptr_2->expr_type == EXPR_FUNCTION && c_ptr_2->ts.type == BT_VOID) - return true; +check_1_error: - if (c_ptr_2->ts.type != BT_DERIVED - || c_ptr_2->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING - || (c_ptr_1->ts.u.derived->intmod_sym_id - != c_ptr_2->ts.u.derived->intmod_sym_id)) + gfc_error ("Argument C_PTR_1 at %L to C_ASSOCIATED shall have the " + "type TYPE(C_PTR) or TYPE(C_FUNPTR)", &c_ptr_1->where); + return false; +} + +static inline +bool check_c_ptr_2 (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2) +{ + switch (c_ptr_2->ts.type) + { + case BT_VOID: + if (c_ptr_2->expr_type == EXPR_FUNCTION) { - gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the " - "same type as C_PTR_1: %s instead of %s", &c_ptr_1->where, - gfc_typename (&c_ptr_1->ts), gfc_typename (&c_ptr_2->ts)); - return false; + if ((c_ptr_1->ts.type == BT_DERIVED) + && c_ptr_1->expr_type == EXPR_STRUCTURE + && (c_ptr_1->ts.u.derived->intmod_sym_id + == ISOCBINDING_FUNPTR)) + goto check_2_error; } - } + break; - if (c_ptr_2 && !scalar_check (c_ptr_2, 1)) + case BT_DERIVED: + if ((c_ptr_2->expr_type == EXPR_STRUCTURE) + && (c_ptr_2->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR) + && (c_ptr_1->ts.type == BT_VOID) + && (c_ptr_1->expr_type == EXPR_FUNCTION)) + return scalar_check (c_ptr_2, 1); + + if ((c_ptr_2->expr_type == EXPR_STRUCTURE) + && (c_ptr_1->ts.type == BT_VOID) + && (c_ptr_1->expr_type == EXPR_FUNCTION)) + goto check_2_error; + + if (c_ptr_2->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING) + goto check_2_error; + + if (c_ptr_1->ts.type == BT_DERIVED + && (c_ptr_1->ts.u.derived->intmod_sym_id + != c_ptr_2->ts.u.derived->intmod_sym_id)) + goto check_2_error; + break; + + default: + goto check_2_error; + } + + if (scalar_check (c_ptr_2, 1)) + return true; + else + /* Return since the check_2_error message may not apply here. */ return false; - return true; +check_2_error: + + gfc_error ("Argument C_PTR_2 at %L to C_ASSOCIATED shall have the " + "same type as C_PTR_1, found %s instead of %s", &c_ptr_2->where, + gfc_typename (&c_ptr_2->ts), gfc_typename (&c_ptr_1->ts)); + + return false; + } + + +bool +gfc_check_c_associated (gfc_expr *c_ptr_1, gfc_expr *c_ptr_2) +{ + if (c_ptr_2) + { + if (check_c_ptr_2 (c_ptr_1, c_ptr_2)) + return check_c_ptr_1 (c_ptr_1); + else + return false; + } + else + return check_c_ptr_1 (c_ptr_1); } bool -gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr, gfc_expr *shape) +gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr, gfc_expr *shape, + gfc_expr *lower) { symbol_attribute attr; const char *msg; @@ -6074,6 +6187,43 @@ gfc_check_c_f_pointer (gfc_expr *cptr, gfc_expr *fptr, gfc_expr *shape) } } + if (lower + && !gfc_notify_std (GFC_STD_F2023, "LOWER argument at %L to C_F_POINTER", + &lower->where)) + return false; + + if (!shape && lower) + { + gfc_error ("Unexpected LOWER argument at %L to C_F_POINTER " + "with scalar FPTR", + &lower->where); + return false; + } + + if (lower && !rank_check (lower, 3, 1)) + return false; + + if (lower && !type_check (lower, 3, BT_INTEGER)) + return false; + + if (lower) + { + mpz_t size; + if (gfc_array_size (lower, &size)) + { + if (mpz_cmp_ui (size, fptr->rank) != 0) + { + mpz_clear (size); + gfc_error ( + "LOWER argument at %L to C_F_POINTER must have the same " + "size as the RANK of FPTR", + &lower->where); + return false; + } + mpz_clear (size); + } + } + if (fptr->ts.type == BT_CLASS) { gfc_error ("Polymorphic FPTR at %L to C_F_POINTER", &fptr->where); @@ -6446,7 +6596,7 @@ gfc_check_fseek_sub (gfc_expr *unit, gfc_expr *offset, gfc_expr *whence, gfc_exp bool -gfc_check_fstat (gfc_expr *unit, gfc_expr *array) +gfc_check_fstat (gfc_expr *unit, gfc_expr *values) { if (!type_check (unit, 0, BT_INTEGER)) return false; @@ -6454,11 +6604,22 @@ gfc_check_fstat (gfc_expr *unit, gfc_expr *array) if (!scalar_check (unit, 0)) return false; - if (!type_check (array, 1, BT_INTEGER) - || !kind_value_check (unit, 0, gfc_default_integer_kind)) + if (!type_check (values, 1, BT_INTEGER)) return false; - if (!array_check (array, 1)) + if (values->ts.kind != 4 && values->ts.kind != 8) + { + error_unsupported_kind (values, 1); + return false; + } + + if (!array_check (values, 1)) + return false; + + if (!variable_check (values, 1, false)) + return false; + + if (!array_size_check (values, 1, 13)) return false; return true; @@ -6466,31 +6627,24 @@ gfc_check_fstat (gfc_expr *unit, gfc_expr *array) bool -gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *array, gfc_expr *status) +gfc_check_fstat_sub (gfc_expr *unit, gfc_expr *values, gfc_expr *status) { - if (!type_check (unit, 0, BT_INTEGER)) - return false; - - if (!scalar_check (unit, 0)) - return false; - - if (!type_check (array, 1, BT_INTEGER) - || !kind_value_check (array, 1, gfc_default_integer_kind)) - return false; - - if (!array_check (array, 1)) + if (!gfc_check_fstat (unit, values)) return false; if (status == NULL) return true; if (!type_check (status, 2, BT_INTEGER) - || !kind_value_check (status, 2, gfc_default_integer_kind)) + || !check_minrange4 (status, 2)) return false; if (!scalar_check (status, 2)) return false; + if (!variable_check (status, 2, false)) + return false; + return true; } @@ -6528,18 +6682,29 @@ gfc_check_ftell_sub (gfc_expr *unit, gfc_expr *offset) bool -gfc_check_stat (gfc_expr *name, gfc_expr *array) +gfc_check_stat (gfc_expr *name, gfc_expr *values) { if (!type_check (name, 0, BT_CHARACTER)) return false; if (!kind_value_check (name, 0, gfc_default_character_kind)) return false; - if (!type_check (array, 1, BT_INTEGER) - || !kind_value_check (array, 1, gfc_default_integer_kind)) + if (!type_check (values, 1, BT_INTEGER)) return false; - if (!array_check (array, 1)) + if (values->ts.kind != 4 && values->ts.kind != 8) + { + error_unsupported_kind (values, 1); + return false; + } + + if (!array_check (values, 1)) + return false; + + if (!variable_check (values, 1, false)) + return false; + + if (!array_size_check (values, 1, 13)) return false; return true; @@ -6547,30 +6712,24 @@ gfc_check_stat (gfc_expr *name, gfc_expr *array) bool -gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status) +gfc_check_stat_sub (gfc_expr *name, gfc_expr *values, gfc_expr *status) { - if (!type_check (name, 0, BT_CHARACTER)) - return false; - if (!kind_value_check (name, 0, gfc_default_character_kind)) - return false; - - if (!type_check (array, 1, BT_INTEGER) - || !kind_value_check (array, 1, gfc_default_integer_kind)) - return false; - - if (!array_check (array, 1)) + if (!gfc_check_stat (name, values)) return false; if (status == NULL) return true; if (!type_check (status, 2, BT_INTEGER) - || !kind_value_check (array, 1, gfc_default_integer_kind)) + || !check_minrange4 (status, 2)) return false; if (!scalar_check (status, 2)) return false; + if (!variable_check (status, 2, false)) + return false; + return true; } diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc index df18601..a1c6faf 100644 --- a/gcc/fortran/class.cc +++ b/gcc/fortran/class.cc @@ -1034,7 +1034,7 @@ comp_is_finalizable (gfc_component *comp) of calling the appropriate finalizers, coarray deregistering, and deallocation of allocatable subcomponents. */ -static void +static bool finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp, gfc_symbol *stat, gfc_symbol *fini_coarray, gfc_code **code, gfc_namespace *sub_ns) @@ -1044,14 +1044,14 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp, gfc_was_finalized *f; if (!comp_is_finalizable (comp)) - return; + return false; /* If this expression with this component has been finalized already in this namespace, there is nothing to do. */ for (f = sub_ns->was_finalized; f; f = f->next) { if (f->e == expr && f->c == comp) - return; + return false; } e = gfc_copy_expr (expr); @@ -1208,8 +1208,6 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp, final_wrap->ext.actual->next->next = gfc_get_actual_arglist (); final_wrap->ext.actual->next->next->expr = fini_coarray_expr; - - if (*code) { (*code)->next = final_wrap; @@ -1221,11 +1219,14 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp, else { gfc_component *c; + bool ret = false; for (c = comp->ts.u.derived->components; c; c = c->next) - finalize_component (e, comp->ts.u.derived, c, stat, fini_coarray, code, - sub_ns); - gfc_free_expr (e); + ret |= finalize_component (e, comp->ts.u.derived, c, stat, fini_coarray, + code, sub_ns); + /* Only free the expression, if it has never been used. */ + if (!ret) + gfc_free_expr (e); } /* Record that this was finalized already in this namespace. */ @@ -1234,6 +1235,7 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp, sub_ns->was_finalized->e = expr; sub_ns->was_finalized->c = comp; sub_ns->was_finalized->next = f; + return true; } @@ -2314,6 +2316,7 @@ finish_assumed_rank: { gfc_symbol *stat; gfc_code *block = NULL; + gfc_expr *ptr_expr; if (!ptr) { @@ -2359,14 +2362,15 @@ finish_assumed_rank: sub_ns); block = block->next; + ptr_expr = gfc_lval_expr_from_sym (ptr); for (comp = derived->components; comp; comp = comp->next) { if (comp == derived->components && derived->attr.extension && ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL) continue; - finalize_component (gfc_lval_expr_from_sym (ptr), derived, comp, - stat, fini_coarray, &block, sub_ns); + finalize_component (ptr_expr, derived, comp, stat, fini_coarray, + &block, sub_ns); if (!last_code->block->next) last_code->block->next = block; } diff --git a/gcc/fortran/coarray.cc b/gcc/fortran/coarray.cc index 2f067f8..ef8fd4e 100644 --- a/gcc/fortran/coarray.cc +++ b/gcc/fortran/coarray.cc @@ -503,7 +503,7 @@ check_add_new_comp_handle_array (gfc_expr *e, gfc_symbol *type, gfc_symbol *add_data) { gfc_component *comp; - int cnt = -1; + static int cnt = -1; gfc_symtree *caller_image; gfc_code *pre_code = caf_accessor_prepend; bool static_array_or_scalar = true; @@ -566,7 +566,7 @@ check_add_new_comp_handle_array (gfc_expr *e, gfc_symbol *type, else { comp->initializer = gfc_copy_expr (e); - if (e_attr.dimension) + if (e_attr.dimension && e->rank) { comp->attr.dimension = 1; comp->as = get_arrayspec_from_expr (e); @@ -697,7 +697,10 @@ check_add_new_component (gfc_symbol *type, gfc_expr *e, gfc_symbol *add_data) break; case EXPR_FUNCTION: if (!e->symtree->n.sym->attr.pure - && !e->symtree->n.sym->attr.elemental) + && !e->symtree->n.sym->attr.elemental + && !(e->value.function.isym + && (e->value.function.isym->pure + || e->value.function.isym->elemental))) /* Treat non-pure/non-elemental functions. */ check_add_new_comp_handle_array (e, type, add_data); else @@ -743,7 +746,6 @@ create_caf_add_data_parameter_type (gfc_expr *expr, gfc_namespace *ns, add_data->as->lower[0] = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, &expr->where); - mpz_init (add_data->as->lower[0]->value.integer); mpz_set_si (add_data->as->lower[0]->value.integer, 1); for (gfc_ref *ref = expr->ref; ref; ref = ref->next) @@ -763,6 +765,7 @@ create_caf_add_data_parameter_type (gfc_expr *expr, gfc_namespace *ns, type->declared_at = expr->where; gfc_set_sym_referenced (type); gfc_commit_symbol (type); + free (name); return type; } diff --git a/gcc/fortran/cpp.cc b/gcc/fortran/cpp.cc index 1b70420..15ecc7d 100644 --- a/gcc/fortran/cpp.cc +++ b/gcc/fortran/cpp.cc @@ -1063,7 +1063,7 @@ cb_used_define (cpp_reader *pfile, location_t line ATTRIBUTE_UNUSED, /* Return the gcc option code associated with the reason for a cpp message, or 0 if none. */ -static diagnostic_option_id +static diagnostics::option_id cb_cpp_diagnostic_cpp_option (enum cpp_warning_reason reason) { const struct cpp_reason_option_codes_t *entry; @@ -1088,8 +1088,8 @@ cb_cpp_diagnostic (cpp_reader *pfile ATTRIBUTE_UNUSED, rich_location *richloc, const char *msg, va_list *ap) { - diagnostic_info diagnostic; - diagnostic_t dlevel; + diagnostics::diagnostic_info diagnostic; + enum diagnostics::kind dlevel; bool save_warn_system_headers = global_dc->m_warn_system_headers; bool ret; @@ -1099,22 +1099,22 @@ cb_cpp_diagnostic (cpp_reader *pfile ATTRIBUTE_UNUSED, global_dc->m_warn_system_headers = 1; /* Fall through. */ case CPP_DL_WARNING: - dlevel = DK_WARNING; + dlevel = diagnostics::kind::warning; break; case CPP_DL_PEDWARN: - dlevel = DK_PEDWARN; + dlevel = diagnostics::kind::pedwarn; break; case CPP_DL_ERROR: - dlevel = DK_ERROR; + dlevel = diagnostics::kind::error; break; case CPP_DL_ICE: - dlevel = DK_ICE; + dlevel = diagnostics::kind::ice; break; case CPP_DL_NOTE: - dlevel = DK_NOTE; + dlevel = diagnostics::kind::note; break; case CPP_DL_FATAL: - dlevel = DK_FATAL; + dlevel = diagnostics::kind::fatal; break; default: gcc_unreachable (); diff --git a/gcc/fortran/data.cc b/gcc/fortran/data.cc index 5c83f69..a438c26 100644 --- a/gcc/fortran/data.cc +++ b/gcc/fortran/data.cc @@ -593,7 +593,13 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index, { /* Point the container at the new expression. */ if (last_con == NULL) - symbol->value = expr; + { + symbol->value = expr; + /* For a new initializer use the location from the + constructor as fallback. */ + if (!GFC_LOCUS_IS_SET(expr->where) && con != NULL) + symbol->value->where = con->where; + } else last_con->expr = expr; } diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc index 69acd2d..5da3c26 100644 --- a/gcc/fortran/decl.cc +++ b/gcc/fortran/decl.cc @@ -1723,13 +1723,17 @@ build_sym (const char *name, int elem, gfc_charlen *cl, bool cl_deferred, symbol_attribute attr; gfc_symbol *sym; int upper; - gfc_symtree *st; + gfc_symtree *st, *host_st = NULL; /* Symbols in a submodule are host associated from the parent module or submodules. Therefore, they can be overridden by declarations in the submodule scope. Deal with this by attaching the existing symbol to a new symtree and recycling the old symtree with a new symbol... */ st = gfc_find_symtree (gfc_current_ns->sym_root, name); + if (((st && st->import_only) || (gfc_current_ns->import_state == IMPORT_ALL)) + && gfc_current_ns->parent) + host_st = gfc_find_symtree (gfc_current_ns->parent->sym_root, name); + if (st != NULL && gfc_state_stack->state == COMP_SUBMODULE && st->n.sym != NULL && st->n.sym->attr.host_assoc && st->n.sym->attr.used_in_submodule) @@ -1742,6 +1746,20 @@ build_sym (const char *name, int elem, gfc_charlen *cl, bool cl_deferred, sym->refs++; gfc_set_sym_referenced (sym); } + /* ...Check that F2018 IMPORT, ONLY and IMPORT, ALL statements, within the + current scope are not violated by local redeclarations. Note that there is + no need to guard for std >= F2018 because import_only and IMPORT_ALL are + only set for these standards. */ + else if (host_st && host_st->n.sym + && host_st->n.sym != gfc_current_ns->proc_name + && !(st && st->n.sym + && (st->n.sym->attr.dummy || st->n.sym->attr.result))) + { + gfc_error ("F2018: C8102 %s at %L is already imported by an %s " + "statement and must not be re-declared", name, var_locus, + (st && st->import_only) ? "IMPORT, ONLY" : "IMPORT, ALL"); + return false; + } /* ...Otherwise generate a new symtree and new symbol. */ else if (gfc_get_symbol (name, NULL, &sym, var_locus)) return false; @@ -3772,6 +3790,48 @@ match_record_decl (char *name) } + /* In parsing a PDT, it is possible that one of the type parameters has the + same name as a previously declared symbol that is not a type parameter. + Intercept this now by looking for the symtree in f2k_derived. */ + +static bool +correct_parm_expr (gfc_expr* e, gfc_symbol* pdt, int* f ATTRIBUTE_UNUSED) +{ + if (!e || (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION)) + return false; + + if (!(e->symtree->n.sym->attr.pdt_len + || e->symtree->n.sym->attr.pdt_kind)) + { + gfc_symtree *st; + st = gfc_find_symtree (pdt->f2k_derived->sym_root, + e->symtree->n.sym->name); + if (st && st->n.sym + && (st->n.sym->attr.pdt_len || st->n.sym->attr.pdt_kind)) + { + gfc_expr *new_expr; + gfc_set_sym_referenced (st->n.sym); + new_expr = gfc_get_expr (); + new_expr->ts = st->n.sym->ts; + new_expr->expr_type = EXPR_VARIABLE; + new_expr->symtree = st; + new_expr->where = e->where; + gfc_replace_expr (e, new_expr); + } + } + + return false; +} + + +void +gfc_correct_parm_expr (gfc_symbol *pdt, gfc_expr **bound) +{ + if (!*bound || (*bound)->expr_type == EXPR_CONSTANT) + return; + gfc_traverse_expr (*bound, pdt, &correct_parm_expr, 0); +} + /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source of expressions to substitute into the possibly parameterized expression 'e'. Using a list is inefficient but should not be too bad since the @@ -3783,22 +3843,26 @@ insert_parameter_exprs (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED, gfc_actual_arglist *param; gfc_expr *copy; - if (e->expr_type != EXPR_VARIABLE) + if (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION) return false; gcc_assert (e->symtree); if (e->symtree->n.sym->attr.pdt_kind - || (*f != 0 && e->symtree->n.sym->attr.pdt_len)) + || (*f != 0 && e->symtree->n.sym->attr.pdt_len) + || (e->expr_type == EXPR_FUNCTION && e->symtree->n.sym)) { for (param = type_param_spec_list; param; param = param->next) if (strcmp (e->symtree->n.sym->name, param->name) == 0) break; - if (param) + if (param && param->expr) { copy = gfc_copy_expr (param->expr); *e = *copy; free (copy); + /* Catch variables declared without a value expression. */ + if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_PROCEDURE) + e->ts = e->symtree->n.sym->ts; } } @@ -3836,7 +3900,7 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, /* The symbol for the parameter in the template f2k_namespace. */ gfc_symbol *param; /* The hoped for instance of the PDT. */ - gfc_symbol *instance; + gfc_symbol *instance = NULL; /* The list of parameters appearing in the PDT declaration. */ gfc_formal_arglist *type_param_name_list; /* Used to store the parameter specification list during recursive calls. */ @@ -3852,6 +3916,8 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, bool assumed_seen = false; bool deferred_seen = false; bool spec_error = false; + bool alloc_seen = false; + bool ptr_seen = false; int kind_value, i; gfc_expr *kind_expr; gfc_component *c1, *c2; @@ -3932,6 +3998,16 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, } } + if (kind_expr && kind_expr->expr_type == EXPR_VARIABLE + && kind_expr->ts.type != BT_INTEGER + && kind_expr->symtree->n.sym->ts.type != BT_INTEGER) + { + gfc_error ("The type parameter expression at %L must be of INTEGER " + "type and not %s", &kind_expr->where, + gfc_basic_typename (kind_expr->symtree->n.sym->ts.type)); + goto error_return; + } + /* Store the current parameter expressions in a temporary actual arglist 'list' so that they can be substituted in the corresponding expressions in the PDT instance. */ @@ -3952,6 +4028,12 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, /* Try simplification even for LEN expressions. */ bool ok; gfc_resolve_expr (kind_expr); + + if (c1->attr.pdt_kind + && kind_expr->expr_type != EXPR_CONSTANT + && type_param_spec_list) + gfc_insert_parameter_exprs (kind_expr, type_param_spec_list); + ok = gfc_simplify_expr (kind_expr, 1); /* Variable expressions seem to default to BT_PROCEDURE. TODO find out why this is and fix it. */ @@ -4004,7 +4086,16 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, goto error_return; } - gfc_extract_int (kind_expr, &kind_value); + kind_value = 0; + /* This can come about during the parsing of nested pdt_templates. An + error arises because the KIND parameter expression has not been + provided. Use the template instead of an incorrect instance. */ + if (gfc_extract_int (kind_expr, &kind_value)) + { + gfc_free_actual_arglist (type_param_spec_list); + return MATCH_YES; + } + sprintf (name + strlen (name), "_%d", kind_value); if (!name_seen && actual_param) @@ -4042,6 +4133,8 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, /* Start building the new instance of the parameterized type. */ gfc_copy_attr (&instance->attr, &pdt->attr, &pdt->declared_at); + if (pdt->attr.use_assoc) + instance->module = pdt->module; instance->attr.pdt_template = 0; instance->attr.pdt_type = 1; instance->declared_at = gfc_current_locus; @@ -4056,6 +4149,11 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, c2->ts = c1->ts; c2->attr = c1->attr; + if (c1->tb) + { + c2->tb = gfc_get_tbp (); + *c2->tb = *c1->tb; + } /* The order of declaration of the type_specs might not be the same as that of the components. */ @@ -4092,7 +4190,7 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, /* Now obtain the PDT instance for the extended type. */ c2->param_list = type_param_spec_list; m = gfc_get_pdt_instance (type_param_spec_list, &c2->ts.u.derived, - NULL); + &c2->param_list); type_param_spec_list = old_param_spec_list; c2->ts.u.derived->refs++; @@ -4143,20 +4241,17 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, c2->ts.kind, gfc_basic_typename (c2->ts.type)); goto error_return; } - } - - /* Similarly, set the string length if parameterized. */ - if (c1->ts.type == BT_CHARACTER - && c1->ts.u.cl->length - && gfc_derived_parameter_expr (c1->ts.u.cl->length)) - { - gfc_expr *e; - e = gfc_copy_expr (c1->ts.u.cl->length); - gfc_insert_kind_parameter_exprs (e); - gfc_simplify_expr (e, 1); - c2->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); - c2->ts.u.cl->length = e; - c2->attr.pdt_string = 1; + if (c2->attr.proc_pointer && c2->attr.function + && c1->ts.interface && c1->ts.interface->ts.kind == 0) + { + c2->ts.interface = gfc_new_symbol ("", gfc_current_ns); + c2->ts.interface->result = c2->ts.interface; + c2->ts.interface->ts = c2->ts; + c2->ts.interface->attr.flavor = FL_PROCEDURE; + c2->ts.interface->attr.function = 1; + c2->attr.function = 1; + c2->attr.if_source = IFSRC_UNKNOWN; + } } /* Set up either the KIND/LEN initializer, if constant, @@ -4183,6 +4278,12 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, if (c1->ts.type == BT_CLASS) CLASS_DATA (c2)->as = gfc_copy_array_spec (CLASS_DATA (c1)->as); + if (c1->attr.allocatable) + alloc_seen = true; + + if (c1->attr.pointer) + ptr_seen = true; + /* Determine if an array spec is parameterized. If so, substitute in the parameter expressions for the bounds and set the pdt_array attribute. Notice that this attribute must be unconditionally set @@ -4217,7 +4318,8 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, gfc_free_expr (c2->as->upper[i]); c2->as->upper[i] = e; } - c2->attr.pdt_array = pdt_array ? 1 : c2->attr.pdt_string; + + c2->attr.pdt_array = 1; if (c1->initializer) { c2->initializer = gfc_copy_expr (c1->initializer); @@ -4226,6 +4328,20 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, } } + /* Similarly, set the string length if parameterized. */ + if (c1->ts.type == BT_CHARACTER + && c1->ts.u.cl->length + && gfc_derived_parameter_expr (c1->ts.u.cl->length)) + { + gfc_expr *e; + e = gfc_copy_expr (c1->ts.u.cl->length); + gfc_insert_kind_parameter_exprs (e); + gfc_simplify_expr (e, 1); + gfc_free_expr (c2->ts.u.cl->length); + c2->ts.u.cl->length = e; + c2->attr.pdt_string = 1; + } + /* Recurse into this function for PDT components. */ if ((c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS) && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template) @@ -4238,23 +4354,35 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, /* Substitute the template parameters with the expressions from the specification list. */ for (;actual_param; actual_param = actual_param->next) - gfc_insert_parameter_exprs (actual_param->expr, - type_param_spec_list); + { + gfc_correct_parm_expr (pdt, &actual_param->expr); + gfc_insert_parameter_exprs (actual_param->expr, + type_param_spec_list); + } /* Now obtain the PDT instance for the component. */ old_param_spec_list = type_param_spec_list; - m = gfc_get_pdt_instance (params, &c2->ts.u.derived, NULL); + m = gfc_get_pdt_instance (params, &c2->ts.u.derived, + &c2->param_list); type_param_spec_list = old_param_spec_list; - c2->param_list = params; if (!(c2->attr.pointer || c2->attr.allocatable)) c2->initializer = gfc_default_initializer (&c2->ts); if (c2->attr.allocatable) instance->attr.alloc_comp = 1; } + else if (!(c2->attr.pdt_kind || c2->attr.pdt_len || c2->attr.pdt_string + || c2->attr.pdt_array) && c1->initializer) + c2->initializer = gfc_copy_expr (c1->initializer); } + if (alloc_seen) + instance->attr.alloc_comp = 1; + if (ptr_seen) + instance->attr.pointer_comp = 1; + + gfc_commit_symbol (instance); if (ext_param_list) *ext_param_list = type_param_spec_list; @@ -4688,6 +4816,16 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) return MATCH_ERROR; } + if (dt_sym && decl_type_param_list + && dt_sym->attr.flavor == FL_DERIVED + && !dt_sym->attr.pdt_type + && !dt_sym->attr.pdt_template) + { + gfc_error ("Type %qs is not parameterized and so the type parameter spec " + "list at %C may not appear", dt_sym->name); + return MATCH_ERROR; + } + if (sym && sym->attr.flavor == FL_DERIVED && sym->attr.pdt_template && gfc_current_state () != COMP_DERIVED) @@ -5100,6 +5238,54 @@ error: } +/* Match the IMPORT statement. IMPORT was added to F2003 as + + R1209 import-stmt is IMPORT [[ :: ] import-name-list ] + + C1210 (R1209) The IMPORT statement is allowed only in an interface-body. + + C1211 (R1209) Each import-name shall be the name of an entity in the + host scoping unit. + + under the description of an interface block. Under F2008, IMPORT was + split out of the interface block description to 12.4.3.3 and C1210 + became + + C1210 (R1209) The IMPORT statement is allowed only in an interface-body + that is not a module procedure interface body. + + Finally, F2018, section 8.8, has changed the IMPORT statement to + + R867 import-stmt is IMPORT [[ :: ] import-name-list ] + or IMPORT, ONLY : import-name-list + or IMPORT, NONE + or IMPORT, ALL + + C896 (R867) An IMPORT statement shall not appear in the scoping unit of + a main-program, external-subprogram, module, or block-data. + + C897 (R867) Each import-name shall be the name of an entity in the host + scoping unit. + + C898 If any IMPORT statement in a scoping unit has an ONLY specifier, + all IMPORT statements in that scoping unit shall have an ONLY + specifier. + + C899 IMPORT, NONE shall not appear in the scoping unit of a submodule. + + C8100 If an IMPORT, NONE or IMPORT, ALL statement appears in a scoping + unit, no other IMPORT statement shall appear in that scoping unit. + + C8101 Within an interface body, an entity that is accessed by host + association shall be accessible by host or use association within + the host scoping unit, or explicitly declared prior to the interface + body. + + C8102 An entity whose name appears as an import-name or which is made + accessible by an IMPORT, ALL statement shall not appear in any + context described in 19.5.1.4 that would cause the host entity + of that name to be inaccessible. */ + match gfc_match_import (void) { @@ -5107,16 +5293,28 @@ gfc_match_import (void) match m; gfc_symbol *sym; gfc_symtree *st; + bool f2018_allowed = gfc_option.allow_std & ~GFC_STD_OPT_F08;; + importstate current_import_state = gfc_current_ns->import_state; - if (gfc_current_ns->proc_name == NULL - || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY) + if (!f2018_allowed + && (gfc_current_ns->proc_name == NULL + || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY)) { gfc_error ("IMPORT statement at %C only permitted in " "an INTERFACE body"); return MATCH_ERROR; } + else if (f2018_allowed + && (!gfc_current_ns->parent || gfc_current_ns->is_block_data)) + goto C897; - if (gfc_current_ns->proc_name->attr.module_procedure) + if (f2018_allowed + && (current_import_state == IMPORT_ALL + || current_import_state == IMPORT_NONE)) + goto C8100; + + if (gfc_current_ns->proc_name + && gfc_current_ns->proc_name->attr.module_procedure) { gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted " "in a module procedure interface body"); @@ -5126,20 +5324,65 @@ gfc_match_import (void) if (!gfc_notify_std (GFC_STD_F2003, "IMPORT statement at %C")) return MATCH_ERROR; + gfc_current_ns->import_state = IMPORT_NOT_SET; + if (f2018_allowed) + { + if (gfc_match (" , none") == MATCH_YES) + { + if (current_import_state == IMPORT_ONLY) + goto C898; + if (gfc_current_state () == COMP_SUBMODULE) + goto C899; + gfc_current_ns->import_state = IMPORT_NONE; + } + else if (gfc_match (" , only :") == MATCH_YES) + { + if (current_import_state != IMPORT_NOT_SET + && current_import_state != IMPORT_ONLY) + goto C898; + gfc_current_ns->import_state = IMPORT_ONLY; + } + else if (gfc_match (" , all") == MATCH_YES) + { + if (current_import_state == IMPORT_ONLY) + goto C898; + gfc_current_ns->import_state = IMPORT_ALL; + } + + if (current_import_state != IMPORT_NOT_SET + && (gfc_current_ns->import_state == IMPORT_NONE + || gfc_current_ns->import_state == IMPORT_ALL)) + goto C8100; + } + + /* F2008 IMPORT<eos> is distinct from F2018 IMPORT, ALL. */ if (gfc_match_eos () == MATCH_YES) { - /* All host variables should be imported. */ - gfc_current_ns->has_import_set = 1; + /* This is the F2008 variant. */ + if (gfc_current_ns->import_state == IMPORT_NOT_SET) + { + if (current_import_state == IMPORT_ONLY) + goto C898; + gfc_current_ns->import_state = IMPORT_F2008; + } + + /* Host variables should be imported. */ + if (gfc_current_ns->import_state != IMPORT_NONE) + gfc_current_ns->has_import_set = 1; return MATCH_YES; } - if (gfc_match (" ::") == MATCH_YES) + if (gfc_match (" ::") == MATCH_YES + && gfc_current_ns->import_state != IMPORT_ONLY) { if (gfc_match_eos () == MATCH_YES) - { - gfc_error ("Expecting list of named entities at %C"); - return MATCH_ERROR; - } + goto expecting_list; + gfc_current_ns->import_state = IMPORT_F2008; + } + else if (gfc_current_ns->import_state == IMPORT_ONLY) + { + if (gfc_match_eos () == MATCH_YES) + goto expecting_list; } for(;;) @@ -5149,13 +5392,15 @@ gfc_match_import (void) switch (m) { case MATCH_YES: - if (gfc_current_ns->parent != NULL + if (gfc_current_ns->parent != NULL && gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym)) { gfc_error ("Type name %qs at %C is ambiguous", name); return MATCH_ERROR; } - else if (!sym && gfc_current_ns->proc_name->ns->parent != NULL + else if (!sym + && gfc_current_ns->proc_name + && gfc_current_ns->proc_name->ns->parent && gfc_find_symbol (name, gfc_current_ns->proc_name->ns->parent, 1, &sym)) @@ -5166,12 +5411,29 @@ gfc_match_import (void) if (sym == NULL) { - gfc_error ("Cannot IMPORT %qs from host scoping unit " - "at %C - does not exist.", name); - return MATCH_ERROR; + if (gfc_current_ns->proc_name + && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY) + { + gfc_error ("Cannot IMPORT %qs from host scoping unit " + "at %C - does not exist.", name); + return MATCH_ERROR; + } + else + { + /* This might be a procedure that has not yet been parsed. If + so gfc_fixup_sibling_symbols will replace this symbol with + that of the procedure. */ + gfc_get_sym_tree (name, gfc_current_ns, &st, false, + &gfc_current_locus); + st->n.sym->refs++; + st->n.sym->attr.imported = 1; + st->import_only = 1; + goto next_item; + } } - if (gfc_find_symtree (gfc_current_ns->sym_root, name)) + st = gfc_find_symtree (gfc_current_ns->sym_root, name); + if (st && st->n.sym && st->n.sym->attr.imported) { gfc_warning (0, "%qs is already IMPORTed from host scoping unit " "at %C", name); @@ -5182,6 +5444,7 @@ gfc_match_import (void) st->n.sym = sym; sym->refs++; sym->attr.imported = 1; + st->import_only = 1; if (sym->attr.generic && (sym = gfc_find_dt_in_generic (sym))) { @@ -5193,6 +5456,7 @@ gfc_match_import (void) st->n.sym = sym; sym->refs++; sym->attr.imported = 1; + st->import_only = 1; } goto next_item; @@ -5216,6 +5480,34 @@ gfc_match_import (void) syntax: gfc_error ("Syntax error in IMPORT statement at %C"); return MATCH_ERROR; + +C897: + gfc_error ("F2018: C897 IMPORT statement at %C cannot appear in a main " + "program, an external subprogram, a module or block data"); + return MATCH_ERROR; + +C898: + gfc_error ("F2018: C898 IMPORT statement at %C is not permitted because " + "a scoping unit has an ONLY specifier, can only have IMPORT " + "with an ONLY specifier"); + return MATCH_ERROR; + +C899: + gfc_error ("F2018: C899 IMPORT, NONE shall not appear in the scoping unit" + " of a submodule as at %C"); + return MATCH_ERROR; + +C8100: + gfc_error ("F2018: C8100 IMPORT statement at %C is not permitted because " + "%s has already been declared, which must be unique in the " + "scoping unit", + gfc_current_ns->import_state == IMPORT_ALL ? "IMPORT, ALL" : + "IMPORT, NONE"); + return MATCH_ERROR; + +expecting_list: + gfc_error ("Expecting list of named entities at %C"); + return MATCH_ERROR; } @@ -6144,15 +6436,17 @@ verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts, &(tmp_sym->declared_at)); } - /* See if the symbol has been marked as private. If it has, make sure - there is no binding label and warn the user if there is one. */ + /* See if the symbol has been marked as private. If it has, warn if + there is a binding label with default binding name. */ if (tmp_sym->attr.access == ACCESS_PRIVATE - && tmp_sym->binding_label) - /* Use gfc_warning_now because we won't say that the symbol fails - just because of this. */ - gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been " - "given the binding label %qs", tmp_sym->name, - &(tmp_sym->declared_at), tmp_sym->binding_label); + && tmp_sym->binding_label + && strcmp (tmp_sym->name, tmp_sym->binding_label) == 0 + && (tmp_sym->attr.flavor == FL_VARIABLE + || tmp_sym->attr.if_source == IFSRC_DECL)) + gfc_warning (OPT_Wsurprising, + "Symbol %qs at %L is marked PRIVATE but is accessible " + "via its default binding name %qs", tmp_sym->name, + &(tmp_sym->declared_at), tmp_sym->binding_label); return retval; } @@ -7384,6 +7678,9 @@ match_ppc_decl (void) *c->tb = *tb; } + if (saved_kind_expr) + c->kind_expr = gfc_copy_expr (saved_kind_expr); + /* Set interface. */ if (proc_if != NULL) { @@ -8765,7 +9062,7 @@ cleanup: /* If we are missing an END BLOCK, we created a half-ready namespace. Remove it from the parent namespace's sibling list. */ - while (state == COMP_BLOCK && !got_matching_end) + if (state == COMP_BLOCK && !got_matching_end) { parent_ns = gfc_current_ns->parent; @@ -11538,10 +11835,308 @@ syntax: } +/* Match a GENERIC statement. +F2018 15.4.3.3 GENERIC statement + +A GENERIC statement specifies a generic identifier for one or more specific +procedures, in the same way as a generic interface block that does not contain +interface bodies. + +R1510 generic-stmt is: +GENERIC [ , access-spec ] :: generic-spec => specific-procedure-list + +C1510 (R1510) A specific-procedure in a GENERIC statement shall not specify a +procedure that was specified previously in any accessible interface with the +same generic identifier. + +If access-spec appears, it specifies the accessibility (8.5.2) of generic-spec. + +For GENERIC statements outside of a derived type, use is made of the existing, +typebound matching functions to obtain access-spec and generic-spec. After +this the standard INTERFACE machinery is used. */ + +static match +match_generic_stmt (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + /* Allow space for OPERATOR(...). */ + char generic_spec_name[GFC_MAX_SYMBOL_LEN + 16]; + /* Generics other than uops */ + gfc_symbol* generic_spec = NULL; + /* Generic uops */ + gfc_user_op *generic_uop = NULL; + /* For the matching calls */ + gfc_typebound_proc tbattr; + gfc_namespace* ns = gfc_current_ns; + interface_type op_type; + gfc_intrinsic_op op; + match m; + gfc_symtree* st; + /* The specific-procedure-list */ + gfc_interface *generic = NULL; + /* The head of the specific-procedure-list */ + gfc_interface **generic_tail = NULL; + + memset (&tbattr, 0, sizeof (tbattr)); + tbattr.where = gfc_current_locus; + + /* See if we get an access-specifier. */ + m = match_binding_attributes (&tbattr, true, false); + tbattr.where = gfc_current_locus; + if (m == MATCH_ERROR) + goto error; + + /* Now the colons, those are required. */ + if (gfc_match (" ::") != MATCH_YES) + { + gfc_error ("Expected %<::%> at %C"); + goto error; + } + + /* Match the generic-spec name; depending on type (operator / generic) format + it for future error messages in 'generic_spec_name'. */ + m = gfc_match_generic_spec (&op_type, name, &op); + if (m == MATCH_ERROR) + return MATCH_ERROR; + if (m == MATCH_NO) + { + gfc_error ("Expected generic name or operator descriptor at %C"); + goto error; + } + + switch (op_type) + { + case INTERFACE_GENERIC: + case INTERFACE_DTIO: + snprintf (generic_spec_name, sizeof (generic_spec_name), "%s", name); + break; + + case INTERFACE_USER_OP: + snprintf (generic_spec_name, sizeof (generic_spec_name), "OPERATOR(.%s.)", name); + break; + + case INTERFACE_INTRINSIC_OP: + snprintf (generic_spec_name, sizeof (generic_spec_name), "OPERATOR(%s)", + gfc_op2string (op)); + break; + + case INTERFACE_NAMELESS: + gfc_error ("Malformed GENERIC statement at %C"); + goto error; + break; + + default: + gcc_unreachable (); + } + + /* Match the required =>. */ + if (gfc_match (" =>") != MATCH_YES) + { + gfc_error ("Expected %<=>%> at %C"); + goto error; + } + + + if (gfc_current_state () != COMP_MODULE && tbattr.access != ACCESS_UNKNOWN) + { + gfc_error ("The access specification at %L not in a module", + &tbattr.where); + goto error; + } + + /* Try to find existing generic-spec with this name for this operator; + if there is something, check that it is another generic-spec and then + extend it rather than building a new symbol. Otherwise, create a new + one with the right attributes. */ + + switch (op_type) + { + case INTERFACE_DTIO: + case INTERFACE_GENERIC: + st = gfc_find_symtree (ns->sym_root, name); + generic_spec = st ? st->n.sym : NULL; + if (generic_spec) + { + if (generic_spec->attr.flavor != FL_PROCEDURE + && generic_spec->attr.flavor != FL_UNKNOWN) + { + gfc_error ("The generic-spec name %qs at %C clashes with the " + "name of an entity declared at %L that is not a " + "procedure", name, &generic_spec->declared_at); + goto error; + } + + if (op_type == INTERFACE_GENERIC && !generic_spec->attr.generic + && generic_spec->attr.flavor != FL_UNKNOWN) + { + gfc_error ("There's already a non-generic procedure with " + "name %qs at %C", generic_spec->name); + goto error; + } + + if (tbattr.access != ACCESS_UNKNOWN) + { + if (generic_spec->attr.access != tbattr.access) + { + gfc_error ("The access specification at %L conflicts with " + "that already given to %qs", &tbattr.where, + generic_spec->name); + goto error; + } + else + { + gfc_error ("The access specification at %L repeats that " + "already given to %qs", &tbattr.where, + generic_spec->name); + goto error; + } + } + + if (generic_spec->ts.type != BT_UNKNOWN) + { + gfc_error ("The generic-spec in the generic statement at %C " + "has a type from the declaration at %L", + &generic_spec->declared_at); + goto error; + } + } + + /* Now create the generic_spec if it doesn't already exist and provide + is with the appropriate attributes. */ + if (!generic_spec || generic_spec->attr.flavor != FL_PROCEDURE) + { + if (!generic_spec) + { + gfc_get_symbol (name, ns, &generic_spec, &gfc_current_locus); + gfc_set_sym_referenced (generic_spec); + generic_spec->attr.access = tbattr.access; + } + else if (generic_spec->attr.access == ACCESS_UNKNOWN) + generic_spec->attr.access = tbattr.access; + generic_spec->refs++; + generic_spec->attr.generic = 1; + generic_spec->attr.flavor = FL_PROCEDURE; + + generic_spec->declared_at = gfc_current_locus; + } + + /* Prepare to add the specific procedures. */ + generic = generic_spec->generic; + generic_tail = &generic_spec->generic; + break; + + case INTERFACE_USER_OP: + st = gfc_find_symtree (ns->uop_root, name); + generic_uop = st ? st->n.uop : NULL; + if (generic_uop) + { + if (generic_uop->access != ACCESS_UNKNOWN + && tbattr.access != ACCESS_UNKNOWN) + { + if (generic_uop->access != tbattr.access) + { + gfc_error ("The user operator at %L must have the same " + "access specification as already defined user " + "operator %qs", &tbattr.where, generic_spec_name); + goto error; + } + else + { + gfc_error ("The user operator at %L repeats the access " + "specification of already defined user operator " "%qs", &tbattr.where, generic_spec_name); + goto error; + } + } + else if (generic_uop->access == ACCESS_UNKNOWN) + generic_uop->access = tbattr.access; + } + else + { + generic_uop = gfc_get_uop (name); + generic_uop->access = tbattr.access; + } + + /* Prepare to add the specific procedures. */ + generic = generic_uop->op; + generic_tail = &generic_uop->op; + break; + + case INTERFACE_INTRINSIC_OP: + generic = ns->op[op]; + generic_tail = &ns->op[op]; + break; + + default: + gcc_unreachable (); + } + + /* Now, match all following names in the specific-procedure-list. */ + do + { + m = gfc_match_name (name); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_NO) + { + gfc_error ("Expected specific procedure name at %C"); + goto error; + } + + if (op_type == INTERFACE_GENERIC + && !strcmp (generic_spec->name, name)) + { + gfc_error ("The name %qs of the specific procedure at %C conflicts " + "with that of the generic-spec", name); + goto error; + } + + generic = *generic_tail; + for (; generic; generic = generic->next) + { + if (!strcmp (generic->sym->name, name)) + { + gfc_error ("%qs already defined as a specific procedure for the" + " generic %qs at %C", name, generic_spec->name); + goto error; + } + } + + gfc_find_sym_tree (name, ns, 1, &st); + if (!st) + { + /* This might be a procedure that has not yet been parsed. If + so gfc_fixup_sibling_symbols will replace this symbol with + that of the procedure. */ + gfc_get_sym_tree (name, ns, &st, false); + st->n.sym->refs++; + } + + generic = gfc_get_interface(); + generic->next = *generic_tail; + *generic_tail = generic; + generic->where = gfc_current_locus; + generic->sym = st->n.sym; + } + while (gfc_match (" ,") == MATCH_YES); + + if (gfc_match_eos () != MATCH_YES) + { + gfc_error ("Junk after GENERIC statement at %C"); + goto error; + } + + gfc_commit_symbols (); + return MATCH_YES; + +error: + return MATCH_ERROR; +} + + /* Match a GENERIC procedure binding inside a derived type. */ -match -gfc_match_generic (void) +static match +match_typebound_generic (void) { char name[GFC_MAX_SYMBOL_LEN + 1]; char bind_name[GFC_MAX_SYMBOL_LEN + 16]; /* Allow space for OPERATOR(...). */ @@ -11751,6 +12346,17 @@ error: } +match +gfc_match_generic () +{ + if (gfc_option.allow_std & ~GFC_STD_OPT_F08 + && gfc_current_state () != COMP_DERIVED_CONTAINS) + return match_generic_stmt (); + else + return match_typebound_generic (); +} + + /* Match a FINAL declaration inside a derived type. */ match diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc index dd920f3..eda0659 100644 --- a/gcc/fortran/dump-parse-tree.cc +++ b/gcc/fortran/dump-parse-tree.cc @@ -767,6 +767,16 @@ show_expr (gfc_expr *p) break; + case EXPR_CONDITIONAL: + fputc ('(', dumpfile); + show_expr (p->value.conditional.condition); + fputs (" ? ", dumpfile); + show_expr (p->value.conditional.true_expr); + fputs (" : ", dumpfile); + show_expr (p->value.conditional.false_expr); + fputc (')', dumpfile); + break; + case EXPR_COMPCALL: show_compcall (p); break; @@ -4371,6 +4381,8 @@ get_c_type_name (gfc_typespec *ts, gfc_array_spec *as, const char **pre, mpz_clear (sz); *asterisk = false; } + else + *asterisk = true; } return ret; } @@ -4415,10 +4427,11 @@ write_type (gfc_symbol *sym) { gfc_component *c; - /* Don't dump our iso c module, nor vtypes. */ + /* Don't dump types that are not interoperable, our very own ISO C Binding + module, or vtypes. */ if (sym->from_intmod == INTMOD_ISO_C_BINDING || sym->attr.flavor != FL_DERIVED - || sym->attr.vtype) + || sym->attr.vtype || !sym->attr.is_bind_c) return; fprintf (dumpfile, "typedef struct %s {\n", sym->name); diff --git a/gcc/fortran/error.cc b/gcc/fortran/error.cc index f89d41d..8fde46e 100644 --- a/gcc/fortran/error.cc +++ b/gcc/fortran/error.cc @@ -24,6 +24,7 @@ along with GCC; see the file COPYING3. If not see for possible use later. If a line does not match a legal construction, then the saved error message is reported. */ +#define INCLUDE_VECTOR #include "config.h" #include "system.h" #include "coretypes.h" @@ -31,9 +32,9 @@ along with GCC; see the file COPYING3. If not see #include "gfortran.h" #include "diagnostic.h" -#include "diagnostic-color.h" +#include "diagnostics/color.h" #include "tree-diagnostic.h" /* tree_diagnostics_defaults */ -#include "diagnostic-format-text.h" +#include "diagnostics/text-sink.h" static int suppress_errors = 0; @@ -43,7 +44,7 @@ static bool warnings_not_errors = false; static bool buffered_p; static gfc_error_buffer *error_buffer; -static diagnostic_buffer *pp_error_buffer, *pp_warning_buffer; +static diagnostics::buffer *pp_error_buffer, *pp_warning_buffer; gfc_error_buffer::gfc_error_buffer () : flag (false), buffer (*global_dc) @@ -228,7 +229,7 @@ gfc_print_wide_char (gfc_char_t c) it to global_dc. */ static void -gfc_clear_diagnostic_buffer (diagnostic_buffer *this_buffer) +gfc_clear_diagnostic_buffer (diagnostics::buffer *this_buffer) { gcc_assert (this_buffer); global_dc->clear_diagnostic_buffer (*this_buffer); @@ -237,13 +238,13 @@ gfc_clear_diagnostic_buffer (diagnostic_buffer *this_buffer) /* The currently-printing diagnostic, for use by gfc_format_decoder, for colorizing %C and %L. */ -static diagnostic_info *curr_diagnostic; +static diagnostics::diagnostic_info *curr_diagnostic; /* A helper function to call diagnostic_report_diagnostic, while setting curr_diagnostic for the duration of the call. */ static bool -gfc_report_diagnostic (diagnostic_info *diagnostic) +gfc_report_diagnostic (diagnostics::diagnostic_info *diagnostic) { gcc_assert (diagnostic != NULL); curr_diagnostic = diagnostic; @@ -261,9 +262,9 @@ gfc_warning (int opt, const char *gmsgid, va_list ap) va_list argp; va_copy (argp, ap); - diagnostic_info diagnostic; + diagnostics::diagnostic_info diagnostic; rich_location rich_loc (line_table, UNKNOWN_LOCATION); - diagnostic_buffer *old_buffer = global_dc->get_diagnostic_buffer (); + diagnostics::buffer *old_buffer = global_dc->get_diagnostic_buffer (); gcc_assert (!old_buffer); gfc_clear_diagnostic_buffer (pp_warning_buffer); @@ -272,8 +273,8 @@ gfc_warning (int opt, const char *gmsgid, va_list ap) global_dc->set_diagnostic_buffer (pp_warning_buffer); diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, - DK_WARNING); - diagnostic.option_id = opt; + diagnostics::kind::warning); + diagnostic.m_option_id = opt; bool ret = gfc_report_diagnostic (&diagnostic); if (buffered_p) @@ -441,7 +442,7 @@ gfc_format_decoder (pretty_printer *pp, text_info *text, const char *spec, const char *color = (loc_num ? "range1" - : diagnostic_get_color_for_kind (curr_diagnostic->kind)); + : diagnostics::get_color_for_kind (curr_diagnostic->m_kind)); pp_string (pp, colorize_start (pp_show_color (pp), color)); pp_string (pp, result[loc_num]); pp_string (pp, colorize_stop (pp_show_color (pp))); @@ -460,8 +461,8 @@ gfc_format_decoder (pretty_printer *pp, text_info *text, const char *spec, /* Return a malloc'd string describing the kind of diagnostic. The caller is responsible for freeing the memory. */ static char * -gfc_diagnostic_build_kind_prefix (diagnostic_context *context, - const diagnostic_info *diagnostic) +gfc_diagnostic_build_kind_prefix (diagnostics::context *context, + const diagnostics::diagnostic_info *diagnostic) { static const char *const diagnostic_kind_text[] = { #define DEFINE_DIAGNOSTIC_KIND(K, T, C) (T), @@ -475,15 +476,16 @@ gfc_diagnostic_build_kind_prefix (diagnostic_context *context, #undef DEFINE_DIAGNOSTIC_KIND NULL }; - gcc_assert (diagnostic->kind < DK_LAST_DIAGNOSTIC_KIND); - const char *text = _(diagnostic_kind_text[diagnostic->kind]); + const int diag_kind_idx = static_cast<int> (diagnostic->m_kind); + gcc_assert (diagnostic->m_kind < diagnostics::kind::last_diagnostic_kind); + const char *text = _(diagnostic_kind_text[diag_kind_idx]); const char *text_cs = "", *text_ce = ""; pretty_printer *const pp = context->get_reference_printer (); - if (diagnostic_kind_color[diagnostic->kind]) +if (diagnostic_kind_color[diag_kind_idx]) { text_cs = colorize_start (pp_show_color (pp), - diagnostic_kind_color[diagnostic->kind]); + diagnostic_kind_color[diag_kind_idx]); text_ce = colorize_stop (pp_show_color (pp)); } return build_message_string ("%s%s:%s ", text_cs, text, text_ce); @@ -492,7 +494,7 @@ gfc_diagnostic_build_kind_prefix (diagnostic_context *context, /* Return a malloc'd string describing a location. The caller is responsible for freeing the memory. */ static char * -gfc_diagnostic_build_locus_prefix (const diagnostic_location_print_policy &loc_policy, +gfc_diagnostic_build_locus_prefix (const diagnostics::location_print_policy &loc_policy, expanded_location s, bool colorize) { @@ -511,7 +513,7 @@ gfc_diagnostic_build_locus_prefix (const diagnostic_location_print_policy &loc_p /* Return a malloc'd string describing two locations. The caller is responsible for freeing the memory. */ static char * -gfc_diagnostic_build_locus_prefix (const diagnostic_location_print_policy &loc_policy, +gfc_diagnostic_build_locus_prefix (const diagnostics::location_print_policy &loc_policy, expanded_location s, expanded_location s2, bool colorize) { @@ -548,16 +550,16 @@ gfc_diagnostic_build_locus_prefix (const diagnostic_location_print_policy &loc_p [locus of primary range]: Error: Some error at (1) and (2) */ static void -gfc_diagnostic_text_starter (diagnostic_text_output_format &text_output, - const diagnostic_info *diagnostic) +gfc_diagnostic_text_starter (diagnostics::text_sink &text_output, + const diagnostics::diagnostic_info *diagnostic) { - diagnostic_context *const context = &text_output.get_context (); + diagnostics::context *const context = &text_output.get_context (); pretty_printer *const pp = text_output.get_printer (); char * kind_prefix = gfc_diagnostic_build_kind_prefix (context, diagnostic); expanded_location s1 = diagnostic_expand_location (diagnostic); expanded_location s2; - bool one_locus = diagnostic->richloc->get_num_locations () < 2; + bool one_locus = diagnostic->m_richloc->get_num_locations () < 2; bool same_locus = false; if (!one_locus) @@ -566,13 +568,13 @@ gfc_diagnostic_text_starter (diagnostic_text_output_format &text_output, same_locus = diagnostic_same_line (context, s1, s2); } - diagnostic_location_print_policy loc_policy (text_output); + diagnostics::location_print_policy loc_policy (text_output); const bool colorize = pp_show_color (pp); char * locus_prefix = (one_locus || !same_locus) ? gfc_diagnostic_build_locus_prefix (loc_policy, s1, colorize) : gfc_diagnostic_build_locus_prefix (loc_policy, s1, s2, colorize); - if (!context->m_source_printing.enabled + if (!context->get_source_printing_options ().enabled || diagnostic_location (diagnostic, 0) <= BUILTINS_LOCATION || diagnostic_location (diagnostic, 0) == context->m_last_location) { @@ -608,7 +610,7 @@ gfc_diagnostic_text_starter (diagnostic_text_output_format &text_output, pp_newline (pp); diagnostic_show_locus (context, text_output.get_source_printing_options (), - diagnostic->richloc, diagnostic->kind, + diagnostic->m_richloc, diagnostic->m_kind, pp); /* If the caret line was shown, the prefix does not contain the locus. */ @@ -617,10 +619,11 @@ gfc_diagnostic_text_starter (diagnostic_text_output_format &text_output, } static void -gfc_diagnostic_start_span (const diagnostic_location_print_policy &loc_policy, - pretty_printer *pp, +gfc_diagnostic_start_span (const diagnostics::location_print_policy &loc_policy, + diagnostics::to_text &sink, expanded_location exploc) { + pretty_printer *pp = diagnostics::get_printer (sink); const bool colorize = pp_show_color (pp); char *locus_prefix = gfc_diagnostic_build_locus_prefix (loc_policy, exploc, colorize); @@ -633,9 +636,9 @@ gfc_diagnostic_start_span (const diagnostic_location_print_policy &loc_policy, static void -gfc_diagnostic_text_finalizer (diagnostic_text_output_format &text_output, - const diagnostic_info *diagnostic ATTRIBUTE_UNUSED, - diagnostic_t orig_diag_kind ATTRIBUTE_UNUSED) +gfc_diagnostic_text_finalizer (diagnostics::text_sink &text_output, + const diagnostics::diagnostic_info *, + enum diagnostics::kind orig_diag_kind ATTRIBUTE_UNUSED) { pretty_printer *const pp = text_output.get_printer (); pp_destroy_prefix (pp); @@ -649,13 +652,14 @@ bool gfc_warning_now_at (location_t loc, int opt, const char *gmsgid, ...) { va_list argp; - diagnostic_info diagnostic; + diagnostics::diagnostic_info diagnostic; rich_location rich_loc (line_table, loc); bool ret; va_start (argp, gmsgid); - diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_WARNING); - diagnostic.option_id = opt; + diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, + diagnostics::kind::warning); + diagnostic.m_option_id = opt; ret = gfc_report_diagnostic (&diagnostic); va_end (argp); return ret; @@ -667,14 +671,14 @@ bool gfc_warning_now (int opt, const char *gmsgid, ...) { va_list argp; - diagnostic_info diagnostic; + diagnostics::diagnostic_info diagnostic; rich_location rich_loc (line_table, UNKNOWN_LOCATION); bool ret; va_start (argp, gmsgid); diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, - DK_WARNING); - diagnostic.option_id = opt; + diagnostics::kind::warning); + diagnostic.m_option_id = opt; ret = gfc_report_diagnostic (&diagnostic); va_end (argp); return ret; @@ -686,14 +690,14 @@ bool gfc_warning_internal (int opt, const char *gmsgid, ...) { va_list argp; - diagnostic_info diagnostic; + diagnostics::diagnostic_info diagnostic; rich_location rich_loc (line_table, UNKNOWN_LOCATION); bool ret; va_start (argp, gmsgid); diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, - DK_WARNING); - diagnostic.option_id = opt; + diagnostics::kind::warning); + diagnostic.m_option_id = opt; ret = gfc_report_diagnostic (&diagnostic); va_end (argp); return ret; @@ -705,13 +709,14 @@ void gfc_error_now (const char *gmsgid, ...) { va_list argp; - diagnostic_info diagnostic; + diagnostics::diagnostic_info diagnostic; rich_location rich_loc (line_table, UNKNOWN_LOCATION); error_buffer->flag = true; va_start (argp, gmsgid); - diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_ERROR); + diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, + diagnostics::kind::error); gfc_report_diagnostic (&diagnostic); va_end (argp); } @@ -723,11 +728,12 @@ void gfc_fatal_error (const char *gmsgid, ...) { va_list argp; - diagnostic_info diagnostic; + diagnostics::diagnostic_info diagnostic; rich_location rich_loc (line_table, UNKNOWN_LOCATION); va_start (argp, gmsgid); - diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_FATAL); + diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, + diagnostics::kind::fatal); gfc_report_diagnostic (&diagnostic); va_end (argp); @@ -775,9 +781,9 @@ gfc_error_opt (int opt, const char *gmsgid, va_list ap) return; } - diagnostic_info diagnostic; + diagnostics::diagnostic_info diagnostic; rich_location richloc (line_table, UNKNOWN_LOCATION); - diagnostic_buffer *old_buffer = global_dc->get_diagnostic_buffer (); + diagnostics::buffer *old_buffer = global_dc->get_diagnostic_buffer (); gcc_assert (!old_buffer); gfc_clear_diagnostic_buffer (pp_error_buffer); @@ -785,7 +791,8 @@ gfc_error_opt (int opt, const char *gmsgid, va_list ap) if (buffered_p) global_dc->set_diagnostic_buffer (pp_error_buffer); - diagnostic_set_info (&diagnostic, gmsgid, &argp, &richloc, DK_ERROR); + diagnostic_set_info (&diagnostic, gmsgid, &argp, &richloc, + diagnostics::kind::error); gfc_report_diagnostic (&diagnostic); if (buffered_p) @@ -822,7 +829,7 @@ gfc_internal_error (const char *gmsgid, ...) { int e, w; va_list argp; - diagnostic_info diagnostic; + diagnostics::diagnostic_info diagnostic; rich_location rich_loc (line_table, UNKNOWN_LOCATION); gfc_get_errors (&w, &e); @@ -830,7 +837,8 @@ gfc_internal_error (const char *gmsgid, ...) exit(EXIT_FAILURE); va_start (argp, gmsgid); - diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_ICE); + diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, + diagnostics::kind::ice); gfc_report_diagnostic (&diagnostic); va_end (argp); @@ -884,8 +892,8 @@ static void gfc_move_error_buffer_from_to (gfc_error_buffer * buffer_from, gfc_error_buffer * buffer_to) { - diagnostic_buffer * from = &(buffer_from->buffer); - diagnostic_buffer * to = &(buffer_to->buffer); + diagnostics::buffer * from = &(buffer_from->buffer); + diagnostics::buffer * to = &(buffer_to->buffer); buffer_to->flag = buffer_from->flag; buffer_from->flag = false; @@ -949,13 +957,14 @@ gfc_errors_to_warnings (bool f) void gfc_diagnostics_init (void) { - diagnostic_text_starter (global_dc) = gfc_diagnostic_text_starter; - diagnostic_start_span (global_dc) = gfc_diagnostic_start_span; - diagnostic_text_finalizer (global_dc) = gfc_diagnostic_text_finalizer; + diagnostics::text_starter (global_dc) = gfc_diagnostic_text_starter; + diagnostics::start_span (global_dc) = gfc_diagnostic_start_span; + diagnostics::text_finalizer (global_dc) = gfc_diagnostic_text_finalizer; global_dc->set_format_decoder (gfc_format_decoder); - global_dc->m_source_printing.caret_chars[0] = '1'; - global_dc->m_source_printing.caret_chars[1] = '2'; - pp_warning_buffer = new diagnostic_buffer (*global_dc); + auto &source_printing_opts = global_dc->get_source_printing_options (); + source_printing_opts.caret_chars[0] = '1'; + source_printing_opts.caret_chars[1] = '2'; + pp_warning_buffer = new diagnostics::buffer (*global_dc); error_buffer = new gfc_error_buffer (); pp_error_buffer = &(error_buffer->buffer); } @@ -966,10 +975,11 @@ gfc_diagnostics_finish (void) tree_diagnostics_defaults (global_dc); /* We still want to use the gfc starter and finalizer, not the tree defaults. */ - diagnostic_text_starter (global_dc) = gfc_diagnostic_text_starter; - diagnostic_text_finalizer (global_dc) = gfc_diagnostic_text_finalizer; - global_dc->m_source_printing.caret_chars[0] = '^'; - global_dc->m_source_printing.caret_chars[1] = '^'; + diagnostics::text_starter (global_dc) = gfc_diagnostic_text_starter; + diagnostics::text_finalizer (global_dc) = gfc_diagnostic_text_finalizer; + auto &source_printing_opts = global_dc->get_source_printing_options (); + source_printing_opts.caret_chars[0] = '^'; + source_printing_opts.caret_chars[1] = '^'; delete error_buffer; error_buffer = nullptr; pp_error_buffer = nullptr; diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc index 92a9ebd..a11ff79 100644 --- a/gcc/fortran/expr.cc +++ b/gcc/fortran/expr.cc @@ -116,6 +116,25 @@ gfc_get_operator_expr (locus *where, gfc_intrinsic_op op, return e; } +/* Get a new expression node that is an conditional expression node. */ + +gfc_expr * +gfc_get_conditional_expr (locus *where, gfc_expr *condition, + gfc_expr *true_expr, gfc_expr *false_expr) +{ + gfc_expr *e; + + e = gfc_get_expr (); + e->expr_type = EXPR_CONDITIONAL; + e->value.conditional.condition = condition; + e->value.conditional.true_expr = true_expr; + e->value.conditional.false_expr = false_expr; + + if (where) + e->where = *where; + + return e; +} /* Get a new expression node that is an structure constructor of given type and kind. */ @@ -393,6 +412,15 @@ gfc_copy_expr (gfc_expr *p) break; + case EXPR_CONDITIONAL: + q->value.conditional.condition + = gfc_copy_expr (p->value.conditional.condition); + q->value.conditional.true_expr + = gfc_copy_expr (p->value.conditional.true_expr); + q->value.conditional.false_expr + = gfc_copy_expr (p->value.conditional.false_expr); + break; + case EXPR_FUNCTION: q->value.function.actual = gfc_copy_actual_arglist (p->value.function.actual); @@ -502,6 +530,12 @@ free_expr0 (gfc_expr *e) gfc_free_expr (e->value.op.op2); break; + case EXPR_CONDITIONAL: + gfc_free_expr (e->value.conditional.condition); + gfc_free_expr (e->value.conditional.true_expr); + gfc_free_expr (e->value.conditional.false_expr); + break; + case EXPR_FUNCTION: gfc_free_actual_arglist (e->value.function.actual); break; @@ -1083,6 +1117,11 @@ gfc_is_constant_expr (gfc_expr *e) && (e->value.op.op2 == NULL || gfc_is_constant_expr (e->value.op.op2))); + case EXPR_CONDITIONAL: + return gfc_is_constant_expr (e->value.conditional.condition) + && gfc_is_constant_expr (e->value.conditional.true_expr) + && gfc_is_constant_expr (e->value.conditional.false_expr); + case EXPR_VARIABLE: /* The only context in which this can occur is in a parameterized derived type declaration, so returning true is OK. */ @@ -1354,6 +1393,43 @@ simplify_intrinsic_op (gfc_expr *p, int type) return true; } +/* Try to collapse conditional expressions. */ + +static bool +simplify_conditional (gfc_expr *p, int type) +{ + gfc_expr *condition, *true_expr, *false_expr; + + condition = p->value.conditional.condition; + true_expr = p->value.conditional.true_expr; + false_expr = p->value.conditional.false_expr; + + if (!gfc_simplify_expr (condition, type) + || !gfc_simplify_expr (true_expr, type) + || !gfc_simplify_expr (false_expr, type)) + return false; + + if (!gfc_is_constant_expr (condition)) + return true; + + p->value.conditional.condition = NULL; + p->value.conditional.true_expr = NULL; + p->value.conditional.false_expr = NULL; + + if (condition->value.logical) + { + gfc_replace_expr (p, true_expr); + gfc_free_expr (false_expr); + } + else + { + gfc_replace_expr (p, false_expr); + gfc_free_expr (true_expr); + } + gfc_free_expr (condition); + + return true; +} /* Subroutine to simplify constructor expressions. Mutually recursive with gfc_simplify_expr(). */ @@ -1372,7 +1448,7 @@ simplify_constructor (gfc_constructor_base base, int type) || !gfc_simplify_expr (c->iterator->step, type))) return false; - if (c->expr) + if (c->expr && c->expr->expr_type != EXPR_CONSTANT) { /* Try and simplify a copy. Replace the original if successful but keep going through the constructor at all costs. Not @@ -1838,6 +1914,55 @@ find_substring_ref (gfc_expr *p, gfc_expr **newp) } +/* Simplify inquiry references (%re/%im) of constant complex arrays. + Used by find_inquiry_ref. */ + +static gfc_expr * +simplify_complex_array_inquiry_ref (gfc_expr *p, inquiry_type inquiry) +{ + gfc_expr *e, *r, *result; + gfc_constructor_base base; + gfc_constructor *c; + + if ((inquiry != INQUIRY_RE && inquiry != INQUIRY_IM) + || p->expr_type != EXPR_ARRAY + || p->ts.type != BT_COMPLEX + || p->rank <= 0 + || p->value.constructor == NULL + || !gfc_is_constant_array_expr (p)) + return NULL; + + /* Simplify array sections. */ + gfc_simplify_expr (p, 0); + + result = gfc_get_array_expr (BT_REAL, p->ts.kind, &p->where); + result->rank = p->rank; + result->shape = gfc_copy_shape (p->shape, p->rank); + + base = p->value.constructor; + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) + { + e = c->expr; + if (e->expr_type != EXPR_CONSTANT) + goto fail; + + r = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); + if (inquiry == INQUIRY_RE) + mpfr_set (r->value.real, mpc_realref (e->value.complex), GFC_RND_MODE); + else + mpfr_set (r->value.real, mpc_imagref (e->value.complex), GFC_RND_MODE); + + gfc_constructor_append_expr (&result->value.constructor, r, &e->where); + } + + return result; + +fail: + gfc_free_expr (result); + return NULL; +} + + /* Pull an inquiry result out of an expression. */ static bool @@ -1846,7 +1971,9 @@ find_inquiry_ref (gfc_expr *p, gfc_expr **newp) gfc_ref *ref; gfc_ref *inquiry = NULL; gfc_ref *inquiry_head; + gfc_ref *ref_ss = NULL; gfc_expr *tmp; + bool nofail = false; tmp = gfc_copy_expr (p); @@ -1862,6 +1989,9 @@ find_inquiry_ref (gfc_expr *p, gfc_expr **newp) { inquiry = ref->next; ref->next = NULL; + if (ref->type == REF_SUBSTRING) + ref_ss = ref; + break; } } @@ -1891,6 +2021,28 @@ find_inquiry_ref (gfc_expr *p, gfc_expr **newp) if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C")) goto cleanup; + /* Inquire length of substring? */ + if (ref_ss) + { + if (ref_ss->u.ss.start->expr_type == EXPR_CONSTANT + && ref_ss->u.ss.end->expr_type == EXPR_CONSTANT) + { + HOST_WIDE_INT istart, iend, length; + istart = gfc_mpz_get_hwi (ref_ss->u.ss.start->value.integer); + iend = gfc_mpz_get_hwi (ref_ss->u.ss.end->value.integer); + + if (istart <= iend) + length = iend - istart + 1; + else + length = 0; + *newp = gfc_get_int_expr (gfc_default_integer_kind, + NULL, length); + break; + } + else + goto cleanup; + } + if (tmp->ts.u.cl->length && tmp->ts.u.cl->length->expr_type == EXPR_CONSTANT) *newp = gfc_copy_expr (tmp->ts.u.cl->length); @@ -1921,24 +2073,50 @@ find_inquiry_ref (gfc_expr *p, gfc_expr **newp) break; case INQUIRY_RE: - if (tmp->ts.type != BT_COMPLEX || tmp->expr_type != EXPR_CONSTANT) + if (tmp->ts.type != BT_COMPLEX) goto cleanup; if (!gfc_notify_std (GFC_STD_F2008, "RE part_ref at %C")) goto cleanup; + if (tmp->expr_type == EXPR_ARRAY) + { + *newp = simplify_complex_array_inquiry_ref (tmp, INQUIRY_RE); + if (*newp != NULL) + { + nofail = true; + break; + } + } + + if (tmp->expr_type != EXPR_CONSTANT) + goto cleanup; + *newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where); mpfr_set ((*newp)->value.real, mpc_realref (tmp->value.complex), GFC_RND_MODE); break; case INQUIRY_IM: - if (tmp->ts.type != BT_COMPLEX || tmp->expr_type != EXPR_CONSTANT) + if (tmp->ts.type != BT_COMPLEX) goto cleanup; if (!gfc_notify_std (GFC_STD_F2008, "IM part_ref at %C")) goto cleanup; + if (tmp->expr_type == EXPR_ARRAY) + { + *newp = simplify_complex_array_inquiry_ref (tmp, INQUIRY_IM); + if (*newp != NULL) + { + nofail = true; + break; + } + } + + if (tmp->expr_type != EXPR_CONSTANT) + goto cleanup; + *newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where); mpfr_set ((*newp)->value.real, mpc_imagref (tmp->value.complex), GFC_RND_MODE); @@ -1951,7 +2129,7 @@ find_inquiry_ref (gfc_expr *p, gfc_expr **newp) if (!(*newp)) goto cleanup; - else if ((*newp)->expr_type != EXPR_CONSTANT) + else if ((*newp)->expr_type != EXPR_CONSTANT && !nofail) { gfc_free_expr (*newp); goto cleanup; @@ -2357,6 +2535,11 @@ gfc_simplify_expr (gfc_expr *p, int type) return false; break; + case EXPR_CONDITIONAL: + if (!simplify_conditional (p, type)) + return false; + break; + case EXPR_VARIABLE: /* Only substitute array parameter variables if we are in an initialization expression, or we want a subsection. */ @@ -2367,7 +2550,8 @@ gfc_simplify_expr (gfc_expr *p, int type) { if (!simplify_parameter_variable (p, type)) return false; - break; + if (!iter_stack) + break; } if (type == 1) @@ -2523,7 +2707,7 @@ scalarize_intrinsic_call (gfc_expr *e, bool init_flag) rank[n] = a->expr->rank; else rank[n] = 1; - ctor = gfc_constructor_copy (a->expr->value.constructor); + ctor = a->expr->value.constructor; args[n] = gfc_constructor_first (ctor); } else @@ -3030,6 +3214,20 @@ gfc_check_init_expr (gfc_expr *e) break; + case EXPR_CONDITIONAL: + t = gfc_check_init_expr (e->value.conditional.condition); + if (!t) + break; + t = gfc_check_init_expr (e->value.conditional.true_expr); + if (!t) + break; + t = gfc_check_init_expr (e->value.conditional.false_expr); + if (t) + t = gfc_simplify_expr (e, 0); + else + t = false; + break; + case EXPR_FUNCTION: t = false; @@ -3506,6 +3704,20 @@ check_restricted (gfc_expr *e) break; + case EXPR_CONDITIONAL: + t = check_restricted (e->value.conditional.condition); + if (!t) + break; + t = check_restricted (e->value.conditional.true_expr); + if (!t) + break; + t = check_restricted (e->value.conditional.false_expr); + if (t) + t = gfc_simplify_expr (e, 0); + else + t = false; + break; + case EXPR_FUNCTION: if (e->value.function.esym) { @@ -4666,6 +4878,52 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue) memset (&lvalue, '\0', sizeof (gfc_expr)); + if (sym && sym->attr.pdt_template && comp && comp->initializer) + { + int i, flag; + gfc_expr *param_expr; + flag = 0; + + if (comp->as && comp->as->type == AS_EXPLICIT + && !(comp->ts.type == BT_DERIVED + && comp->ts.u.derived->attr.pdt_template)) + { + /* Are the bounds of the array parameterized? */ + for (i = 0; i < comp->as->rank; i++) + { + param_expr = gfc_copy_expr (comp->as->lower[i]); + if (gfc_simplify_expr (param_expr, 1) + && param_expr->expr_type != EXPR_CONSTANT) + flag++; + gfc_free_expr (param_expr); + param_expr = gfc_copy_expr (comp->as->upper[i]); + if (gfc_simplify_expr (param_expr, 1) + && param_expr->expr_type != EXPR_CONSTANT) + flag++; + gfc_free_expr (param_expr); + } + } + + /* Is the character length parameterized? */ + if (comp->ts.type == BT_CHARACTER && comp->ts.u.cl->length) + { + param_expr = gfc_copy_expr (comp->ts.u.cl->length); + if (gfc_simplify_expr (param_expr, 1) + && param_expr->expr_type != EXPR_CONSTANT) + flag++; + gfc_free_expr (param_expr); + } + + if (flag) + { + gfc_error ("The component %qs at %L of derived type %qs has " + "paramterized type or array length parameters, which is " + "not compatible with a default initializer", + comp->name, &comp->initializer->where, sym->name); + return false; + } + } + lvalue.expr_type = EXPR_VARIABLE; lvalue.ts = sym->ts; if (sym->as) @@ -5551,6 +5809,15 @@ gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym, return true; break; + case EXPR_CONDITIONAL: + if (gfc_traverse_expr (expr->value.conditional.condition, sym, func, f)) + return true; + if (gfc_traverse_expr (expr->value.conditional.true_expr, sym, func, f)) + return true; + if (gfc_traverse_expr (expr->value.conditional.false_expr, sym, func, f)) + return true; + break; + default: gcc_unreachable (); break; @@ -5808,6 +6075,7 @@ gfc_spec_list_type (gfc_actual_arglist *param_list, gfc_symbol *derived) gfc_component *c; bool seen_assumed = false; bool seen_deferred = false; + bool seen_len = false; if (derived == NULL) { @@ -5829,10 +6097,12 @@ gfc_spec_list_type (gfc_actual_arglist *param_list, gfc_symbol *derived) return SPEC_EXPLICIT; seen_assumed = param_list->spec_type == SPEC_ASSUMED; seen_deferred = param_list->spec_type == SPEC_DEFERRED; + if (c->attr.pdt_len) + seen_len = true; if (seen_assumed && seen_deferred) return SPEC_EXPLICIT; } - res = seen_assumed ? SPEC_ASSUMED : SPEC_DEFERRED; + res = (seen_assumed || !seen_len) ? SPEC_ASSUMED : SPEC_DEFERRED; } return res; } diff --git a/gcc/fortran/f95-lang.cc b/gcc/fortran/f95-lang.cc index 1f09553..bb4ce6d 100644 --- a/gcc/fortran/f95-lang.cc +++ b/gcc/fortran/f95-lang.cc @@ -564,7 +564,7 @@ gfc_builtin_function (tree decl) return decl; } -/* So far we need just these 10 attribute types. */ +/* So far we need just these 12 attribute types. */ #define ATTR_NULL 0 #define ATTR_LEAF_LIST (ECF_LEAF) #define ATTR_NOTHROW_LEAF_LIST (ECF_NOTHROW | ECF_LEAF) @@ -580,6 +580,7 @@ gfc_builtin_function (tree decl) #define ATTR_COLD_NORETURN_NOTHROW_LEAF_LIST \ (ECF_COLD | ECF_NORETURN | \ ECF_NOTHROW | ECF_LEAF) +#define ATTR_PURE_NOTHROW_LIST (ECF_PURE | ECF_NOTHROW) static void gfc_define_builtin (const char *name, tree type, enum built_in_function code, diff --git a/gcc/fortran/frontend-passes.cc b/gcc/fortran/frontend-passes.cc index 02a0a23..595c509 100644 --- a/gcc/fortran/frontend-passes.cc +++ b/gcc/fortran/frontend-passes.cc @@ -1481,7 +1481,8 @@ optimize_namespace (gfc_namespace *ns) gfc_code_walker (&ns->code, convert_elseif, dummy_expr_callback, NULL); gfc_code_walker (&ns->code, cfe_code, cfe_expr_0, NULL); gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL); - if (flag_inline_matmul_limit != 0 || flag_external_blas) + if (flag_inline_matmul_limit != 0 || flag_external_blas + || flag_external_blas64) { bool found; do @@ -1496,7 +1497,7 @@ optimize_namespace (gfc_namespace *ns) NULL); } - if (flag_external_blas) + if (flag_external_blas || flag_external_blas64) gfc_code_walker (&ns->code, call_external_blas, dummy_expr_callback, NULL); @@ -4644,6 +4645,7 @@ call_external_blas (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, enum matrix_case m_case; bool realloc_c; gfc_code **next_code_point; + int arg_kind; /* Many of the tests for inline matmul also apply here. */ @@ -4929,13 +4931,20 @@ call_external_blas (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, transb, 1); actual->next = next; + if (flag_external_blas) + arg_kind = gfc_integer_4_kind; + else + { + gcc_assert (flag_external_blas64); + arg_kind = gfc_integer_8_kind; + } + c1 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (a->expr), 1, - gfc_integer_4_kind); + arg_kind); c2 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (b->expr), 2, - gfc_integer_4_kind); - + arg_kind); b1 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (b->expr), 1, - gfc_integer_4_kind); + arg_kind); /* Argument M. */ actual = next; @@ -4975,7 +4984,7 @@ call_external_blas (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, actual = next; next = gfc_get_actual_arglist (); next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (matrix_a), - 1, gfc_integer_4_kind); + 1, arg_kind); actual->next = next; /* Argument B. */ @@ -4988,7 +4997,7 @@ call_external_blas (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, actual = next; next = gfc_get_actual_arglist (); next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (matrix_b), - 1, gfc_integer_4_kind); + 1, arg_kind); actual->next = next; /* Argument BETA - set to zero. */ @@ -5012,7 +5021,7 @@ call_external_blas (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, actual = next; next = gfc_get_actual_arglist (); next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (expr1), - 1, gfc_integer_4_kind); + 1, arg_kind); actual->next = next; return 0; @@ -5218,6 +5227,11 @@ gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data) for (a = (*e)->value.function.actual; a; a = a->next) WALK_SUBEXPR (a->expr); break; + case EXPR_CONDITIONAL: + WALK_SUBEXPR ((*e)->value.conditional.condition); + WALK_SUBEXPR ((*e)->value.conditional.true_expr); + WALK_SUBEXPR ((*e)->value.conditional.false_expr); + break; case EXPR_COMPCALL: case EXPR_PPC: WALK_SUBEXPR ((*e)->value.compcall.base_object); diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 4740c36..a14202f 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -176,8 +176,19 @@ enum gfc_source_form /* Expression node types. */ enum expr_t - { EXPR_UNKNOWN = 0, EXPR_OP = 1, EXPR_FUNCTION, EXPR_CONSTANT, EXPR_VARIABLE, - EXPR_SUBSTRING, EXPR_STRUCTURE, EXPR_ARRAY, EXPR_NULL, EXPR_COMPCALL, EXPR_PPC +{ + EXPR_UNKNOWN = 0, + EXPR_OP = 1, + EXPR_FUNCTION, + EXPR_CONSTANT, + EXPR_VARIABLE, + EXPR_SUBSTRING, + EXPR_STRUCTURE, + EXPR_ARRAY, + EXPR_NULL, + EXPR_COMPCALL, + EXPR_PPC, + EXPR_CONDITIONAL, }; /* Array types. */ @@ -721,6 +732,16 @@ enum gfc_isym_id remains compatible. */ GFC_ISYM_SU_KIND, GFC_ISYM_UINT, + + GFC_ISYM_ACOSPI, + GFC_ISYM_ASINPI, + GFC_ISYM_ATANPI, + GFC_ISYM_ATAN2PI, + GFC_ISYM_COSPI, + GFC_ISYM_SINPI, + GFC_ISYM_TANPI, + + GFC_ISYM_SPLIT, }; enum init_local_logical @@ -1012,7 +1033,7 @@ typedef struct /* These are the attributes required for parameterized derived types. */ unsigned pdt_kind:1, pdt_len:1, pdt_type:1, pdt_template:1, - pdt_array:1, pdt_string:1; + pdt_array:1, pdt_string:1, pdt_comp:1; /* This is omp_{out,in,priv,orig} artificial variable in !$OMP DECLARE REDUCTION. */ @@ -1906,6 +1927,7 @@ typedef struct gfc_typebound_proc } gfc_typebound_proc; +#define gfc_get_tbp() XCNEW (gfc_typebound_proc) /* Symbol nodes. These are important things. They are what the standard refers to as "entities". The possibly multiple names that @@ -2020,10 +2042,6 @@ typedef struct gfc_symbol /* Set if this should be passed by value, but is not a VALUE argument according to the Fortran standard. */ unsigned pass_as_value:1; - /* Set if an allocatable array variable has been allocated in the current - scope. Used in the suppression of uninitialized warnings in reallocation - on assignment. */ - unsigned allocated_in_scope:1; /* Set if an external dummy argument is called with different argument lists. This is legal in Fortran, but can cause problems with autogenerated C prototypes for C23. */ @@ -2180,6 +2198,7 @@ typedef struct gfc_symtree gfc_omp_udr *omp_udr; } n; + unsigned import_only:1; } gfc_symtree; @@ -2207,6 +2226,17 @@ typedef struct gfc_was_finalized { } gfc_was_finalized; + + /* Flag F2018 import status */ +enum importstate +{ IMPORT_NOT_SET = 0, /* Default condition. */ + IMPORT_F2008, /* Old style IMPORT. */ + IMPORT_ONLY, /* Import list used. */ + IMPORT_NONE, /* No host association. Unique in scoping unit. */ + IMPORT_ALL /* Must be unique in the scoping unit. */ +}; + + /* A namespace describes the contents of procedure, module, interface block or BLOCK construct. */ /* ??? Anything else use these? */ @@ -2320,6 +2350,10 @@ typedef struct gfc_namespace /* Set to 1 if namespace is an interface body with "IMPORT" used. */ unsigned has_import_set:1; + /* Flag F2018 import status */ + ENUM_BITFIELD (importstate) import_state :3; + + /* Set to 1 if the namespace uses "IMPLICIT NONE (export)". */ unsigned has_implicit_none_export:1; @@ -2786,8 +2820,14 @@ typedef struct gfc_expr character; gfc_constructor_base constructor; - } - value; + + struct + { + struct gfc_expr *condition; + struct gfc_expr *true_expr; + struct gfc_expr *false_expr; + } conditional; + } value; /* Used to store PDT expression lists associated with expressions. */ gfc_actual_arglist *param_list; @@ -2922,7 +2962,7 @@ typedef struct gfc_equiv_list upwards, if *low is NULL the selection is *high downwards. This structure has separate fields to allow single and double linked - lists of CASEs at the same time. The singe linked list along the NEXT + lists of CASEs at the same time. The single linked list along the NEXT field is a list of cases for a single CASE label. The double linked list along the LEFT/RIGHT fields is used to detect overlap and to build a table of the cases for SELECT constructs with a CHARACTER @@ -3294,8 +3334,10 @@ typedef struct int flag_init_logical; int flag_init_character; char flag_init_character_value; - bool disable_omp_is_initial_device; - bool disable_acc_on_device; + bool disable_omp_is_initial_device:1; + bool disable_omp_get_initial_device:1; + bool disable_omp_get_num_devices:1; + bool disable_acc_on_device:1; int fpe; int fpe_summary; @@ -3420,6 +3462,7 @@ extern hash_map<nofree_string_hash, int> *gfc_vectorized_builtins; /* Handling Parameterized Derived Types */ bool gfc_insert_parameter_exprs (gfc_expr *, gfc_actual_arglist *); +void gfc_correct_parm_expr (gfc_symbol *, gfc_expr **); match gfc_get_pdt_instance (gfc_actual_arglist *, gfc_symbol **, gfc_actual_arglist **); @@ -3497,6 +3540,8 @@ void gfc_done_2 (void); int get_c_kind (const char *, CInteropKind_t *); +const char * gfc_var_name_for_select_type_temp (gfc_expr *); + const char *gfc_closest_fuzzy_match (const char *, char **); inline void vec_push (char **&optr, size_t &osz, const char *elt) @@ -3570,11 +3615,11 @@ bool gfc_notify_std (int, const char *, ...) ATTRIBUTE_GCC_GFC(2,3); #define gfc_syntax_error(ST) \ gfc_error ("Syntax error in %s statement at %C", gfc_ascii_statement (ST)); -#include "diagnostic-buffer.h" /* For diagnostic_buffer. */ +#include "diagnostics/buffering.h" /* For diagnostics::buffer. */ struct gfc_error_buffer { bool flag; - diagnostic_buffer buffer; + diagnostics::buffer buffer; gfc_error_buffer(); }; @@ -3628,6 +3673,8 @@ extern int gfc_character_storage_size; #define gfc_integer_4_kind 4 #define gfc_real_4_kind 4 +#define gfc_integer_8_kind 8 + /* symbol.cc */ void gfc_clear_new_implicit (void); bool gfc_add_new_implicit_range (int, int); @@ -3898,7 +3945,10 @@ bool gfc_is_ptr_fcn (gfc_expr *); gfc_expr *gfc_get_expr (void); gfc_expr *gfc_get_array_expr (bt type, int kind, locus *); gfc_expr *gfc_get_null_expr (locus *); -gfc_expr *gfc_get_operator_expr (locus *, gfc_intrinsic_op,gfc_expr *, gfc_expr *); +gfc_expr *gfc_get_operator_expr (locus *, gfc_intrinsic_op, gfc_expr *, + gfc_expr *); +gfc_expr *gfc_get_conditional_expr (locus *, gfc_expr *, gfc_expr *, + gfc_expr *); gfc_expr *gfc_get_structure_constructor_expr (bt, int, locus *); gfc_expr *gfc_get_constant_expr (bt, int, locus *); gfc_expr *gfc_get_character_expr (int, locus *, const char *, gfc_charlen_t len); diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc index 753f589..ef5a17d 100644 --- a/gcc/fortran/interface.cc +++ b/gcc/fortran/interface.cc @@ -452,11 +452,20 @@ gfc_match_end_interface (void) case INTERFACE_DTIO: case INTERFACE_GENERIC: + /* If a use-associated symbol is renamed, check the local_name. */ + const char *local_name = current_interface.sym->name; + + if (current_interface.sym->attr.use_assoc + && current_interface.sym->attr.use_rename + && current_interface.sym->ns->use_stmts->rename + && (current_interface.sym->ns->use_stmts->rename->local_name[0] + != '\0')) + local_name = current_interface.sym->ns->use_stmts->rename->local_name; + if (type != current_interface.type - || strcmp (current_interface.sym->name, name) != 0) + || strcmp (local_name, name) != 0) { - gfc_error ("Expecting %<END INTERFACE %s%> at %C", - current_interface.sym->name); + gfc_error ("Expecting %<END INTERFACE %s%> at %C", local_name); m = MATCH_ERROR; } @@ -2547,7 +2556,14 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, } else if (formal->attr.function) { - if (!gfc_compare_types (&global_asym->ts, + gfc_typespec ts; + + if (global_asym->result) + ts = global_asym->result->ts; + else + ts = global_asym->ts; + + if (!gfc_compare_types (&ts, &formal->ts)) { gfc_error ("Type mismatch at %L passing global " @@ -2991,15 +3007,17 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, } -/* Returns the storage size of a symbol (formal argument) or - zero if it cannot be determined. */ +/* Returns the storage size of a symbol (formal argument) or sets argument + size_known to false if it cannot be determined. */ static unsigned long -get_sym_storage_size (gfc_symbol *sym) +get_sym_storage_size (gfc_symbol *sym, bool *size_known) { int i; unsigned long strlen, elements; + *size_known = false; + if (sym->ts.type == BT_CHARACTER) { if (sym->ts.u.cl && sym->ts.u.cl->length @@ -3013,7 +3031,10 @@ get_sym_storage_size (gfc_symbol *sym) strlen = 1; if (symbol_rank (sym) == 0) - return strlen; + { + *size_known = true; + return strlen; + } elements = 1; if (sym->as->type != AS_EXPLICIT) @@ -3030,17 +3051,19 @@ get_sym_storage_size (gfc_symbol *sym) - mpz_get_si (sym->as->lower[i]->value.integer) + 1L; } + *size_known = true; + return strlen*elements; } -/* Returns the storage size of an expression (actual argument) or - zero if it cannot be determined. For an array element, it returns - the remaining size as the element sequence consists of all storage +/* Returns the storage size of an expression (actual argument) or sets argument + size_known to false if it cannot be determined. For an array element, it + returns the remaining size as the element sequence consists of all storage units of the actual argument up to the end of the array. */ static unsigned long -get_expr_storage_size (gfc_expr *e) +get_expr_storage_size (gfc_expr *e, bool *size_known) { int i; long int strlen, elements; @@ -3048,6 +3071,8 @@ get_expr_storage_size (gfc_expr *e) bool is_str_storage = false; gfc_ref *ref; + *size_known = false; + if (e == NULL) return 0; @@ -3067,7 +3092,10 @@ get_expr_storage_size (gfc_expr *e) strlen = 1; /* Length per element. */ if (e->rank == 0 && !e->ref) - return strlen; + { + *size_known = true; + return strlen; + } elements = 1; if (!e->ref) @@ -3076,7 +3104,10 @@ get_expr_storage_size (gfc_expr *e) return 0; for (i = 0; i < e->rank; i++) elements *= mpz_get_si (e->shape[i]); - return elements*strlen; + { + *size_known = true; + return elements*strlen; + } } for (ref = e->ref; ref; ref = ref->next) @@ -3215,6 +3246,8 @@ get_expr_storage_size (gfc_expr *e) } } + *size_known = true; + if (substrlen) return (is_str_storage) ? substrlen + (elements-1)*strlen : elements*strlen; @@ -3315,7 +3348,8 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, gfc_array_spec *fas, *aas; bool pointer_dummy, pointer_arg, allocatable_arg; bool procptr_dummy, optional_dummy, allocatable_dummy; - + bool actual_size_known = false; + bool formal_size_known = false; bool ok = true; actual = *ap; @@ -3568,20 +3602,39 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, && (mpz_cmp (a->expr->ts.u.cl->length->value.integer, f->sym->ts.u.cl->length->value.integer) != 0)) { + long actual_len, formal_len; + actual_len = mpz_get_si (a->expr->ts.u.cl->length->value.integer); + formal_len = mpz_get_si (f->sym->ts.u.cl->length->value.integer); + if (where && (f->sym->attr.pointer || f->sym->attr.allocatable)) - gfc_warning (0, "Character length mismatch (%ld/%ld) between actual " - "argument and pointer or allocatable dummy argument " - "%qs at %L", - mpz_get_si (a->expr->ts.u.cl->length->value.integer), - mpz_get_si (f->sym->ts.u.cl->length->value.integer), - f->sym->name, &a->expr->where); + { + /* Emit a warning for -std=legacy and an error otherwise. */ + if (gfc_option.warn_std == 0) + gfc_warning (0, "Character length mismatch (%ld/%ld) between " + "actual argument and pointer or allocatable " + "dummy argument %qs at %L", actual_len, formal_len, + f->sym->name, &a->expr->where); + else + gfc_error ("Character length mismatch (%ld/%ld) between " + "actual argument and pointer or allocatable " + "dummy argument %qs at %L", actual_len, formal_len, + f->sym->name, &a->expr->where); + } else if (where) - gfc_warning (0, "Character length mismatch (%ld/%ld) between actual " - "argument and assumed-shape dummy argument %qs " - "at %L", - mpz_get_si (a->expr->ts.u.cl->length->value.integer), - mpz_get_si (f->sym->ts.u.cl->length->value.integer), - f->sym->name, &a->expr->where); + { + /* Emit a warning for -std=legacy and an error otherwise. */ + if (gfc_option.warn_std == 0) + gfc_warning (0, "Character length mismatch (%ld/%ld) between " + "actual argument and assumed-shape dummy argument " + "%qs at %L", actual_len, formal_len, + f->sym->name, &a->expr->where); + else + gfc_error ("Character length mismatch (%ld/%ld) between " + "actual argument and assumed-shape dummy argument " + "%qs at %L", actual_len, formal_len, + f->sym->name, &a->expr->where); + + } ok = false; goto match; } @@ -3606,21 +3659,74 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, if (a->expr->expr_type == EXPR_NULL && a->expr->ts.type == BT_UNKNOWN) goto skip_size_check; - actual_size = get_expr_storage_size (a->expr); - formal_size = get_sym_storage_size (f->sym); - if (actual_size != 0 && actual_size < formal_size - && a->expr->ts.type != BT_PROCEDURE + actual_size = get_expr_storage_size (a->expr, &actual_size_known); + formal_size = get_sym_storage_size (f->sym, &formal_size_known); + + if (actual_size_known && formal_size_known + && actual_size != formal_size + && a->expr->ts.type == BT_CHARACTER && f->sym->attr.flavor != FL_PROCEDURE) { - if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where) + /* F2018:15.5.2.4: + (3) "The length type parameter values of a present actual argument + shall agree with the corresponding ones of the dummy argument that + are not assumed, except for the case of the character length + parameter of an actual argument of type character with default + kind or C character kind associated with a dummy argument that is + not assumed-shape or assumed-rank." + + (4) "If a present scalar dummy argument is of type character with + default kind or C character kind, the length len of the dummy + argument shall be less than or equal to the length of the actual + argument. The dummy argument becomes associated with the leftmost + len characters of the actual argument. If a present array dummy + argument is of type character with default kind or C character + kind and is not assumed-shape or assumed-rank, it becomes + associated with the leftmost characters of the actual argument + element sequence." + + As an extension we treat kind=4 character similarly to kind=1. */ + + if (actual_size > formal_size) { - gfc_warning (0, "Character length of actual argument shorter " - "than of dummy argument %qs (%lu/%lu) at %L", - f->sym->name, actual_size, formal_size, - &a->expr->where); + if (a->expr->ts.type == BT_CHARACTER && where + && (!f->sym->as || f->sym->as->type == AS_EXPLICIT)) + gfc_warning (OPT_Wcharacter_truncation, + "Character length of actual argument longer " + "than of dummy argument %qs (%lu/%lu) at %L", + f->sym->name, actual_size, formal_size, + &a->expr->where); goto skip_size_check; } - else if (where) + + if (a->expr->ts.type == BT_CHARACTER && where && !f->sym->as) + { + /* Emit warning for -std=legacy/gnu and an error otherwise. */ + if (gfc_notification_std (GFC_STD_LEGACY) == ERROR) + { + gfc_error ("Character length of actual argument shorter " + "than of dummy argument %qs (%lu/%lu) at %L", + f->sym->name, actual_size, formal_size, + &a->expr->where); + ok = false; + goto match; + } + else + gfc_warning (0, "Character length of actual argument shorter " + "than of dummy argument %qs (%lu/%lu) at %L", + f->sym->name, actual_size, formal_size, + &a->expr->where); + goto skip_size_check; + } + } + + if (actual_size_known && formal_size_known + && actual_size < formal_size + && f->sym->as + && a->expr->ts.type != BT_PROCEDURE + && f->sym->attr.flavor != FL_PROCEDURE) + { + if (where) { /* Emit a warning for -std=legacy and an error otherwise. */ if (gfc_option.warn_std == 0) @@ -4765,6 +4871,13 @@ matching_typebound_op (gfc_expr** tb_base, gfc_actual_arglist* argcopy; bool matches; + /* If expression matching comes here during parsing, eg. when + parsing ASSOCIATE, generic TBPs have not yet been resolved + and g->specific will not have been set. Wait for expression + resolution by returning NULL. */ + if (!g->specific && !gfc_current_ns->resolved) + return NULL; + gcc_assert (g->specific); if (g->specific->error) continue; diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc index 2eba209..a422fc1 100644 --- a/gcc/fortran/intrinsic.cc +++ b/gcc/fortran/intrinsic.cc @@ -376,11 +376,11 @@ do_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg) Argument list: char * name of function - int whether function is elemental - int If the function can be used as an actual argument [1] - bt return type of function - int kind of return type of function - int Fortran standard version + int whether function is elemental + int If the function can be used as an actual argument [1] + bt return type of function + int kind of return type of function + int Fortran standard version check pointer to check function simplify pointer to simplification function resolve pointer to resolution function @@ -396,7 +396,7 @@ do_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg) [1] Whether a function can or cannot be used as an actual argument is - determined by its presence on the 13.6 list in Fortran 2003. The + determined by its presence in the 13.6 list in Fortran 2003. The following intrinsics, which are GNU extensions, are considered allowed as actual arguments: ACOSH ATANH DACOSH DASINH DATANH DCONJG DIMAG ZABS ZCOS ZEXP ZLOG ZSIN ZSQRT. */ @@ -3452,43 +3452,50 @@ add_functions (void) add_sym_1 ("acosd", GFC_ISYM_ACOSD, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F2023, - gfc_check_fn_r, gfc_simplify_acosd, gfc_resolve_trigd, + gfc_check_fn_r, gfc_simplify_acosd, gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); make_generic ("acosd", GFC_ISYM_ACOSD, GFC_STD_F2023); add_sym_1 ("dacosd", GFC_ISYM_ACOSD, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_acosd, gfc_resolve_trigd, + gfc_check_fn_d, gfc_simplify_acosd, gfc_resolve_trig, x, BT_REAL, dd, REQUIRED); add_sym_1 ("asind", GFC_ISYM_ASIND, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F2023, - gfc_check_fn_r, gfc_simplify_asind, gfc_resolve_trigd, + gfc_check_fn_r, gfc_simplify_asind, gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); make_generic ("asind", GFC_ISYM_ASIND, GFC_STD_F2023); add_sym_1 ("dasind", GFC_ISYM_ASIND, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_asind, gfc_resolve_trigd, + gfc_check_fn_d, gfc_simplify_asind, gfc_resolve_trig, x, BT_REAL, dd, REQUIRED); add_sym_1 ("atand", GFC_ISYM_ATAND, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F2023, - gfc_check_fn_r, gfc_simplify_atand, gfc_resolve_trigd, + gfc_check_fn_r, gfc_simplify_atand, gfc_resolve_trig, + x, BT_REAL, dr, REQUIRED); + + /* Two-argument version of atand, equivalent to atan2d. */ + add_sym_2 ("atand", GFC_ISYM_ATAN2D, CLASS_ELEMENTAL, ACTUAL_YES, + BT_REAL, dr, GFC_STD_F2023, + gfc_check_atan2, gfc_simplify_atan2d, gfc_resolve_trig2, + y, BT_REAL, dr, REQUIRED, x, BT_REAL, dr, REQUIRED); make_generic ("atand", GFC_ISYM_ATAND, GFC_STD_F2023); add_sym_1 ("datand", GFC_ISYM_ATAND, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_atand, gfc_resolve_trigd, + gfc_check_fn_d, gfc_simplify_atand, gfc_resolve_trig, x, BT_REAL, dd, REQUIRED); add_sym_2 ("atan2d", GFC_ISYM_ATAN2D, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F2023, - gfc_check_atan2, gfc_simplify_atan2d, gfc_resolve_trigd2, + gfc_check_atan2, gfc_simplify_atan2d, gfc_resolve_trig2, y, BT_REAL, dr, REQUIRED, x, BT_REAL, dr, REQUIRED); @@ -3496,78 +3503,78 @@ add_functions (void) add_sym_2 ("datan2d", GFC_ISYM_ATAN2D, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, - gfc_check_datan2, gfc_simplify_atan2d, gfc_resolve_trigd2, + gfc_check_datan2, gfc_simplify_atan2d, gfc_resolve_trig2, y, BT_REAL, dd, REQUIRED, x, BT_REAL, dd, REQUIRED); add_sym_1 ("cosd", GFC_ISYM_COSD, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F2023, - gfc_check_fn_r, gfc_simplify_cosd, gfc_resolve_trigd, + gfc_check_fn_r, gfc_simplify_cosd, gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); make_generic ("cosd", GFC_ISYM_COSD, GFC_STD_F2023); add_sym_1 ("dcosd", GFC_ISYM_COSD, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_cosd, gfc_resolve_trigd, + gfc_check_fn_d, gfc_simplify_cosd, gfc_resolve_trig, x, BT_REAL, dd, REQUIRED); add_sym_1 ("cotan", GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_GNU, - gfc_check_fn_rc2008, gfc_simplify_cotan, gfc_resolve_trigd, + gfc_check_fn_rc2008, gfc_simplify_cotan, gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); add_sym_1 ("dcotan", GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_cotan, gfc_resolve_trigd, + gfc_check_fn_d, gfc_simplify_cotan, gfc_resolve_trig, x, BT_REAL, dd, REQUIRED); add_sym_1 ("ccotan", GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_GNU, - NULL, gfc_simplify_cotan, gfc_resolve_trigd, + NULL, gfc_simplify_cotan, gfc_resolve_trig, x, BT_COMPLEX, dz, REQUIRED); add_sym_1 ("zcotan", GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU, - NULL, gfc_simplify_cotan, gfc_resolve_trigd, + NULL, gfc_simplify_cotan, gfc_resolve_trig, x, BT_COMPLEX, dd, REQUIRED); make_generic ("cotan", GFC_ISYM_COTAN, GFC_STD_GNU); add_sym_1 ("cotand", GFC_ISYM_COTAND, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_GNU, - gfc_check_fn_r, gfc_simplify_cotand, gfc_resolve_trigd, + gfc_check_fn_r, gfc_simplify_cotand, gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); add_sym_1 ("dcotand", GFC_ISYM_COTAND, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_cotand, gfc_resolve_trigd, + gfc_check_fn_d, gfc_simplify_cotand, gfc_resolve_trig, x, BT_REAL, dd, REQUIRED); make_generic ("cotand", GFC_ISYM_COTAND, GFC_STD_GNU); add_sym_1 ("sind", GFC_ISYM_SIND, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F2023, - gfc_check_fn_r, gfc_simplify_sind, gfc_resolve_trigd, + gfc_check_fn_r, gfc_simplify_sind, gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); make_generic ("sind", GFC_ISYM_SIND, GFC_STD_F2023); add_sym_1 ("dsind", GFC_ISYM_SIND, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_sind, gfc_resolve_trigd, + gfc_check_fn_d, gfc_simplify_sind, gfc_resolve_trig, x, BT_REAL, dd, REQUIRED); add_sym_1 ("tand", GFC_ISYM_TAND, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F2023, - gfc_check_fn_r, gfc_simplify_tand, gfc_resolve_trigd, + gfc_check_fn_r, gfc_simplify_tand, gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); make_generic ("tand", GFC_ISYM_TAND, GFC_STD_F2023); add_sym_1 ("dtand", GFC_ISYM_TAND, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, - gfc_check_fn_d, gfc_simplify_tand, gfc_resolve_trigd, + gfc_check_fn_d, gfc_simplify_tand, gfc_resolve_trig, x, BT_REAL, dd, REQUIRED); /* The following function is internally used for coarray libray functions. @@ -3583,6 +3590,57 @@ add_functions (void) REQUIRED, val, BT_INTEGER, di, REQUIRED, i, BT_INTEGER, di, REQUIRED); make_from_module (); + + /* The half-cycle trigonometric functions were added by Fortran 2023. */ + + add_sym_1 ("acospi", GFC_ISYM_ACOSPI, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, + GFC_STD_F2023, gfc_check_fn_r, gfc_simplify_acospi, + gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); + + make_generic ("acospi", GFC_ISYM_ACOSPI, GFC_STD_F2023); + + add_sym_1 ("asinpi", GFC_ISYM_ASINPI, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, + GFC_STD_F2023, gfc_check_fn_r, gfc_simplify_asinpi, + gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); + + make_generic ("asinpi", GFC_ISYM_ASINPI, GFC_STD_F2023); + + add_sym_1 ("atanpi", GFC_ISYM_ATANPI, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, + GFC_STD_F2023, gfc_check_fn_r, gfc_simplify_atanpi, + gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); + + /* Two-argument version of atanpi, equivalent to atan2pi. */ + add_sym_2 ("atanpi", GFC_ISYM_ATAN2PI, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, + dr, GFC_STD_F2023, gfc_check_atan2, gfc_simplify_atan2pi, + gfc_resolve_trig2, y, BT_REAL, dr, REQUIRED, x, BT_REAL, dr, + REQUIRED); + + make_generic ("atanpi", GFC_ISYM_ATANPI, GFC_STD_F2023); + + add_sym_2 ("atan2pi", GFC_ISYM_ATAN2PI, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, + dr, GFC_STD_F2023, gfc_check_atan2, gfc_simplify_atan2pi, + gfc_resolve_trig2, y, BT_REAL, dr, REQUIRED, x, BT_REAL, dr, + REQUIRED); + + make_generic ("atan2pi", GFC_ISYM_ATAN2PI, GFC_STD_F2023); + + add_sym_1 ("cospi", GFC_ISYM_COSPI, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, + GFC_STD_F2023, gfc_check_fn_r, gfc_simplify_cospi, + gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); + + make_generic ("cospi", GFC_ISYM_COSPI, GFC_STD_F2023); + + add_sym_1 ("sinpi", GFC_ISYM_SINPI, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, + GFC_STD_F2023, gfc_check_fn_r, gfc_simplify_sinpi, + gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); + + make_generic ("sinpi", GFC_ISYM_SINPI, GFC_STD_F2023); + + add_sym_1 ("tanpi", GFC_ISYM_TANPI, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, + GFC_STD_F2023, gfc_check_fn_r, gfc_simplify_tanpi, + gfc_resolve_trig, x, BT_REAL, dr, REQUIRED); + + make_generic ("tanpi", GFC_ISYM_TANPI, GFC_STD_F2023); } @@ -3875,13 +3933,22 @@ add_subroutines (void) pt, BT_INTEGER, di, OPTIONAL, INTENT_IN, gt, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + add_sym_4s ("split", GFC_ISYM_SPLIT, CLASS_PURE, + BT_UNKNOWN, 0, GFC_STD_F2023, + gfc_check_split, NULL, gfc_resolve_split, + "string", BT_CHARACTER, dc, REQUIRED, INTENT_IN, + "set", BT_CHARACTER, dc, REQUIRED, INTENT_IN, + "pos", BT_INTEGER, di, REQUIRED, INTENT_INOUT, + "back", BT_LOGICAL, dl, OPTIONAL, INTENT_IN); + /* The following subroutines are part of ISO_C_BINDING. */ - add_sym_3s ("c_f_pointer", GFC_ISYM_C_F_POINTER, CLASS_IMPURE, BT_UNKNOWN, 0, + add_sym_4s ("c_f_pointer", GFC_ISYM_C_F_POINTER, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_F2003, gfc_check_c_f_pointer, NULL, NULL, "cptr", BT_VOID, 0, REQUIRED, INTENT_IN, "fptr", BT_UNKNOWN, 0, REQUIRED, INTENT_OUT, - "shape", BT_INTEGER, di, OPTIONAL, INTENT_IN); + "shape", BT_INTEGER, di, OPTIONAL, INTENT_IN, + "lower", BT_INTEGER, di, OPTIONAL, INTENT_IN); make_from_module(); add_sym_2s ("c_f_procpointer", GFC_ISYM_C_F_PROCPOINTER, CLASS_IMPURE, @@ -5399,6 +5466,9 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag, if (ts->type == BT_UNKNOWN) goto bad; + if (from_ts.type == BT_DERIVED && from_ts.u.derived->attr.pdt_type) + *ts = from_ts; + expr->do_not_warn = ! wflag; /* NULL and zero size arrays get their type here, unless they already have a diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index 767792c..048196d 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -165,7 +165,7 @@ bool gfc_check_sign (gfc_expr *, gfc_expr *); bool gfc_check_signal (gfc_expr *, gfc_expr *); bool gfc_check_sizeof (gfc_expr *); bool gfc_check_c_associated (gfc_expr *, gfc_expr *); -bool gfc_check_c_f_pointer (gfc_expr *, gfc_expr *, gfc_expr *); +bool gfc_check_c_f_pointer (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_c_f_procpointer (gfc_expr *, gfc_expr *); bool gfc_check_c_funloc (gfc_expr *); bool gfc_check_c_loc (gfc_expr *); @@ -215,6 +215,7 @@ bool gfc_check_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, bool gfc_check_random_init (gfc_expr *, gfc_expr *); bool gfc_check_random_number (gfc_expr *); bool gfc_check_random_seed (gfc_expr *, gfc_expr *, gfc_expr *); +bool gfc_check_split (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_dtime_etime_sub (gfc_expr *, gfc_expr *); bool gfc_check_fgetputc_sub (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_fgetput_sub (gfc_expr *, gfc_expr *); @@ -246,6 +247,7 @@ gfc_expr *gfc_simplify_achar (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_acos (gfc_expr *); gfc_expr *gfc_simplify_acosd (gfc_expr *); gfc_expr *gfc_simplify_acosh (gfc_expr *); +gfc_expr *gfc_simplify_acospi (gfc_expr *); gfc_expr *gfc_simplify_adjustl (gfc_expr *); gfc_expr *gfc_simplify_adjustr (gfc_expr *); gfc_expr *gfc_simplify_aimag (gfc_expr *); @@ -259,11 +261,14 @@ gfc_expr *gfc_simplify_and (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_any (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_asin (gfc_expr *); gfc_expr *gfc_simplify_asinh (gfc_expr *); +gfc_expr *gfc_simplify_asinpi (gfc_expr *); gfc_expr *gfc_simplify_atan (gfc_expr *); gfc_expr *gfc_simplify_atand (gfc_expr *); gfc_expr *gfc_simplify_atanh (gfc_expr *); +gfc_expr *gfc_simplify_atanpi (gfc_expr *); gfc_expr *gfc_simplify_atan2 (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_atan2d (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_atan2pi (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_bessel_j0 (gfc_expr *); gfc_expr *gfc_simplify_bessel_j1 (gfc_expr *); gfc_expr *gfc_simplify_bessel_jn (gfc_expr *, gfc_expr *); @@ -288,6 +293,7 @@ gfc_expr *gfc_simplify_conjg (gfc_expr *); gfc_expr *gfc_simplify_cos (gfc_expr *); gfc_expr *gfc_simplify_cosd (gfc_expr *); gfc_expr *gfc_simplify_cosh (gfc_expr *); +gfc_expr *gfc_simplify_cospi (gfc_expr *); gfc_expr *gfc_simplify_cotan (gfc_expr *); gfc_expr *gfc_simplify_cotand (gfc_expr *); gfc_expr *gfc_simplify_count (gfc_expr *, gfc_expr *, gfc_expr *); @@ -421,6 +427,7 @@ gfc_expr *gfc_simplify_shiftr (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_sin (gfc_expr *); gfc_expr *gfc_simplify_sind (gfc_expr *); gfc_expr *gfc_simplify_sinh (gfc_expr *); +gfc_expr *gfc_simplify_sinpi (gfc_expr *); gfc_expr *gfc_simplify_size (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_sizeof (gfc_expr *); gfc_expr *gfc_simplify_storage_size (gfc_expr *, gfc_expr *); @@ -432,6 +439,7 @@ gfc_expr *gfc_simplify_sum (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_tan (gfc_expr *); gfc_expr *gfc_simplify_tand (gfc_expr *); gfc_expr *gfc_simplify_tanh (gfc_expr *); +gfc_expr *gfc_simplify_tanpi (gfc_expr *); gfc_expr *gfc_simplify_this_image (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_tiny (gfc_expr *); gfc_expr *gfc_simplify_trailz (gfc_expr *); @@ -631,8 +639,8 @@ void gfc_resolve_time (gfc_expr *); void gfc_resolve_time8 (gfc_expr *); void gfc_resolve_transfer (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_transpose (gfc_expr *, gfc_expr *); -void gfc_resolve_trigd (gfc_expr *, gfc_expr *); -void gfc_resolve_trigd2 (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_trig (gfc_expr *, gfc_expr *); +void gfc_resolve_trig2 (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_trim (gfc_expr *, gfc_expr *); void gfc_resolve_ttynam (gfc_expr *, gfc_expr *); void gfc_resolve_ubound (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); @@ -686,6 +694,7 @@ void gfc_resolve_link_sub (gfc_code *); void gfc_resolve_symlnk_sub (gfc_code *); void gfc_resolve_signal_sub (gfc_code *); void gfc_resolve_sleep_sub (gfc_code *); +void gfc_resolve_split (gfc_code *); void gfc_resolve_stat_sub (gfc_code *); void gfc_resolve_system_clock (gfc_code *); void gfc_resolve_system_sub (gfc_code *); diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index 3a105bc..9012c2a 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -24,15 +24,22 @@ Some basic guidelines for editing this document: @tex \gdef\acosd{\mathop{\rm acosd}\nolimits} -\gdef\asind{\mathop{\rm asind}\nolimits} -\gdef\atand{\mathop{\rm atand}\nolimits} -\gdef\acos{\mathop{\rm acos}\nolimits} -\gdef\asin{\mathop{\rm asin}\nolimits} -\gdef\atan{\mathop{\rm atan}\nolimits} \gdef\acosh{\mathop{\rm acosh}\nolimits} +\gdef\acospi{\mathop{\rm acospi}\nolimits} +\gdef\acos{\mathop{\rm acos}\nolimits} +\gdef\asind{\mathop{\rm asind}\nolimits} \gdef\asinh{\mathop{\rm asinh}\nolimits} +\gdef\asinpi{\mathop{\rm asinpi}\nolimits} +\gdef\asin{\mathop{\rm asin}\nolimits} +\gdef\atan2pi{\mathop{\rm atan2pi}\nolimits} +\gdef\atand{\mathop{\rm atand}\nolimits} \gdef\atanh{\mathop{\rm atanh}\nolimits} +\gdef\atanpi{\mathop{\rm atanpi}\nolimits} +\gdef\atan{\mathop{\rm atan}\nolimits} \gdef\cosd{\mathop{\rm cosd}\nolimits} +\gdef\cospi{\mathop{\rm cospi}\nolimits} +\gdef\sinpi{\mathop{\rm sinpi}\nolimits} +\gdef\tanpi{\mathop{\rm tanpi}\nolimits} @end tex @@ -49,6 +56,7 @@ Some basic guidelines for editing this document: * @code{ACOS}: ACOS, Arccosine function * @code{ACOSD}: ACOSD, Arccosine function, degrees * @code{ACOSH}: ACOSH, Inverse hyperbolic cosine function +* @code{ACOSPI}: ACOSPI, Circular arc cosine function * @code{ADJUSTL}: ADJUSTL, Left adjust a string * @code{ADJUSTR}: ADJUSTR, Right adjust a string * @code{AIMAG}: AIMAG, Imaginary part of complex number @@ -62,12 +70,15 @@ Some basic guidelines for editing this document: * @code{ASIN}: ASIN, Arcsine function * @code{ASIND}: ASIND, Arcsine function, degrees * @code{ASINH}: ASINH, Inverse hyperbolic sine function +* @code{ASINPI}: ASINPI, Circular arc sine function * @code{ASSOCIATED}: ASSOCIATED, Status of a pointer or pointer/target pair * @code{ATAN}: ATAN, Arctangent function -* @code{ATAND}: ATAND, Arctangent function, degrees * @code{ATAN2}: ATAN2, Arctangent function * @code{ATAN2D}: ATAN2D, Arctangent function, degrees +* @code{ATAN2PI}: ATAN2PI, Circular arc tangent function +* @code{ATAND}: ATAND, Arctangent function, degrees * @code{ATANH}: ATANH, Inverse hyperbolic tangent function +* @code{ATANPI}: ATANPI, Circular arc tangent function * @code{ATOMIC_ADD}: ATOMIC_ADD, Atomic ADD operation * @code{ATOMIC_AND}: ATOMIC_AND, Atomic bitwise AND operation * @code{ATOMIC_CAS}: ATOMIC_CAS, Atomic compare and swap @@ -116,6 +127,7 @@ Some basic guidelines for editing this document: * @code{COS}: COS, Cosine function * @code{COSD}: COSD, Cosine function, degrees * @code{COSH}: COSH, Hyperbolic cosine function +* @code{COSPI}: COSPI, Circular cosine function * @code{COTAN}: COTAN, Cotangent function * @code{COTAND}: COTAND, Cotangent function, degrees * @code{COUNT}: COUNT, Count occurrences of TRUE in an array @@ -296,10 +308,12 @@ Some basic guidelines for editing this document: * @code{SIN}: SIN, Sine function * @code{SIND}: SIND, Sine function, degrees * @code{SINH}: SINH, Hyperbolic sine function +* @code{SINPI}: SINPI, Circular sine function * @code{SIZE}: SIZE, Function to determine the size of an array * @code{SIZEOF}: SIZEOF, Determine the size in bytes of an expression * @code{SLEEP}: SLEEP, Sleep for the specified number of seconds * @code{SPACING}: SPACING, Smallest distance between two numbers of a given type +* @code{SPLIT}: SPLIT, Parse a string into tokens, one at a time. * @code{SPREAD}: SPREAD, Add a dimension to an array * @code{SQRT}: SQRT, Square-root function * @code{SRAND}: SRAND, Reinitialize the random number generator @@ -312,6 +326,7 @@ Some basic guidelines for editing this document: * @code{TAN}: TAN, Tangent function * @code{TAND}: TAND, Tangent function, degrees * @code{TANH}: TANH, Hyperbolic tangent function +* @code{TANPI}: TANPI, Circular tangent function * @code{TEAM_NUMBER}: TEAM_NUMBER, Retrieve team id of given team * @code{THIS_IMAGE}: THIS_IMAGE, Cosubscript index of this image * @code{TIME}: TIME, Time function @@ -754,6 +769,62 @@ Inverse function: @* +@node ACOSPI +@section @code{ACOSPI} --- Circular arc cosine function +@fnindex ACOSPI +@cindex trigonometric function, cosine, inverse + +@table @asis +@item @emph{Description}: +@code{ACOSPI(X)} computes @math{ \acos(x) / \pi}, which is a measure +of an angle in half-revolutions. + +@item @emph{Standard}: +Fortran 2023 + +@item @emph{Class}: +Elemental function + +@item @emph{Syntax}: +@code{RESULT = ACOSPI(X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{X} @tab The type shall be @code{REAL} with @math{-1 \leq x \leq 1}. +@end multitable + +@item @emph{Return value}: +The return value has the same type and kind as @var{X}. +It is expressed in half-revolutions and satisfies +@math{ 0 \leq \acospi (x) \leq 1}. + +@item @emph{Example}: +@smallexample +program test_acospi + implicit none + real, parameter :: x = 0.123, y(3) = [0.123, 0.45, 0.8] + real, parameter :: a = acospi(x), b(3) = acospi(y) + call foo(x, y) +contains + subroutine foo(u, v) + real, intent(in) :: u, v(:) + real :: f, g(size(v)) + f = acospi(u) + g = acospi(v) + if (abs(a - f) > 8 * epsilon(f)) stop 1 + if (any(abs(g - b) > 8 * epsilon(f))) stop 2 + end subroutine foo +end program test_acospi +@end smallexample + +@item @emph{See also}: +@ref{ASINPI} @* +@ref{ATAN2PI} @* +@ref{ATANPI} @* +@end table + + + @node ADJUSTL @section @code{ADJUSTL} --- Left adjust a string @fnindex ADJUSTL @@ -1469,6 +1540,62 @@ Inverse function: @* +@node ASINPI +@section @code{ASINPI} --- Circular arc sine function +@fnindex ASINPI +@cindex trigonometric function, sine, inverse + +@table @asis +@item @emph{Description}: +@code{ASINPI(X)} computes @math{ \asin(x) / \pi}, which is a measure +of an angle in half-revolutions. + +@item @emph{Standard}: +Fortran 2023 + +@item @emph{Class}: +Elemental function + +@item @emph{Syntax}: +@code{RESULT = ASINPI(X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{X} @tab The type shall be @code{REAL} with @math{-1 \leq x \leq 1}. +@end multitable + +@item @emph{Return value}: +The return value has the same type and kind as @var{X}. +It is expressed in half-revolutions and satisfies +@math{ -0.5 \leq \asinpi (x) \leq 0.5}. + +@item @emph{Example}: +@smallexample +program test_asinpi + implicit none + real, parameter :: x = 0.123, y(3) = [0.123, 0.45, 0.8] + real, parameter :: a = asinpi(x), b(3) = asinpi(y) + call foo(x, y) +contains + subroutine foo(u, v) + real, intent(in) :: u, v(:) + real :: f, g(size(v)) + f = asinpi(u) + g = asinpi(v) + if (abs(a - f) > 8 * epsilon(f)) stop 1 + if (any(abs(g - b) > 8 * epsilon(f))) stop 2 + end subroutine foo +end program test_asinpi +@end smallexample + +@item @emph{See also}: +@ref{ACOSPI} @* +@ref{ATAN2PI} @* +@ref{ATANPI} @* +@end table + + + @node ASSOCIATED @section @code{ASSOCIATED} --- Status of a pointer or pointer/target pair @fnindex ASSOCIATED @@ -1547,7 +1674,7 @@ Fortran 90 and later @node ATAN -@section @code{ATAN} --- Arctangent function +@section @code{ATAN} --- Arctangent function @fnindex ATAN @fnindex DATAN @cindex trigonometric function, tangent, inverse @@ -1608,65 +1735,6 @@ Degrees function: @* -@node ATAND -@section @code{ATAND} --- Arctangent function, degrees -@fnindex ATAND -@fnindex DATAND -@cindex trigonometric function, tangent, inverse, degrees -@cindex tangent, inverse, degrees - -@table @asis -@item @emph{Synopsis}: -@multitable @columnfractions .80 -@item @code{RESULT = ATAND(X)} -@end multitable - -@item @emph{Description}: -@code{ATAND(X)} computes the arctangent of @var{X} in degrees (inverse of -@ref{TAND}). - -@item @emph{Class}: -Elemental function - -@item @emph{Arguments}: -@multitable @columnfractions .15 .70 -@item @var{X} @tab The type shall be @code{REAL}; -if @var{Y} is present, @var{X} shall be REAL. -@item @var{Y} @tab The type and kind type parameter shall be the same as @var{X}. -@end multitable - -@item @emph{Return value}: -The return value is of the same type and kind as @var{X}. -The result is in degrees and lies in the range -@math{-90 \leq \Re \atand(x) \leq 90}. - -@item @emph{Example}: -@smallexample -program test_atand - real(8) :: x = 2.866_8 - x = atand(x) -end program test_atand -@end smallexample - -@item @emph{Specific names}: -@multitable @columnfractions .23 .23 .20 .30 -@headitem Name @tab Argument @tab Return type @tab Standard -@item @code{ATAND(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab Fortran 2023 -@item @code{DATAND(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab GNU extension -@end multitable - -@item @emph{Standard}: -Fortran 2023 - -@item @emph{See also}: -Inverse function: @* -@ref{TAND} @* -Radians function: @* -@ref{ATAN} -@end table - - - @node ATAN2 @section @code{ATAN2} --- Arctangent function @fnindex ATAN2 @@ -1795,6 +1863,117 @@ Radians function: @* @ref{ATAN2} @end table + + +@node ATAN2PI +@section @code{ATAN2PI} --- Circular arc tangent function +@fnindex ATAN2PI +@cindex trigonometric function, tangent, inverse + +@table @asis +@item @emph{Description}: +@code{ATAN2PI(Y, X)} computes @math{ {\rm {atan2}}(y, x) / \pi}, +and provides a measure of an angle in half-revolutions within +the proper quadrant. + +@item @emph{Standard}: +Fortran 2023 + +@item @emph{Class}: +Elemental function + +@item @emph{Syntax}: +@code{RESULT = ATAN2PI(Y, X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{Y} @tab The type shall be @code{REAL}. +@item @var{X} @tab The type and kind type parameter shall be the +same as @var{Y}. If @var{Y} is zero, then @var{X} shall be nonzero. +@end multitable + +@item @emph{Return value}: +The return value has the same type and kind type parameter as @var{Y} +and satisfies @math{-1 \leq {\rm {atan2}}(y, x) / \pi \leq 1}. + +@item @emph{Example}: +@smallexample +program test_atan2pi + real(kind=4) :: x = 1.e0_4, y = 0.5e0_4 + x = atan2pi(y, x) +end program test_atan2pi +@end smallexample + +@item @emph{See also}: +@ref{ACOSPI} @* +@ref{ASINPI} @* +@ref{ATANPI} @* +@end table + + + +@node ATAND +@section @code{ATAND} --- Arctangent function, degrees +@fnindex ATAND +@fnindex DATAND +@cindex trigonometric function, tangent, inverse, degrees +@cindex tangent, inverse, degrees + +@table @asis +@item @emph{Synopsis}: +@multitable @columnfractions .80 +@item @code{RESULT = ATAND(X)} +@item @code{RESULT = ATAND(Y, X)} +@end multitable + +@item @emph{Description}: +@code{ATAND(X)} computes the arctangent of @var{X} in degrees (inverse of +@ref{TAND}). + +@item @emph{Class}: +Elemental function + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{X} @tab The type shall be @code{REAL}. +@item @var{Y} @tab The type and kind type parameter shall be the same as @var{X}. +@end multitable + +@item @emph{Return value}: +The return value is of the same type and kind as @var{X}. +If @var{Y} is present, the result is identical to @code{ATAN2D(Y, X)}. +Otherwise, the result is in degrees and lies in the range +@math{-90 \leq \atand(x) \leq 90}. + +@item @emph{Example}: +@smallexample +program test_atand + real(8) :: x = 2.866_8 + real(4) :: x1 = 1.e0_4, y1 = 0.5e0_4 + x = atand(x) + x1 = atand(y1, x1) +end program test_atand +@end smallexample + +@item @emph{Specific names}: +@multitable @columnfractions .23 .23 .20 .30 +@headitem Name @tab Argument @tab Return type @tab Standard +@item @code{ATAND(X)} @tab @code{REAL(4) X} @tab @code{REAL(4)} @tab Fortran 2023 +@item @code{DATAND(X)} @tab @code{REAL(8) X} @tab @code{REAL(8)} @tab GNU extension +@end multitable + +@item @emph{Standard}: +Fortran 2023 + +@item @emph{See also}: +Inverse function: @* +@ref{TAND} @* +Radians function: @* +@ref{ATAN} +@end table + + + @node ATANH @section @code{ATANH} --- Inverse hyperbolic tangent function @fnindex ATANH @@ -1848,6 +2027,70 @@ Inverse function: @* +@node ATANPI +@section @code{ATANPI} --- Circular arc tangent function +@fnindex ATANPI +@cindex trigonometric function, tangent, inverse + +@table @asis +@item @emph{Description}: +@code{ATANPI(X)} computes @math{ \atan(x) / \pi}. +@code{ATANPI(Y, X)} computes @math{ {\rm atan2}(y, x) / \pi}. +These provide a measure of an angle in half-revolutions. + +@item @emph{Standard}: +Fortran 2023 + +@item @emph{Class}: +Elemental function + +@item @emph{Syntax}: +@multitable @columnfractions .80 +@item @code{RESULT = ATANPI(X)} +@item @code{RESULT = ATANPI(Y, X)} +@end multitable + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{Y} @tab The type shall be @code{REAL}. +@item @var{X} @tab If @var{Y} appears, @var{X} shall have the same type +and kind as @var{Y}. If @var{Y} is zero, then @var{X} shall not be zero. +If @var{Y} does not appear in a function reference, then @var{X} shall be +@code{REAL}. +@end multitable + +@item @emph{Return value}: +The return value has the same type and kind as @var{X}. +It is expressed in half-revolutions and satisfies +@math{ -0.5 \leq \atanpi (x) \leq 0.5}. + +@item @emph{Example}: +@smallexample +program test_atanpi + implicit none + real, parameter :: x = 0.123, y(3) = [0.123, 0.45, 0.8] + real, parameter :: a = atanpi(x), b(3) = atanpi(y) + call foo(x, y) +contains + subroutine foo(u, v) + real, intent(in) :: u, v(:) + real :: f, g(size(v)) + f = atanpi(u) + g = atanpi(v) + if (abs(a - f) > 8 * epsilon(f)) stop 1 + if (any(abs(g - b) > 8 * epsilon(f))) stop 2 + end subroutine foo +end program test_atanpi +@end smallexample + +@item @emph{See also}: +@ref{ACOSPI} @* +@ref{ASINPI} @* +@ref{ATAN2PI} @* +@end table + + + @node ATOMIC_ADD @section @code{ATOMIC_ADD} --- Atomic ADD operation @fnindex ATOMIC_ADD @@ -3125,11 +3368,13 @@ Fortran 2003 and later @table @asis @item @emph{Synopsis}: -@code{CALL C_F_POINTER(CPTR, FPTR[, SHAPE])} +@code{CALL C_F_POINTER(CPTR, FPTR[, SHAPE, LOWER])} @item @emph{Description}: -@code{C_F_POINTER(CPTR, FPTR[, SHAPE])} assigns the target of the C pointer -@var{CPTR} to the Fortran pointer @var{FPTR} and specifies its shape. +@code{C_F_POINTER(CPTR, FPTR[, SHAPE, LOWER])} assigns the target of the C +pointer @var{CPTR} to the Fortran pointer @var{FPTR} and specifies its shape. +For an array @var{FPTR}, the lower bounds are specified by @var{LOWER} if +present and otherwise equal to 1. @item @emph{Class}: Subroutine @@ -3141,9 +3386,11 @@ Subroutine @item @var{FPTR} @tab pointer interoperable with @var{cptr}. It is @code{INTENT(OUT)}. @item @var{SHAPE} @tab (Optional) Rank-one array of type @code{INTEGER} -with @code{INTENT(IN)}. It shall be present -if and only if @var{fptr} is an array. The size -must be equal to the rank of @var{fptr}. +with @code{INTENT(IN)}. It shall be present if and only if @var{FPTR} is an +array. The size must be equal to the rank of @var{FPTR}. +@item @var{LOWER} @tab (Optional) Rank-one array of type @code{INTEGER} +with @code{INTENT(IN)}. It shall not be present if @var{SHAPE} is not present. +The size must be equal to the rank of @var{FPTR}. @end multitable @item @emph{Example}: @@ -3165,7 +3412,7 @@ end program main @end smallexample @item @emph{Standard}: -Fortran 2003 and later +Fortran 2003 and later, with @var{LOWER} argument Fortran 2023 and later @item @emph{See also}: @ref{C_LOC}, @* @@ -4388,6 +4635,57 @@ Inverse function: @* +@node COSPI +@section @code{COSPI} --- Circular cosine function +@fnindex COSPI +@cindex trigonometric function, cosine +@cindex cosine + +@table @asis +@item @emph{Description}: +@code{COSPI(X)} computes @math{\cos(\pi x)} without performing +an explicit multiplication by @math{\pi}. This is achieved +through argument reduction where @math{ x = n + r } with +@math{n} an integer and @math{0 \leq r \le 1}. +Due to the +properties of floating-point arithmetic, the useful range +for @var{X} is defined by +@code{ABS(X) <= REAL(2,KIND(X))**DIGITS(X)}. + +@item @emph{Standard}: +Fortran 2023 + +@item @emph{Class}: +Elemental function + +@item @emph{Syntax}: +@code{RESULT = COSPI(X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{X} @tab The type shall be @code{REAL}. +@end multitable + +@item @emph{Return value}: +The return value is of the same type and kind as @var{X}. +The result is in half-revolutions and satisfies +@math{ -1 \leq \cospi (x) \leq 1}. + +@item @emph{Example}: +@smallexample +program test_cospi + real :: x = 0.0 + x = cospi(x) +end program test_cospi +@end smallexample + +@item @emph{See also}: +@ref{ACOSPI} @* +@ref{COS} @* +@end table + + + @node COTAN @section @code{COTAN} --- Cotangent function @fnindex COTAN @@ -6516,7 +6814,6 @@ GNU extension @end table - @node FRACTION @section @code{FRACTION} --- Fractional part of the model representation @fnindex FRACTION @@ -6542,14 +6839,15 @@ Elemental function @item @emph{Return value}: The return value is of the same type and kind as the argument. The fractional part of the model representation of @code{X} is returned; -it is @code{X * RADIX(X)**(-EXPONENT(X))}. +it is @code{X * REAL(RADIX(X))**(-EXPONENT(X))}. @item @emph{Example}: @smallexample program test_fraction + implicit none real :: x x = 178.1387e-4 - print *, fraction(x), x * radix(x)**(-exponent(x)) + print *, fraction(x), x * real(radix(x))**(-exponent(x)) end program test_fraction @end smallexample @@ -6694,7 +6992,7 @@ GNU extension @end multitable @item @emph{Description}: -@code{FSTAT} is identical to @ref{STAT}, except that information about an +@code{FSTAT} is identical to @ref{STAT}, except that information about an already opened file is obtained. The elements in @code{VALUES} are the same as described by @ref{STAT}. @@ -6708,9 +7006,11 @@ Subroutine, function @item @emph{Arguments}: @multitable @columnfractions .15 .70 @item @var{UNIT} @tab An open I/O unit number of type @code{INTEGER}. -@item @var{VALUES} @tab The type shall be @code{INTEGER(4), DIMENSION(13)}. -@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER(4)}. Returns 0 -on success and a system specific error code otherwise. +@item @var{VALUES} @tab The type shall be @code{INTEGER, DIMENSION(13)} +of either kind 4 or kind 8. +@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER} +of kind 2 or larger. +Returns 0 on success and a system specific error code otherwise. @end multitable @item @emph{Example}: @@ -10013,8 +10313,10 @@ Subroutine, function @multitable @columnfractions .15 .70 @item @var{NAME} @tab The type shall be @code{CHARACTER} of the default kind, a valid path within the file system. -@item @var{VALUES} @tab The type shall be @code{INTEGER(4), DIMENSION(13)}. -@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER(4)}. +@item @var{VALUES} @tab The type shall be @code{INTEGER, DIMENSION(13)} +of either kind 4 or kind 8. +@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER} +of kind 2 or larger. Returns 0 on success and a system specific error code otherwise. @end multitable @@ -13674,6 +13976,57 @@ a GNU extension +@node SINPI +@section @code{SINPI} --- Circular sine function +@fnindex SINPI +@cindex trigonometric function, sine +@cindex sine + +@table @asis +@item @emph{Description}: +@code{SINPI(X)} computes @math{\sin(\pi x)} without performing +an explicit multiplication by @math{\pi}. This is achieved +through argument reduction where @math{ |x| = n + r } with +@math{n} an integer and @math{0 \leq r \le 1}. +Due to the +properties of floating-point arithmetic, the useful range +for @var{X} is defined by +@code{ABS(X) <= REAL(2,KIND(X))**DIGITS(X)}. + +@item @emph{Standard}: +Fortran 2023 + +@item @emph{Class}: +Elemental function + +@item @emph{Syntax}: +@code{RESULT = SINPI(X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{X} @tab The type shall be @code{REAL}. +@end multitable + +@item @emph{Return value}: +The return value is of the same type and kind as @var{X}. +The result is in half-revolutions and satisfies +@math{ -1 \leq \sinpi (x) \leq 1}. + +@item @emph{Example}: +@smallexample +program test_sinpi + real :: x = 0.0 + x = sinpi(x) +end program test_sinpi +@end smallexample + +@item @emph{See also}: +@ref{ASINPI} @* +@ref{SIN} @* +@end table + + + @node SIZE @section @code{SIZE} --- Determine the size of an array @fnindex SIZE @@ -13855,6 +14208,69 @@ Fortran 90 and later +@node SPLIT +@section @code{SPLIT} --- Parse a string into tokens, one at a time +@fnindex SPLIT +@cindex string, split + +@table @asis +@item @emph{Synopsis}: +@code{RESULT = SPLIT(STRING, SET, POS [, BACK])} + +@item @emph{Description}: +Updates the integer @var{POS} to the position of the next (or previous) +separator in @var{STRING}. + +If @var{BACK} is absent or is present with the value false, @var{POS} is +assigned the position of the leftmost token delimiter in @var{STRING} whose +position is greater than @var{POS}, or if there is no such character, it is +assigned a value one greater than the length of @var{STRING}. This identifies +a token with starting position one greater than the value of @var{POS} on +invocation, and ending position one less than the value of @var{POS} on return. + +If @var{BACK} is present with the value true, @var{POS} is assigned the +position of the rightmost token delimiter in @var{STRING} whose position is +less than @var{POS}, or if there is no such character, it is assigned the value +zero. This identifies a token with ending position one less than the value of +@var{POS} on invocation, and starting position one greater than the value of +@var{POS} on return. + +@item @emph{Class}: +Subroutine + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{STRING} @tab Shall be of type @code{CHARACTER}. +@item @var{SET} @tab Shall be of type @code{CHARACTER}. +@item @var{POS} @tab Shall be of type @code{INTEGER}. +@item @var{BACK} @tab (Optional) Shall be of type @code{LOGICAL}. +@end multitable + +@item @emph{Example}: +@smallexample +character(len=:), allocatable :: input +character(len=2) :: set = ', ' +integer :: p +input = "one,last example" +p = 0 +do + if (p > len(input)) exit + istart = p + 1 + call split(input, set, p) + iend = p - 1 + print '(t7, a)', input(istart:iend) +end do +@end smallexample + +@item @emph{Standard}: +Fortran 2023 + +@item @emph{See also}: +@ref{SCAN} +@end table + + + @node SPREAD @section @code{SPREAD} --- Add a dimension to an array @fnindex SPREAD @@ -14024,29 +14440,31 @@ GNU extension @end multitable @item @emph{Description}: -This function returns information about a file. No permissions are required on -the file itself, but execute (search) permission is required on all of the +This function returns information about a file. No permissions are required on +the file itself, but execute (search) permission is required on all of the directories in path that lead to the file. The elements that are obtained and stored in the array @code{VALUES}: @multitable @columnfractions .15 .70 -@item @code{VALUES(1)} @tab Device ID -@item @code{VALUES(2)} @tab Inode number -@item @code{VALUES(3)} @tab File mode -@item @code{VALUES(4)} @tab Number of links -@item @code{VALUES(5)} @tab Owner's uid -@item @code{VALUES(6)} @tab Owner's gid -@item @code{VALUES(7)} @tab ID of device containing directory entry for file (0 if not available) -@item @code{VALUES(8)} @tab File size (bytes) -@item @code{VALUES(9)} @tab Last access time -@item @code{VALUES(10)} @tab Last modification time -@item @code{VALUES(11)} @tab Last file status change time -@item @code{VALUES(12)} @tab Preferred I/O block size (-1 if not available) +@item @code{VALUES(1)} @tab Device ID +@item @code{VALUES(2)} @tab Inode number +@item @code{VALUES(3)} @tab File mode +@item @code{VALUES(4)} @tab Number of links +@item @code{VALUES(5)} @tab Owner's uid +@item @code{VALUES(6)} @tab Owner's gid +@item @code{VALUES(7)} @tab ID of device containing directory entry for file (0 if not available) +@item @code{VALUES(8)} @tab File size (bytes) +@item @code{VALUES(9)} @tab Last access time +@item @code{VALUES(10)} @tab Last modification time +@item @code{VALUES(11)} @tab Last file status change time +@item @code{VALUES(12)} @tab Preferred I/O block size (-1 if not available) @item @code{VALUES(13)} @tab Number of blocks allocated (-1 if not available) @end multitable -Not all these elements are relevant on all systems. +Not all these elements are relevant on all systems. If an element is not relevant, it is returned as 0. +If the value of an element would overflow the range of default integer, +a -1 is returned instead. This intrinsic is provided in both subroutine and function forms; however, only one form can be used in any given program unit. @@ -14058,9 +14476,11 @@ Subroutine, function @multitable @columnfractions .15 .70 @item @var{NAME} @tab The type shall be @code{CHARACTER}, of the default kind and a valid path within the file system. -@item @var{VALUES} @tab The type shall be @code{INTEGER(4), DIMENSION(13)}. -@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER(4)}. Returns 0 -on success and a system specific error code otherwise. +@item @var{VALUES} @tab The type shall be @code{INTEGER, DIMENSION(13)} +of either kind 4 or kind 8. +@item @var{STATUS} @tab (Optional) status flag of type @code{INTEGER} +of kind 2 or larger. +Returns 0 on success and a system specific error code otherwise. @end multitable @item @emph{Example}: @@ -14523,6 +14943,55 @@ Fortran 77 and later, for a complex argument Fortran 2008 or later +@node TANPI +@section @code{TANPI} --- Circular tangent function +@fnindex TANPI +@cindex trigonometric function, tangent +@cindex tangent + +@table @asis +@item @emph{Description}: +@code{TANPI(X)} computes @math{\tan(\pi x)} without performing +an explicit multiplication by @math{\pi}. This is achieved +through argument reduction where @math{ |x| = n + r } with +@math{n} an integer and @math{0 \leq r \le 1}. +Due to the +properties of floating-point arithmetic, the useful range +for @var{X} is defined by +@code{ABS(X) <= REAL(2,KIND(X))**DIGITS(X)}. + +@item @emph{Standard}: +Fortran 2023 + +@item @emph{Class}: +Elemental function + +@item @emph{Syntax}: +@code{RESULT = TANPI(X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{X} @tab The type shall be @code{REAL}. +@end multitable + +@item @emph{Return value}: +The return value is of the same type and kind as @var{X}. + +@item @emph{Example}: +@smallexample +program test_tanpi + real :: x = 0.0 + x = tanpi(x) +end program test_tanpi +@end smallexample + +@item @emph{See also}: +@ref{ATANPI} @* +@ref{TAN} @* +@end table + + + @node TEAM_NUMBER @section @code{TEAM_NUMBER} --- Retrieve team id of given team @fnindex TEAM_NUMBER diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi index da085d1..a65f2d1 100644 --- a/gcc/fortran/invoke.texi +++ b/gcc/fortran/invoke.texi @@ -189,7 +189,7 @@ and warnings}. -fbounds-check -ftail-call-workaround -ftail-call-workaround=@var{n} -fcheck-array-temporaries -fcheck=<all|array-temps|bits|bounds|do|mem|pointer|recursion> --fcoarray=<none|single|lib> -fexternal-blas -ff2c +-fcoarray=<none|single|lib> -fexternal-blas -fexternal-blas64 -ff2c -ffrontend-loop-interchange -ffrontend-optimize -finit-character=@var{n} -finit-integer=@var{n} -finit-local-zero -finit-derived -finit-logical=<true|false> @@ -1170,6 +1170,10 @@ A @code{CHARACTER} variable is declared with negative length. With @option{-fopenmp}, for fixed-form source code, when an @code{omx} vendor-extension sentinel is encountered. (The equivalent @code{ompx}, used in free-form source code, is diagnosed by default.) + +@item +With @option{-fopenacc}, when using named constances with clauses that +take a variable as doing so has no effect. @end itemize @opindex Wtabs @@ -2010,13 +2014,27 @@ for some matrix operations like @code{MATMUL}, instead of using our own algorithms, if the size of the matrices involved is larger than a given limit (see @option{-fblas-matmul-limit}). This may be profitable if an optimized vendor BLAS library is available. The BLAS library has -to be specified at link time. +to be specified at link time. This option specifies a BLAS library +with integer arguments of default kind (32 bits). It cannot be used +together with @option{-fexternal-blas64}. + +@opindex fexternal-blas64 +@item -fexternal-blas64 +makes @command{gfortran} generate calls to BLAS functions +for some matrix operations like @code{MATMUL}, instead of using our own +algorithms, if the size of the matrices involved is larger than a given +limit (see @option{-fblas-matmul-limit}). This may be profitable if an +optimized vendor BLAS library is available. The BLAS library has +to be specified at link time. This option specifies a BLAS library +with integer arguments of @code{KIND=8} (64 bits). It cannot be used +together with @option{-fexternal-blas}, and requires a 64-bit system. +This option also requires @option{-ffrontend-optimize}. @opindex fblas-matmul-limit @item -fblas-matmul-limit=@var{n} -Only significant when @option{-fexternal-blas} is in effect. -Matrix multiplication of matrices with size larger than (or equal to) @var{n} -is performed by calls to BLAS functions, while others are +Only significant when @option{-fexternal-blas} or @option{-fexternal-blas64} +are in effect. Matrix multiplication of matrices with size larger than or equal +to @var{n} is performed by calls to BLAS functions, while others are handled by @command{gfortran} internal algorithms. If the matrices involved are not square, the size comparison is performed using the geometric mean of the dimensions of the argument and result matrices. diff --git a/gcc/fortran/io.cc b/gcc/fortran/io.cc index b5c9d33..45cac5e 100644 --- a/gcc/fortran/io.cc +++ b/gcc/fortran/io.cc @@ -29,7 +29,7 @@ along with GCC; see the file COPYING3. If not see gfc_st_label format_asterisk = {0, NULL, NULL, -1, ST_LABEL_FORMAT, ST_LABEL_FORMAT, NULL, - 0, {NULL, NULL}, NULL, 0}; + 0, {NULL, {NULL}}, NULL, 0}; typedef struct { @@ -1129,13 +1129,16 @@ data_desc: break; case FMT_H: - if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings) + if (!(gfc_option.allow_std & GFC_STD_LEGACY)) { - if (mode != MODE_FORMAT) - format_locus.nextc += format_string_pos; - gfc_warning (0, "The H format specifier at %L is" - " a Fortran 95 deleted feature", &format_locus); + error = G_("The H format specifier at %L is a Fortran 95 deleted" + " feature"); + goto syntax; } + if (mode != MODE_FORMAT) + format_locus.nextc += format_string_pos; + gfc_warning (0, "The H format specifier at %L is" + " a Fortran 95 deleted feature", &format_locus); if (mode == MODE_STRING) { format_string += value; @@ -1144,7 +1147,7 @@ data_desc: } else { - while (repeat >0) + while (repeat > 0) { next_char (INSTRING_WARN); repeat -- ; @@ -1228,7 +1231,8 @@ between_desc: default: if (mode != MODE_FORMAT) format_locus.nextc += format_string_pos - 1; - if (!gfc_notify_std (GFC_STD_GNU, "Missing comma at %L", &format_locus)) + if (!gfc_notify_std (GFC_STD_LEGACY, + "Missing comma in FORMAT string at %L", &format_locus)) return false; /* If we do not actually return a failure, we need to unwind this before the next round. */ @@ -1290,7 +1294,8 @@ extension_optional_comma: default: if (mode != MODE_FORMAT) format_locus.nextc += format_string_pos; - if (!gfc_notify_std (GFC_STD_GNU, "Missing comma at %L", &format_locus)) + if (!gfc_notify_std (GFC_STD_LEGACY, + "Missing comma in FORMAT string at %L", &format_locus)) return false; /* If we do not actually return a failure, we need to unwind this before the next round. */ diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc index 6930e2c..a821332 100644 --- a/gcc/fortran/iresolve.cc +++ b/gcc/fortran/iresolve.cc @@ -3000,30 +3000,28 @@ gfc_resolve_sqrt (gfc_expr *f, gfc_expr *x) /* Resolve the g77 compatibility function STAT AND FSTAT. */ void -gfc_resolve_stat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED, - gfc_expr *a ATTRIBUTE_UNUSED) +gfc_resolve_stat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED, gfc_expr *a) { f->ts.type = BT_INTEGER; - f->ts.kind = gfc_default_integer_kind; + f->ts.kind = a->ts.kind; f->value.function.name = gfc_get_string (PREFIX ("stat_i%d"), f->ts.kind); } void -gfc_resolve_lstat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED, - gfc_expr *a ATTRIBUTE_UNUSED) +gfc_resolve_lstat (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED, gfc_expr *a) { f->ts.type = BT_INTEGER; - f->ts.kind = gfc_default_integer_kind; + f->ts.kind = a->ts.kind; f->value.function.name = gfc_get_string (PREFIX ("lstat_i%d"), f->ts.kind); } void -gfc_resolve_fstat (gfc_expr *f, gfc_expr *n, gfc_expr *a ATTRIBUTE_UNUSED) +gfc_resolve_fstat (gfc_expr *f, gfc_expr *n, gfc_expr *a) { f->ts.type = BT_INTEGER; - f->ts.kind = gfc_default_integer_kind; + f->ts.kind = a->ts.kind; if (n->ts.kind != f->ts.kind) gfc_convert_type (n, &f->ts, 2); @@ -3435,13 +3433,12 @@ gfc_resolve_trim (gfc_expr *f, gfc_expr *string) f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind); } - -/* Resolve the degree trigonometric functions. This amounts to setting +/* Resolve the trigonometric functions. This amounts to setting the function return type-spec from its argument and building a library function names of the form _gfortran_sind_r4. */ void -gfc_resolve_trigd (gfc_expr *f, gfc_expr *x) +gfc_resolve_trig (gfc_expr *f, gfc_expr *x) { f->ts = x->ts; f->value.function.name @@ -3450,9 +3447,8 @@ gfc_resolve_trigd (gfc_expr *f, gfc_expr *x) gfc_type_abi_kind (&x->ts)); } - void -gfc_resolve_trigd2 (gfc_expr *f, gfc_expr *y, gfc_expr *x) +gfc_resolve_trig2 (gfc_expr *f, gfc_expr *y, gfc_expr *x) { f->ts = y->ts; f->value.function.name @@ -3865,6 +3861,19 @@ gfc_resolve_sleep_sub (gfc_code *c) c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); } +void +gfc_resolve_split (gfc_code *c) +{ + const char *name; + gfc_expr *string; + + string = c->ext.actual->expr; + if (string->ts.type == BT_CHARACTER && string->ts.kind == 4) + name = "__split_char4"; + else + name = "__split"; + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} /* G77 compatibility function srand(). */ @@ -4148,7 +4157,9 @@ void gfc_resolve_stat_sub (gfc_code *c) { const char *name; - name = gfc_get_string (PREFIX ("stat_i%d_sub"), gfc_default_integer_kind); + gfc_typespec *ts; + ts = &c->ext.actual->next->expr->ts; + name = gfc_get_string (PREFIX ("stat_i%d_sub"), ts->kind); c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); } @@ -4157,7 +4168,9 @@ void gfc_resolve_lstat_sub (gfc_code *c) { const char *name; - name = gfc_get_string (PREFIX ("lstat_i%d_sub"), gfc_default_integer_kind); + gfc_typespec *ts; + ts = &c->ext.actual->next->expr->ts; + name = gfc_get_string (PREFIX ("lstat_i%d_sub"), ts->kind); c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); } diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt index 7826a1a..33710d0 100644 --- a/gcc/fortran/lang.opt +++ b/gcc/fortran/lang.opt @@ -566,6 +566,10 @@ fexternal-blas Fortran Var(flag_external_blas) Specify that an external BLAS library should be used for matmul calls on large-size arrays. +fexternal-blas64 +Fortran Var(flag_external_blas64) +Use an external BLAS library with 64-bit indexing for matmul on large-size arrays. + ff2c Fortran Var(flag_f2c) Use f2c calling convention. diff --git a/gcc/fortran/lang.opt.urls b/gcc/fortran/lang.opt.urls index 4972ff8..4a51f5a 100644 --- a/gcc/fortran/lang.opt.urls +++ b/gcc/fortran/lang.opt.urls @@ -295,6 +295,9 @@ LangUrlSuffix_Fortran(gfortran/Developer-Options.html#index-fdump-parse-tree) fexternal-blas LangUrlSuffix_Fortran(gfortran/Code-Gen-Options.html#index-fexternal-blas) +fexternal-blas64 +LangUrlSuffix_Fortran(gfortran/Code-Gen-Options.html#index-fexternal-blas64) + ff2c LangUrlSuffix_Fortran(gfortran/Code-Gen-Options.html#index-ff2c) diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc index a99a757..8355a39 100644 --- a/gcc/fortran/match.cc +++ b/gcc/fortran/match.cc @@ -5293,7 +5293,7 @@ match gfc_match_nullify (void) { gfc_code *tail; - gfc_expr *e, *p; + gfc_expr *e, *p = NULL; match m; tail = NULL; @@ -7171,9 +7171,11 @@ select_type_push (gfc_symbol *sel) /* Set the temporary for the current intrinsic SELECT TYPE selector. */ static gfc_symtree * -select_intrinsic_set_tmp (gfc_typespec *ts) +select_intrinsic_set_tmp (gfc_typespec *ts, const char *var_name) { - char name[GFC_MAX_SYMBOL_LEN]; + /* Keep size in sync with the buffer size in resolve_select_type as it + determines the final name through truncation. */ + char name[GFC_MAX_SYMBOL_LEN + 12 + 1]; gfc_symtree *tmp; HOST_WIDE_INT charlen = 0; gfc_symbol *selector = select_type_stack->selector; @@ -7192,12 +7194,12 @@ select_intrinsic_set_tmp (gfc_typespec *ts) charlen = gfc_mpz_get_hwi (ts->u.cl->length->value.integer); if (ts->type != BT_CHARACTER) - sprintf (name, "__tmp_%s_%d", gfc_basic_typename (ts->type), - ts->kind); + snprintf (name, sizeof (name), "__tmp_%s_%d_%s", + gfc_basic_typename (ts->type), ts->kind, var_name); else snprintf (name, sizeof (name), - "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d", - gfc_basic_typename (ts->type), charlen, ts->kind); + "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d_%s", + gfc_basic_typename (ts->type), charlen, ts->kind, var_name); gfc_get_sym_tree (name, gfc_current_ns, &tmp, false); sym = tmp->n.sym; @@ -7239,7 +7241,9 @@ select_type_set_tmp (gfc_typespec *ts) return; } - tmp = select_intrinsic_set_tmp (ts); + gfc_expr *select_type_expr = gfc_state_stack->construct->expr1; + const char *var_name = gfc_var_name_for_select_type_temp (select_type_expr); + tmp = select_intrinsic_set_tmp (ts, var_name); if (tmp == NULL) { @@ -7247,9 +7251,11 @@ select_type_set_tmp (gfc_typespec *ts) return; if (ts->type == BT_CLASS) - sprintf (name, "__tmp_class_%s", ts->u.derived->name); + snprintf (name, sizeof (name), "__tmp_class_%s_%s", ts->u.derived->name, + var_name); else - sprintf (name, "__tmp_type_%s", ts->u.derived->name); + snprintf (name, sizeof (name), "__tmp_type_%s_%s", ts->u.derived->name, + var_name); gfc_get_sym_tree (name, gfc_current_ns, &tmp, false); sym = tmp->n.sym; diff --git a/gcc/fortran/matchexp.cc b/gcc/fortran/matchexp.cc index 9b66243..e3a9925 100644 --- a/gcc/fortran/matchexp.cc +++ b/gcc/fortran/matchexp.cc @@ -138,6 +138,65 @@ gfc_get_parentheses (gfc_expr *e) return e2; } +/* Match a conditional expression. */ + +static match +match_conditional (gfc_expr **result) +{ + gfc_expr *condition, *true_expr, *false_expr; + locus where; + match m; + + where = gfc_current_locus; + + m = gfc_match_expr (&condition); + if (m != MATCH_YES) + { + gfc_error (expression_syntax); + return MATCH_ERROR; + } + + m = gfc_match_char ('?'); + if (m != MATCH_YES) + { + *result = condition; + return MATCH_YES; + } + else if (!gfc_notify_std (GFC_STD_F2023, "Conditional expression at %L", + &where)) + { + gfc_free_expr (condition); + return MATCH_ERROR; + } + + gfc_gobble_whitespace (); + m = gfc_match_expr (&true_expr); + if (m != MATCH_YES) + { + gfc_free_expr (condition); + return m; + } + + m = gfc_match_char (':'); + if (m != MATCH_YES) + { + gfc_error ("Expected ':' in conditional expression at %C"); + gfc_free_expr (condition); + gfc_free_expr (true_expr); + return MATCH_ERROR; + } + + m = match_conditional (&false_expr); + if (m != MATCH_YES) + { + gfc_free_expr (condition); + gfc_free_expr (true_expr); + return m; + } + + *result = gfc_get_conditional_expr (&where, condition, true_expr, false_expr); + return MATCH_YES; +} /* Match a primary expression. */ @@ -163,20 +222,20 @@ match_primary (gfc_expr **result) if (gfc_match_char ('(') != MATCH_YES) return MATCH_NO; - m = gfc_match_expr (&e); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) + m = match_conditional (&e); + if (m != MATCH_YES) return m; m = gfc_match_char (')'); if (m == MATCH_NO) gfc_error ("Expected a right parenthesis in expression at %C"); - /* Now we have the expression inside the parentheses, build the - expression pointing to it. By 7.1.7.2, any expression in - parentheses shall be treated as a data entity. */ - *result = gfc_get_parentheses (e); + /* Now we have the expression inside the parentheses, build the expression + pointing to it. By 7.1.7.2, any expression in parentheses shall be treated + as a data entity. + Note that if the expression is a conditional expression, we will omit the + extra parentheses. */ + *result = e->expr_type == EXPR_CONDITIONAL ? e : gfc_get_parentheses (e); if (m != MATCH_YES) { @@ -185,10 +244,6 @@ match_primary (gfc_expr **result) } return MATCH_YES; - -syntax: - gfc_error (expression_syntax); - return MATCH_ERROR; } diff --git a/gcc/fortran/mathbuiltins.def b/gcc/fortran/mathbuiltins.def index 2d475a2..bdc9058 100644 --- a/gcc/fortran/mathbuiltins.def +++ b/gcc/fortran/mathbuiltins.def @@ -23,34 +23,41 @@ along with GCC; see the file COPYING3. If not see Use DEFINE_MATH_BUILTIN_C if the complex versions of the builtin are also available. */ -DEFINE_MATH_BUILTIN_C (ACOS, "acos", 0) -DEFINE_MATH_BUILTIN_C (ACOSH, "acosh", 0) -DEFINE_MATH_BUILTIN_C (ASIN, "asin", 0) -DEFINE_MATH_BUILTIN_C (ASINH, "asinh", 0) -DEFINE_MATH_BUILTIN_C (ATAN, "atan", 0) -DEFINE_MATH_BUILTIN_C (ATANH, "atanh", 0) -DEFINE_MATH_BUILTIN (ATAN2, "atan2", 1) -DEFINE_MATH_BUILTIN_C (COS, "cos", 0) -DEFINE_MATH_BUILTIN_C (COSH, "cosh", 0) -DEFINE_MATH_BUILTIN_C (EXP, "exp", 0) -DEFINE_MATH_BUILTIN_C (LOG, "log", 0) -DEFINE_MATH_BUILTIN_C (LOG10, "log10", 0) -DEFINE_MATH_BUILTIN_C (SIN, "sin", 0) -DEFINE_MATH_BUILTIN_C (SINH, "sinh", 0) -DEFINE_MATH_BUILTIN_C (SQRT, "sqrt", 0) -DEFINE_MATH_BUILTIN_C (TAN, "tan", 0) -DEFINE_MATH_BUILTIN_C (TANH, "tanh", 0) -DEFINE_MATH_BUILTIN (J0, "j0", 0) -DEFINE_MATH_BUILTIN (J1, "j1", 0) -DEFINE_MATH_BUILTIN (JN, "jn", 5) -DEFINE_MATH_BUILTIN (Y0, "y0", 0) -DEFINE_MATH_BUILTIN (Y1, "y1", 0) -DEFINE_MATH_BUILTIN (YN, "yn", 5) -DEFINE_MATH_BUILTIN (ERF, "erf", 0) -DEFINE_MATH_BUILTIN (ERFC, "erfc", 0) -DEFINE_MATH_BUILTIN (TGAMMA,"tgamma", 0) -DEFINE_MATH_BUILTIN (LGAMMA,"lgamma", 0) -DEFINE_MATH_BUILTIN (HYPOT, "hypot", 1) +DEFINE_MATH_BUILTIN_C (ACOS, "acos", 0) +DEFINE_MATH_BUILTIN_C (ACOSH, "acosh", 0) +DEFINE_MATH_BUILTIN (ACOSPI, "acospi", 0) +DEFINE_MATH_BUILTIN_C (ASIN, "asin", 0) +DEFINE_MATH_BUILTIN_C (ASINH, "asinh", 0) +DEFINE_MATH_BUILTIN (ASINPI, "asinpi", 0) +DEFINE_MATH_BUILTIN_C (ATAN, "atan", 0) +DEFINE_MATH_BUILTIN (ATAN2, "atan2", 1) +DEFINE_MATH_BUILTIN (ATAN2PI, "atan2pi", 1) +DEFINE_MATH_BUILTIN_C (ATANH, "atanh", 0) +DEFINE_MATH_BUILTIN (ATANPI, "atanpi", 0) +DEFINE_MATH_BUILTIN_C (COS, "cos", 0) +DEFINE_MATH_BUILTIN_C (COSH, "cosh", 0) +DEFINE_MATH_BUILTIN (COSPI, "cospi", 0) +DEFINE_MATH_BUILTIN (ERF, "erf", 0) +DEFINE_MATH_BUILTIN (ERFC, "erfc", 0) +DEFINE_MATH_BUILTIN_C (EXP, "exp", 0) +DEFINE_MATH_BUILTIN (HYPOT, "hypot", 1) +DEFINE_MATH_BUILTIN (J0, "j0", 0) +DEFINE_MATH_BUILTIN (J1, "j1", 0) +DEFINE_MATH_BUILTIN (JN, "jn", 5) +DEFINE_MATH_BUILTIN (LGAMMA, "lgamma", 0) +DEFINE_MATH_BUILTIN_C (LOG, "log", 0) +DEFINE_MATH_BUILTIN_C (LOG10, "log10", 0) +DEFINE_MATH_BUILTIN_C (SIN, "sin", 0) +DEFINE_MATH_BUILTIN_C (SINH, "sinh", 0) +DEFINE_MATH_BUILTIN (SINPI, "sinpi", 0) +DEFINE_MATH_BUILTIN_C (SQRT, "sqrt", 0) +DEFINE_MATH_BUILTIN_C (TAN, "tan", 0) +DEFINE_MATH_BUILTIN_C (TANH, "tanh", 0) +DEFINE_MATH_BUILTIN (TANPI, "tanpi", 0) +DEFINE_MATH_BUILTIN (TGAMMA, "tgamma", 0) +DEFINE_MATH_BUILTIN (Y0, "y0", 0) +DEFINE_MATH_BUILTIN (Y1, "y1", 0) +DEFINE_MATH_BUILTIN (YN, "yn", 5) /* OTHER_BUILTIN (CODE, NAME, PROTOTYPE_TYPE, CONST) For floating-point builtins that do not directly correspond to a diff --git a/gcc/fortran/misc.cc b/gcc/fortran/misc.cc index 893c40f..2339306 100644 --- a/gcc/fortran/misc.cc +++ b/gcc/fortran/misc.cc @@ -214,6 +214,9 @@ gfc_typename (gfc_typespec *ts, bool for_hash) case BT_UNKNOWN: strcpy (buffer, "UNKNOWN"); break; + case BT_VOID: + strcpy (buffer, "VOID"); + break; default: gfc_internal_error ("gfc_typename(): Undefined type"); } @@ -469,3 +472,24 @@ gfc_mpz_set_hwi (mpz_t rop, const HOST_WIDE_INT op) const wide_int w = wi::shwi (op, HOST_BITS_PER_WIDE_INT); wi::to_mpz (w, rop, SIGNED); } + + +/* Extract a name suitable for use in the name of the select type temporary + variable. We pick the last component name in the data reference if there + is one, otherwise the user variable name, and return the empty string by + default. */ + +const char * +gfc_var_name_for_select_type_temp (gfc_expr *e) +{ + const char *name = ""; + if (e->symtree) + name = e->symtree->name; + for (gfc_ref *r = e->ref; r; r = r->next) + if (r->type == REF_COMPONENT + && !(strcmp (r->u.c.component->name, "_data") == 0 + || strcmp (r->u.c.component->name, "_vptr") == 0)) + name = r->u.c.component->name; + + return name; +} diff --git a/gcc/fortran/module.cc b/gcc/fortran/module.cc index 070b316..c489dec 100644 --- a/gcc/fortran/module.cc +++ b/gcc/fortran/module.cc @@ -2093,7 +2093,7 @@ enum ab_attribute AB_OACC_DECLARE_COPYIN, AB_OACC_DECLARE_DEVICEPTR, AB_OACC_DECLARE_DEVICE_RESIDENT, AB_OACC_DECLARE_LINK, AB_OMP_DECLARE_TARGET_LINK, AB_PDT_KIND, AB_PDT_LEN, AB_PDT_TYPE, - AB_PDT_TEMPLATE, AB_PDT_ARRAY, AB_PDT_STRING, + AB_PDT_COMP, AB_PDT_TEMPLATE, AB_PDT_ARRAY, AB_PDT_STRING, AB_OACC_ROUTINE_LOP_GANG, AB_OACC_ROUTINE_LOP_WORKER, AB_OACC_ROUTINE_LOP_VECTOR, AB_OACC_ROUTINE_LOP_SEQ, AB_OACC_ROUTINE_NOHOST, @@ -2172,6 +2172,7 @@ static const mstring attr_bits[] = minit ("PDT_TEMPLATE", AB_PDT_TEMPLATE), minit ("PDT_ARRAY", AB_PDT_ARRAY), minit ("PDT_STRING", AB_PDT_STRING), + minit ("PDT_COMP", AB_PDT_COMP), minit ("OACC_ROUTINE_LOP_GANG", AB_OACC_ROUTINE_LOP_GANG), minit ("OACC_ROUTINE_LOP_WORKER", AB_OACC_ROUTINE_LOP_WORKER), minit ("OACC_ROUTINE_LOP_VECTOR", AB_OACC_ROUTINE_LOP_VECTOR), @@ -2404,6 +2405,8 @@ mio_symbol_attribute (symbol_attribute *attr) MIO_NAME (ab_attribute) (AB_PDT_LEN, attr_bits); if (attr->pdt_type) MIO_NAME (ab_attribute) (AB_PDT_TYPE, attr_bits); + if (attr->pdt_comp) + MIO_NAME (ab_attribute) (AB_PDT_COMP , attr_bits); if (attr->pdt_template) MIO_NAME (ab_attribute) (AB_PDT_TEMPLATE, attr_bits); if (attr->pdt_array) @@ -2681,6 +2684,9 @@ mio_symbol_attribute (symbol_attribute *attr) case AB_PDT_TYPE: attr->pdt_type = 1; break; + case AB_PDT_COMP: + attr->pdt_comp = 1; + break; case AB_PDT_TEMPLATE: attr->pdt_template = 1; break; @@ -3622,7 +3628,9 @@ static const mstring expr_types[] = { minit ("ARRAY", EXPR_ARRAY), minit ("NULL", EXPR_NULL), minit ("COMPCALL", EXPR_COMPCALL), - minit (NULL, -1) + minit ("PPC", EXPR_PPC), + minit ("CONDITIONAL", EXPR_CONDITIONAL), + minit (NULL, -1), }; /* INTRINSIC_ASSIGN is missing because it is used as an index for @@ -3843,6 +3851,12 @@ mio_expr (gfc_expr **ep) break; + case EXPR_CONDITIONAL: + mio_expr (&e->value.conditional.condition); + mio_expr (&e->value.conditional.true_expr); + mio_expr (&e->value.conditional.false_expr); + break; + case EXPR_FUNCTION: mio_symtree_ref (&e->symtree); mio_actual_arglist (&e->value.function.actual, false); @@ -7277,10 +7291,13 @@ create_int_parameter_array (const char *name, int size, gfc_expr *value, tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name); if (tmp_symtree != NULL) { - if (strcmp (modname, tmp_symtree->n.sym->module) == 0) + if (tmp_symtree->n.sym->module && + strcmp (modname, tmp_symtree->n.sym->module) == 0) return; else - gfc_error ("Symbol %qs already declared", name); + gfc_error ("Symbol %qs already declared at %L conflicts with " + "symbol in %qs at %C", name, + &tmp_symtree->n.sym->declared_at, modname); } gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false); diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc index df82940..9e282c7 100644 --- a/gcc/fortran/openmp.cc +++ b/gcc/fortran/openmp.cc @@ -4474,7 +4474,7 @@ error: | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE | OMP_CLAUSE_FINALIZE \ | OMP_CLAUSE_DETACH) #define OACC_WAIT_CLAUSES \ - omp_mask (OMP_CLAUSE_ASYNC) + omp_mask (OMP_CLAUSE_ASYNC) | OMP_CLAUSE_IF #define OACC_ROUTINE_CLAUSES \ (omp_mask (OMP_CLAUSE_GANG) | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR \ | OMP_CLAUSE_SEQ \ @@ -6982,13 +6982,9 @@ gfc_match_omp_declare_variant (void) return MATCH_ERROR; } - if ((has_adjust_args || has_append_args) && !has_match) + if (!has_match) { - gfc_error ("the %qs clause at %L can only be specified if the " - "%<dispatch%> selector of the construct selector set appears " - "in the %<match%> clause", - has_adjust_args ? "adjust_args" : "append_args", - has_adjust_args ? &adjust_args_loc : &append_args_loc); + gfc_error ("expected %<match%> clause at %C"); return MATCH_ERROR; } @@ -8895,15 +8891,21 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, if (list == OMP_LIST_MAP && n->sym->attr.flavor == FL_PARAMETER) { + /* OpenACC since 3.4 permits for Fortran named constants, but + permits removing then as optimization is not needed and such + ignore them. Likewise below for FIRSTPRIVATE. */ if (openacc) - gfc_error ("Object %qs is not a variable at %L; parameters" - " cannot be and need not be copied", n->sym->name, - &n->where); + gfc_warning (OPT_Wsurprising, "Clause for object %qs at %L is " + "ignored as parameters need not be copied", + n->sym->name, &n->where); else gfc_error ("Object %qs is not a variable at %L; parameters" " cannot be and need not be mapped", n->sym->name, &n->where); } + else if (openacc && n->sym->attr.flavor == FL_PARAMETER) + gfc_warning (OPT_Wsurprising, "Clause for object %qs at %L is ignored" + " as it is a parameter", n->sym->name, &n->where); else if (list != OMP_LIST_USES_ALLOCATORS) gfc_error ("Object %qs is not a variable at %L", n->sym->name, &n->where); @@ -12756,9 +12758,21 @@ gfc_resolve_oacc_declare (gfc_namespace *ns) && (n->sym->attr.flavor != FL_PROCEDURE || n->sym->result != n->sym)) { - gfc_error ("Object %qs is not a variable at %L", - n->sym->name, &oc->loc); - continue; + if (n->sym->attr.flavor != FL_PARAMETER) + { + gfc_error ("Object %qs is not a variable at %L", + n->sym->name, &oc->loc); + continue; + } + /* Note that OpenACC 3.4 permits name constants, but the + implementation is permitted to ignore the clause; + as semantically, device_resident kind of makes sense + (and the wording with it is a bit odd), the warning + is suppressed. */ + if (list != OMP_LIST_DEVICE_RESIDENT) + gfc_warning (OPT_Wsurprising, "Object %qs at %L is ignored as" + " parameters need not be copied", n->sym->name, + &oc->loc); } if (n->expr && n->expr->ref->type == REF_ARRAY) diff --git a/gcc/fortran/options.cc b/gcc/fortran/options.cc index ddddc1c..21839ef 100644 --- a/gcc/fortran/options.cc +++ b/gcc/fortran/options.cc @@ -406,7 +406,8 @@ gfc_post_options (const char **pfilename) if (warn_line_truncation && !OPTION_SET_P (warnings_are_errors) && option_unspecified_p (OPT_Wline_truncation)) diagnostic_classify_diagnostic (global_dc, OPT_Wline_truncation, - DK_ERROR, UNKNOWN_LOCATION); + diagnostics::kind::error, + UNKNOWN_LOCATION); } else { @@ -503,12 +504,20 @@ gfc_post_options (const char **pfilename) flag_inline_matmul_limit = 30; } - /* Optimization implies front end optimization, unless the user + /* We can only have a 32-bit or a 64-bit version of BLAS, not both. */ + + if (flag_external_blas && flag_external_blas64) + gfc_fatal_error ("32- and 64-bit version of BLAS cannot both be specified"); + + /* Optimizationx implies front end optimization, unless the user specified it directly. */ if (flag_frontend_optimize == -1) flag_frontend_optimize = optimize && !optimize_debug; + if (flag_external_blas64 && !flag_frontend_optimize) + gfc_fatal_error ("-ffrontend-optimize required for -fexternal-blas64"); + /* Same for front end loop interchange. */ if (flag_frontend_loop_interchange == -1) @@ -883,6 +892,10 @@ gfc_handle_option (size_t scode, const char *arg, HOST_WIDE_INT value, return false; /* Not supported. */ if (!strcmp ("omp_is_initial_device", arg)) gfc_option.disable_omp_is_initial_device = true; + else if (!strcmp ("omp_get_initial_device", arg)) + gfc_option.disable_omp_get_initial_device = true; + else if (!strcmp ("omp_get_num_devices", arg)) + gfc_option.disable_omp_get_num_devices = true; else if (!strcmp ("acc_on_device", arg)) gfc_option.disable_acc_on_device = true; else diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc index 538eb65..b29f690 100644 --- a/gcc/fortran/parse.cc +++ b/gcc/fortran/parse.cc @@ -27,6 +27,9 @@ along with GCC; see the file COPYING3. If not see #include "match.h" #include "parse.h" #include "tree-core.h" +#include "tree.h" +#include "fold-const.h" +#include "tree-hash-traits.h" #include "omp-general.h" /* Current statement label. Zero means no statement label. Because new_st @@ -239,6 +242,7 @@ decode_specification_statement (void) break; case 'g': + match ("generic", gfc_match_generic, ST_GENERIC); break; case 'i': @@ -3934,6 +3938,7 @@ parse_derived (void) gfc_state_data s; gfc_symbol *sym; gfc_component *c, *lock_comp = NULL, *event_comp = NULL; + bool pdt_parameters; accept_statement (ST_DERIVED_DECL); push_state (&s, COMP_DERIVED, gfc_new_block); @@ -3942,9 +3947,11 @@ parse_derived (void) seen_private = 0; seen_sequence = 0; seen_component = 0; + pdt_parameters = false; compiling_type = 1; + while (compiling_type) { st = next_statement (); @@ -3957,6 +3964,31 @@ parse_derived (void) case ST_PROCEDURE: accept_statement (st); seen_component = 1; + /* Type parameters must not have an explicit access specification + and must be placed before a PRIVATE statement. If a PRIVATE + statement is encountered after type parameters, mark the remaining + components as PRIVATE. */ + for (c = gfc_current_block ()->components; c; c = c->next) + if (!c->next && (c->attr.pdt_kind || c->attr.pdt_len)) + { + pdt_parameters = true; + if (c->attr.access != ACCESS_UNKNOWN) + { + gfc_error ("Access specification of a type parameter at " + "%C is not allowed"); + c->attr.access = ACCESS_PUBLIC; + break; + } + if (seen_private) + { + gfc_error ("The type parameter at %C must come before a " + "PRIVATE statement"); + break; + } + } + else if (pdt_parameters && seen_private + && !(c->attr.pdt_kind || c->attr.pdt_len)) + c->attr.access = ACCESS_PRIVATE; break; case ST_FINAL: @@ -3982,7 +4014,7 @@ endType: break; } - if (seen_component) + if (seen_component && !pdt_parameters) { gfc_error ("PRIVATE statement at %C must precede " "structure components"); @@ -3992,7 +4024,10 @@ endType: if (seen_private) gfc_error ("Duplicate PRIVATE statement at %C"); - s.sym->component_access = ACCESS_PRIVATE; + if (pdt_parameters) + s.sym->component_access = ACCESS_PUBLIC; + else + s.sym->component_access = ACCESS_PRIVATE; accept_statement (ST_PRIVATE); seen_private = 1; @@ -4531,6 +4566,11 @@ declSt: st = next_statement (); goto loop; + case ST_GENERIC: + accept_statement (st); + st = next_statement (); + goto loop; + case ST_ENUM: accept_statement (st); parse_enum(); @@ -6790,6 +6830,7 @@ gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings) gfc_namespace *ns; gfc_symtree *st; gfc_symbol *old_sym; + bool imported; for (ns = siblings; ns; ns = ns->sibling) { @@ -6805,6 +6846,7 @@ gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings) goto fixup_contained; old_sym = st->n.sym; + imported = old_sym->attr.imported == 1; if (old_sym->ns == ns && !old_sym->attr.contained @@ -6831,7 +6873,8 @@ gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings) /* Replace it with the symbol from the parent namespace. */ st->n.sym = sym; sym->refs++; - + if (imported) + sym->attr.imported = 1; gfc_release_symbol (old_sym); } diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc index ec4e135..cba4208 100644 --- a/gcc/fortran/primary.cc +++ b/gcc/fortran/primary.cc @@ -2102,10 +2102,18 @@ extend_ref (gfc_expr *primary, gfc_ref *tail) { if (primary->ref == NULL) primary->ref = tail = gfc_get_ref (); + else if (tail == NULL) + { + /* Set tail to end of reference chain. */ + for (gfc_ref *ref = primary->ref; ref; ref = ref->next) + if (ref->next == NULL) + { + tail = ref; + break; + } + } else { - if (tail == NULL) - gfc_internal_error ("extend_ref(): Bad tail"); tail->next = gfc_get_ref (); tail = tail->next; } @@ -2302,9 +2310,22 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, gfc_array_spec *as; bool coarray_only = sym->attr.codimension && !sym->attr.dimension && sym->ts.type == BT_CHARACTER; + gfc_ref *ref, *strarr = NULL; tail = extend_ref (primary, tail); - tail->type = REF_ARRAY; + if (sym->ts.type == BT_CHARACTER && tail->type == REF_SUBSTRING) + { + gcc_assert (sym->attr.dimension); + /* Find array reference for substrings of character arrays. */ + for (ref = primary->ref; ref && ref->next; ref = ref->next) + if (ref->type == REF_ARRAY && ref->next->type == REF_SUBSTRING) + { + strarr = ref; + break; + } + } + else + tail->type = REF_ARRAY; /* In EQUIVALENCE, we don't know yet whether we are seeing an array, character variable or array of character @@ -2317,7 +2338,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, else as = sym->as; - m = gfc_match_array_ref (&tail->u.ar, as, equiv_flag, as ? as->corank : 0, + ref = strarr ? strarr : tail; + m = gfc_match_array_ref (&ref->u.ar, as, equiv_flag, as ? as->corank : 0, coarray_only); if (m != MATCH_YES) return m; @@ -2483,6 +2505,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, { bool t; gfc_symtree *tbp; + gfc_typespec *ts = &primary->ts; m = gfc_match_name (name); if (m == MATCH_NO) @@ -2490,8 +2513,18 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, if (m != MATCH_YES) return MATCH_ERROR; + /* For derived type components find typespec of ultimate component. */ + if (ts->type == BT_DERIVED && primary->ref) + { + for (gfc_ref *ref = primary->ref; ref; ref = ref->next) + { + if (ref->type == REF_COMPONENT && ref->u.c.component) + ts = &ref->u.c.component->ts; + } + } + intrinsic = false; - if (primary->ts.type != BT_CLASS && primary->ts.type != BT_DERIVED) + if (ts->type != BT_CLASS && ts->type != BT_DERIVED) { inquiry = is_inquiry_ref (name, &tmp); if (inquiry) @@ -2564,7 +2597,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, return MATCH_ERROR; } else if (tmp->u.i == INQUIRY_LEN - && primary->ts.type != BT_CHARACTER) + && ts->type != BT_CHARACTER) { gfc_error ("The LEN part_ref at %C must be applied " "to a CHARACTER expression"); @@ -2659,6 +2692,11 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, primary->ref = tmp; else { + /* Find end of reference chain if inquiry reference and tail not + set. */ + if (tail == NULL && inquiry && tmp) + tail = extend_ref (primary, tail); + /* Set by the for loop below for the last component ref. */ gcc_assert (tail != NULL); tail->next = tmp; @@ -2678,6 +2716,9 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, if (primary->expr_type == EXPR_CONSTANT) goto check_done; + if (primary->ref == NULL) + goto check_done; + switch (tmp->u.i) { case INQUIRY_RE: @@ -2828,6 +2869,7 @@ check_substring: if (substring) primary->ts.u.cl = NULL; + gfc_gobble_whitespace (); if (gfc_peek_ascii_char () == '(') { gfc_error_now ("Unexpected array/substring ref at %C"); @@ -3015,12 +3057,14 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) if (comp->ts.type == BT_CLASS) { + dimension = CLASS_DATA (comp)->attr.dimension; codimension = CLASS_DATA (comp)->attr.codimension; pointer = CLASS_DATA (comp)->attr.class_pointer; allocatable = CLASS_DATA (comp)->attr.allocatable; } else { + dimension = comp->attr.dimension; codimension = comp->attr.codimension; if (expr->ts.type == BT_CLASS && strcmp (comp->name, "_data") == 0) pointer = comp->attr.class_pointer; @@ -4013,6 +4057,98 @@ gfc_match_rvalue (gfc_expr **result) break; } + /* Check to see if this is a PDT constructor. The format of these + constructors is rather unusual: + name [(type_params)](component_values) + where, component_values excludes the type_params. With the present + gfortran representation this is rather awkward because the two are not + distinguished, other than by their attributes. */ + if (sym->attr.generic) + { + gfc_symtree *pdt_st; + gfc_symbol *pdt_sym; + gfc_actual_arglist *ctr_arglist = NULL, *tmp; + gfc_component *c; + + /* Obtain the template. */ + gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &pdt_st); + if (pdt_st && pdt_st->n.sym && pdt_st->n.sym->attr.pdt_template) + { + bool type_spec_list = false; + pdt_sym = pdt_st->n.sym; + gfc_gobble_whitespace (); + /* Look for a second actual arglist. If present, try the first + for the type parameters. Otherwise, or if there is no match, + depend on default values by setting the type parameters to + NULL. */ + if (gfc_peek_ascii_char() == '(') + type_spec_list = true; + if (!actual_arglist && !type_spec_list) + { + gfc_error_now ("F2023 R755: The empty type specification at %C " + "is not allowed"); + m = MATCH_ERROR; + break; + } + /* Generate this instance using the type parameters from the + first argument list and return the parameter list in + ctr_arglist. */ + m = gfc_get_pdt_instance (actual_arglist, &pdt_sym, &ctr_arglist); + if (m != MATCH_YES || !ctr_arglist) + { + if (ctr_arglist) + gfc_free_actual_arglist (ctr_arglist); + /* See if all the type parameters have default values. */ + m = gfc_get_pdt_instance (NULL, &pdt_sym, &ctr_arglist); + if (m != MATCH_YES) + { + m = MATCH_NO; + break; + } + } + + /* Now match the component_values if the type parameters were + present. */ + if (type_spec_list) + { + m = gfc_match_actual_arglist (0, &actual_arglist); + if (m != MATCH_YES) + { + m = MATCH_ERROR; + break; + } + } + + /* Make sure that the component names are in place so that this + list can be safely appended to the type parameters. */ + tmp = actual_arglist; + for (c = pdt_sym->components; c && tmp; c = c->next) + { + if (c->attr.pdt_kind || c->attr.pdt_len) + continue; + tmp->name = c->name; + tmp = tmp->next; + } + + gfc_find_sym_tree (gfc_dt_lower_string (pdt_sym->name), + NULL, 1, &symtree); + if (!symtree) + { + gfc_get_ha_sym_tree (gfc_dt_lower_string (pdt_sym->name) , + &symtree); + symtree->n.sym = pdt_sym; + symtree->n.sym->ts.u.derived = pdt_sym; + symtree->n.sym->ts.type = BT_DERIVED; + } + + /* Append the type_params and the component_values. */ + for (tmp = ctr_arglist; tmp && tmp->next;) + tmp = tmp->next; + tmp->next = actual_arglist; + actual_arglist = ctr_arglist; + } + } + gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */ sym = symtree->n.sym; @@ -4271,6 +4407,16 @@ gfc_match_rvalue (gfc_expr **result) return MATCH_ERROR; } + /* Scan for possible inquiry references. */ + if (m == MATCH_YES + && e->expr_type == EXPR_VARIABLE + && gfc_peek_ascii_char () == '%') + { + m = gfc_match_varspec (e, 0, false, false); + if (m == MATCH_NO) + m = MATCH_YES; + } + if (m == MATCH_YES) { e->where = where; diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index bf1aa70..f419f5c 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -1630,7 +1630,7 @@ was_declared (gfc_symbol *sym) if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic || a.optional || a.pointer || a.save || a.target || a.volatile_ || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN - || a.asynchronous || a.codimension) + || a.asynchronous || a.codimension || a.subroutine) return 1; return 0; @@ -2030,7 +2030,7 @@ static bool resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, bool no_formal_args) { - gfc_symbol *sym; + gfc_symbol *sym = NULL; gfc_symtree *parent_st; gfc_expr *e; gfc_component *comp; @@ -2295,6 +2295,30 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, goto cleanup; } + if (e->expr_type == EXPR_VARIABLE + && e->ts.type == BT_PROCEDURE + && no_formal_args + && sym->attr.flavor == FL_PROCEDURE + && sym->attr.if_source == IFSRC_UNKNOWN + && !sym->attr.external + && !sym->attr.intrinsic + && !sym->attr.artificial + && !sym->ts.interface) + { + /* Emit a warning for -std=legacy and an error otherwise. */ + if (gfc_option.warn_std == 0) + gfc_warning (0, "Procedure %qs at %L used as actual argument but " + "does neither have an explicit interface nor the " + "EXTERNAL attribute", sym->name, &e->where); + else + { + gfc_error ("Procedure %qs at %L used as actual argument but " + "does neither have an explicit interface nor the " + "EXTERNAL attribute", sym->name, &e->where); + goto cleanup; + } + } + first_actual_arg = false; } @@ -3919,10 +3943,153 @@ found: } + +static bool +check_sym_import_status (gfc_symbol *sym, gfc_symtree *s, gfc_expr *e, + gfc_code *c, gfc_namespace *ns) +{ + locus *here; + + /* If the type has been imported then its vtype functions are OK. */ + if (e && e->expr_type == EXPR_FUNCTION && sym->attr.vtype) + return true; + + if (e) + here = &e->where; + else + here = &c->loc; + + if (s && !s->import_only) + s = gfc_find_symtree (ns->sym_root, sym->name); + + if (ns->import_state == IMPORT_ONLY + && sym->ns != ns + && (!s || !s->import_only)) + { + gfc_error ("F2018: C8102 %qs at %L is host associated but does not " + "appear in an IMPORT or IMPORT, ONLY list", sym->name, here); + return false; + } + else if (ns->import_state == IMPORT_NONE + && sym->ns != ns) + { + gfc_error ("F2018: C8102 %qs at %L is host associated in a scope that " + "has IMPORT, NONE", sym->name, here); + return false; + } + return true; +} + + +static bool +check_import_status (gfc_expr *e) +{ + gfc_symtree *st; + gfc_ref *ref; + gfc_symbol *sym, *der; + gfc_namespace *ns = gfc_current_ns; + + switch (e->expr_type) + { + case EXPR_VARIABLE: + case EXPR_FUNCTION: + case EXPR_SUBSTRING: + sym = e->symtree ? e->symtree->n.sym : NULL; + + /* Check the symbol itself. */ + if (sym + && !(ns->proc_name + && (sym == ns->proc_name)) + && !check_sym_import_status (sym, e->symtree, e, NULL, ns)) + return false; + + /* Check the declared derived type. */ + if (sym->ts.type == BT_DERIVED) + { + der = sym->ts.u.derived; + st = gfc_find_symtree (ns->sym_root, der->name); + + if (!check_sym_import_status (der, st, e, NULL, ns)) + return false; + } + else if (sym->ts.type == BT_CLASS && !UNLIMITED_POLY (sym)) + { + der = CLASS_DATA (sym) ? CLASS_DATA (sym)->ts.u.derived + : sym->ts.u.derived; + st = gfc_find_symtree (ns->sym_root, der->name); + + if (!check_sym_import_status (der, st, e, NULL, ns)) + return false; + } + + /* Check the declared derived types of component references. */ + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + { + gfc_component *c = ref->u.c.component; + if (c->ts.type == BT_DERIVED) + { + der = c->ts.u.derived; + st = gfc_find_symtree (ns->sym_root, der->name); + if (!check_sym_import_status (der, st, e, NULL, ns)) + return false; + } + else if (c->ts.type == BT_CLASS && !UNLIMITED_POLY (c)) + { + der = CLASS_DATA (c) ? CLASS_DATA (c)->ts.u.derived + : c->ts.u.derived; + st = gfc_find_symtree (ns->sym_root, der->name); + if (!check_sym_import_status (der, st, e, NULL, ns)) + return false; + } + } + + break; + + case EXPR_ARRAY: + case EXPR_STRUCTURE: + /* Check the declared derived type. */ + if (e->ts.type == BT_DERIVED) + { + der = e->ts.u.derived; + st = gfc_find_symtree (ns->sym_root, der->name); + + if (!check_sym_import_status (der, st, e, NULL, ns)) + return false; + } + else if (e->ts.type == BT_CLASS && !UNLIMITED_POLY (e)) + { + der = CLASS_DATA (e) ? CLASS_DATA (e)->ts.u.derived + : e->ts.u.derived; + st = gfc_find_symtree (ns->sym_root, der->name); + + if (!check_sym_import_status (der, st, e, NULL, ns)) + return false; + } + + break; + +/* Either not applicable or resolved away + case EXPR_OP: + case EXPR_UNKNOWN: + case EXPR_CONSTANT: + case EXPR_NULL: + case EXPR_COMPCALL: + case EXPR_PPC: */ + + default: + break; + } + + return true; +} + + /* Resolve a subroutine call. Although it was tempting to use the same code for functions, subroutines and functions are stored differently and this makes things awkward. */ + static bool resolve_call (gfc_code *c) { @@ -4080,6 +4247,11 @@ resolve_call (gfc_code *c) "Using subroutine %qs at %L is deprecated", c->resolved_sym->name, &c->loc); + csym = c->resolved_sym ? c->resolved_sym : csym; + if (t && gfc_current_ns->import_state != IMPORT_NOT_SET && !c->resolved_isym + && csym != gfc_current_ns->proc_name) + return check_sym_import_status (csym, c->symtree, NULL, c, gfc_current_ns); + return t; } @@ -4807,34 +4979,6 @@ resolve_operator (gfc_expr *e) return false; } } - - /* coranks have to be equal or one has to be zero to be combinable. */ - if (op1->corank == op2->corank || (op1->corank != 0 && op2->corank == 0)) - { - e->corank = op1->corank; - /* Only do this, when regular array has not set a shape yet. */ - if (e->shape == NULL) - { - if (op1->corank != 0) - { - e->shape = gfc_copy_shape (op1->shape, op1->corank); - } - } - } - else if (op1->corank == 0 && op2->corank != 0) - { - e->corank = op2->corank; - /* Only do this, when regular array has not set a shape yet. */ - if (e->shape == NULL) - e->shape = gfc_copy_shape (op2->shape, op2->corank); - } - else - { - gfc_error ("Inconsistent coranks for operator at %L and %L", - &op1->where, &op2->where); - return false; - } - break; case INTRINSIC_PARENTHESES: @@ -4869,6 +5013,73 @@ simplify_op: return t; } +static bool +resolve_conditional (gfc_expr *expr) +{ + gfc_expr *condition, *true_expr, *false_expr; + + condition = expr->value.conditional.condition; + true_expr = expr->value.conditional.true_expr; + false_expr = expr->value.conditional.false_expr; + + if (!gfc_resolve_expr (condition) || !gfc_resolve_expr (true_expr) + || !gfc_resolve_expr (false_expr)) + return false; + + if (condition->ts.type != BT_LOGICAL || condition->rank != 0) + { + gfc_error ( + "Condition in conditional expression must be a scalar logical at %L", + &condition->where); + return false; + } + + if (true_expr->ts.type != false_expr->ts.type) + { + gfc_error ("expr at %L and expr at %L in conditional expression " + "must have the same declared type", + &true_expr->where, &false_expr->where); + return false; + } + + if (true_expr->ts.kind != false_expr->ts.kind) + { + gfc_error ("expr at %L and expr at %L in conditional expression " + "must have the same kind parameter", + &true_expr->where, &false_expr->where); + return false; + } + + if (true_expr->rank != false_expr->rank) + { + gfc_error ("expr at %L and expr at %L in conditional expression " + "must have the same rank", + &true_expr->where, &false_expr->where); + return false; + } + + /* TODO: support more data types for conditional expressions */ + if (true_expr->ts.type != BT_INTEGER && true_expr->ts.type != BT_LOGICAL + && true_expr->ts.type != BT_REAL && true_expr->ts.type != BT_COMPLEX) + { + gfc_error ("Sorry, only integer, logical, real and complex types " + "are currently supported for conditional expressions at %L", + &expr->where); + return false; + } + + if (true_expr->rank > 0) + { + gfc_error ("Sorry, array is currently unsupported for conditional " + "expressions at %L", + &expr->where); + return false; + } + + expr->ts = true_expr->ts; + expr->rank = true_expr->rank; + return true; +} /************** Array resolution subroutines **************/ @@ -5752,14 +5963,49 @@ gfc_resolve_substring_charlen (gfc_expr *e) } +/* Convert an array reference to an array element so that PDT KIND and LEN + or inquiry references are always scalar. */ + +static void +reset_array_ref_to_scalar (gfc_expr *expr, gfc_ref *array_ref) +{ + gfc_expr *unity = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); + int dim; + + array_ref->u.ar.type = AR_ELEMENT; + expr->rank = 0; + /* Suppress the runtime bounds check. */ + expr->no_bounds_check = 1; + for (dim = 0; dim < array_ref->u.ar.dimen; dim++) + { + array_ref->u.ar.dimen_type[dim] = DIMEN_ELEMENT; + if (array_ref->u.ar.start[dim]) + gfc_free_expr (array_ref->u.ar.start[dim]); + + if (array_ref->u.ar.as && array_ref->u.ar.as->lower[dim]) + array_ref->u.ar.start[dim] + = gfc_copy_expr (array_ref->u.ar.as->lower[dim]); + else + array_ref->u.ar.start[dim] = gfc_copy_expr (unity); + + if (array_ref->u.ar.end[dim]) + gfc_free_expr (array_ref->u.ar.end[dim]); + if (array_ref->u.ar.stride[dim]) + gfc_free_expr (array_ref->u.ar.stride[dim]); + } + gfc_free_expr (unity); +} + + /* Resolve subtype references. */ bool gfc_resolve_ref (gfc_expr *expr) { - int current_part_dimension, n_components, seen_part_dimension, dim; + int current_part_dimension, n_components, seen_part_dimension; gfc_ref *ref, **prev, *array_ref; bool equal_length; + gfc_symbol *last_pdt = NULL; for (ref = expr->ref; ref; ref = ref->next) if (ref->type == REF_ARRAY && ref->u.ar.as == NULL) @@ -5807,6 +6053,11 @@ gfc_resolve_ref (gfc_expr *expr) n_components = 0; array_ref = NULL; + if (expr->expr_type == EXPR_VARIABLE + && expr->symtree->n.sym->ts.type == BT_DERIVED + && expr->symtree->n.sym->ts.u.derived->attr.pdt_type) + last_pdt = expr->symtree->n.sym->ts.u.derived; + for (ref = expr->ref; ref; ref = ref->next) { switch (ref->type) @@ -5864,6 +6115,46 @@ gfc_resolve_ref (gfc_expr *expr) } } + /* Sometimes the component in a component reference is that of the + pdt_template. Point to the component of pdt_type instead. This + ensures that the component gets a backend_decl in translation. */ + if (last_pdt) + { + gfc_component *cmp = last_pdt->components; + for (; cmp; cmp = cmp->next) + if (!strcmp (cmp->name, ref->u.c.component->name)) + { + ref->u.c.component = cmp; + break; + } + ref->u.c.sym = last_pdt; + } + + /* Convert pdt_templates, if necessary, and update 'last_pdt'. */ + if (ref->u.c.component->ts.type == BT_DERIVED) + { + if (ref->u.c.component->ts.u.derived->attr.pdt_template) + { + if (gfc_get_pdt_instance (ref->u.c.component->param_list, + &ref->u.c.component->ts.u.derived, + NULL) != MATCH_YES) + return false; + last_pdt = ref->u.c.component->ts.u.derived; + } + else if (ref->u.c.component->ts.u.derived->attr.pdt_type) + last_pdt = ref->u.c.component->ts.u.derived; + else + last_pdt = NULL; + } + + /* The F08 standard requires(See R425, R431, R435, and in particular + Note 6.7) that a PDT parameter reference be a scalar even if + the designator is an array." */ + if (array_ref && last_pdt && last_pdt->attr.pdt_type + && (ref->u.c.component->attr.pdt_kind + || ref->u.c.component->attr.pdt_len)) + reset_array_ref_to_scalar (expr, array_ref); + n_components++; break; @@ -5876,27 +6167,7 @@ gfc_resolve_ref (gfc_expr *expr) if (ref->u.i == INQUIRY_LEN && array_ref && ((expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->length) || expr->ts.type == BT_INTEGER)) - { - array_ref->u.ar.type = AR_ELEMENT; - expr->rank = 0; - /* INQUIRY_LEN is not evaluated from the rest of the expr - but directly from the string length. This means that setting - the array indices to one does not matter but might trigger - a runtime bounds error. Suppress the check. */ - expr->no_bounds_check = 1; - for (dim = 0; dim < array_ref->u.ar.dimen; dim++) - { - array_ref->u.ar.dimen_type[dim] = DIMEN_ELEMENT; - if (array_ref->u.ar.start[dim]) - gfc_free_expr (array_ref->u.ar.start[dim]); - array_ref->u.ar.start[dim] - = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); - if (array_ref->u.ar.end[dim]) - gfc_free_expr (array_ref->u.ar.end[dim]); - if (array_ref->u.ar.stride[dim]) - gfc_free_expr (array_ref->u.ar.stride[dim]); - } - } + reset_array_ref_to_scalar (expr, array_ref); break; } @@ -6070,8 +6341,8 @@ gfc_op_rank_conformable (gfc_expr *op1, gfc_expr *op2) gfc_expression_rank (op2); return (op1->rank == 0 || op2->rank == 0 || op1->rank == op2->rank) - && (op1->corank == 0 || op2->corank == 0 - || op1->corank == op2->corank); + && (op1->corank == 0 || op2->corank == 0 || op1->corank == op2->corank + || (!gfc_is_coindexed (op1) && !gfc_is_coindexed (op2))); } /* Resolve a variable expression. */ @@ -7820,6 +8091,7 @@ fixup_unique_dummy (gfc_expr *e) e->symtree = st; } + /* Resolve an expression. That is, make sure that types of operands agree with their operators, intrinsic operators are converted to function calls for overloaded types and unresolved function references are resolved. */ @@ -7859,6 +8131,10 @@ gfc_resolve_expr (gfc_expr *e) t = resolve_operator (e); break; + case EXPR_CONDITIONAL: + t = resolve_conditional (e); + break; + case EXPR_FUNCTION: case EXPR_VARIABLE: @@ -7947,6 +8223,9 @@ gfc_resolve_expr (gfc_expr *e) && UNLIMITED_POLY (e->symtree->n.sym)) e->do_not_resolve_again = 1; + if (t && gfc_current_ns->import_state != IMPORT_NOT_SET) + t = check_import_status (e); + return t; } @@ -8740,8 +9019,25 @@ static bool conformable_arrays (gfc_expr *e1, gfc_expr *e2) { gfc_ref *tail; + bool scalar; + for (tail = e2->ref; tail && tail->next; tail = tail->next); + /* If MOLD= is present and is not scalar, and the allocate-object has an + explicit-shape-spec, the ranks need not agree. This may be unintended, + so let's emit a warning if -Wsurprising is given. */ + scalar = !tail || tail->type == REF_COMPONENT; + if (e1->mold && e1->rank > 0 + && (scalar || (tail->type == REF_ARRAY && tail->u.ar.type != AR_FULL))) + { + if (scalar || (tail->u.ar.as && e1->rank != tail->u.ar.as->rank)) + gfc_warning (OPT_Wsurprising, "Allocate-object at %L has rank %d " + "but MOLD= expression at %L has rank %d", + &e2->where, scalar ? 0 : tail->u.ar.as->rank, + &e1->where, e1->rank); + return true; + } + /* First compare rank. */ if ((tail && (!tail->u.ar.as || e1->rank != tail->u.ar.as->rank)) || (!tail && e1->rank != e2->rank)) @@ -10583,6 +10879,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) int rank = 0, corank = 0; gfc_ref* ref = NULL; gfc_expr *selector_expr = NULL; + gfc_code *old_code = code; ns = code->ext.block.ns; if (code->expr2) @@ -10802,6 +11099,8 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) ref = gfc_copy_ref (ref); } + gfc_expr *orig_expr1 = code->expr1; + /* Add EXEC_SELECT to switch on type. */ new_st = gfc_get_code (code->op); new_st->expr1 = code->expr1; @@ -10829,7 +11128,6 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) for (body = code->block; body; body = body->block) { gfc_symbol *vtab; - gfc_expr *e; c = body->ext.block.case_list; /* Generate an index integer expression for address of the @@ -10837,6 +11135,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) is stored in c->high and is used to resolve intrinsic cases. */ if (c->ts.type != BT_UNKNOWN) { + gfc_expr *e; if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) { vtab = gfc_find_derived_vtab (c->ts.u.derived); @@ -10870,10 +11169,24 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) that does precisely this here (instead of using the 'global' one). */ + /* First check the derived type import status. */ + if (gfc_current_ns->import_state != IMPORT_NOT_SET + && (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)) + { + st = gfc_find_symtree (gfc_current_ns->sym_root, + c->ts.u.derived->name); + if (!check_sym_import_status (c->ts.u.derived, st, NULL, old_code, + gfc_current_ns)) + error++; + } + + const char * var_name = gfc_var_name_for_select_type_temp (orig_expr1); if (c->ts.type == BT_CLASS) - sprintf (name, "__tmp_class_%s", c->ts.u.derived->name); + snprintf (name, sizeof (name), "__tmp_class_%s_%s", + c->ts.u.derived->name, var_name); else if (c->ts.type == BT_DERIVED) - sprintf (name, "__tmp_type_%s", c->ts.u.derived->name); + snprintf (name, sizeof (name), "__tmp_type_%s_%s", + c->ts.u.derived->name, var_name); else if (c->ts.type == BT_CHARACTER) { HOST_WIDE_INT charlen = 0; @@ -10881,12 +11194,13 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) && c->ts.u.cl->length->expr_type == EXPR_CONSTANT) charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer); snprintf (name, sizeof (name), - "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d", - gfc_basic_typename (c->ts.type), charlen, c->ts.kind); + "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d_%s", + gfc_basic_typename (c->ts.type), charlen, c->ts.kind, + var_name); } else - sprintf (name, "__tmp_%s_%d", gfc_basic_typename (c->ts.type), - c->ts.kind); + snprintf (name, sizeof (name), "__tmp_%s_%d_%s", + gfc_basic_typename (c->ts.type), c->ts.kind, var_name); st = gfc_find_symtree (ns->sym_root, name); gcc_assert (st->n.sym->assoc); @@ -14323,6 +14637,13 @@ build_init_assign (gfc_symbol *sym, gfc_expr *init) gfc_code *init_st; gfc_namespace *ns = sym->ns; + if (sym->attr.function && sym->result == sym + && sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type) + { + gfc_free_expr (init); + return; + } + /* Search for the function namespace if this is a contained function without an explicit result. */ if (sym->attr.function && sym == sym->result @@ -15445,6 +15766,31 @@ error: } +static gfc_symbol * containing_dt; + +/* Helper function for check_generic_tbp_ambiguity, which ensures that passed + arguments whose declared types are PDT instances only transmit the PASS arg + if they match the enclosing derived type. */ + +static bool +check_pdt_args (gfc_tbp_generic* t, const char *pass) +{ + gfc_formal_arglist *dummy_args; + if (pass && containing_dt != NULL && containing_dt->attr.pdt_type) + { + dummy_args = gfc_sym_get_dummy_args (t->specific->u.specific->n.sym); + while (dummy_args && strcmp (pass, dummy_args->sym->name)) + dummy_args = dummy_args->next; + gcc_assert (strcmp (pass, dummy_args->sym->name) == 0); + if (dummy_args->sym->ts.type == BT_CLASS + && strcmp (CLASS_DATA (dummy_args->sym)->ts.u.derived->name, + containing_dt->name)) + return true; + } + return false; +} + + /* Check if two GENERIC targets are ambiguous and emit an error is they are. */ static bool @@ -15502,6 +15848,17 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2, pass2 = NULL; } + /* Care must be taken with pdt types and templates because the declared type + of the argument that is not 'no_pass' need not be the same as the + containing derived type. If this is the case, subject the argument to + the full interface check, even though it cannot be used in the type + bound context. */ + pass1 = check_pdt_args (t1, pass1) ? NULL : pass1; + pass2 = check_pdt_args (t2, pass2) ? NULL : pass2; + + if (containing_dt != NULL && containing_dt->attr.pdt_template) + pass1 = pass2 = NULL; + /* Compare the interfaces. */ if (gfc_compare_interfaces (sym1, sym2, sym2->name, !t1->is_operator, 0, NULL, 0, pass1, pass2)) @@ -15949,8 +16306,10 @@ resolve_typebound_procedure (gfc_symtree* stree) goto error; } - /* The derived type is not a PDT template. Resolve as usual. */ + /* The derived type is not a PDT template or type. Resolve as usual. */ if (!resolve_bindings_derived->attr.pdt_template + && !(containing_dt && containing_dt->attr.pdt_type + && CLASS_DATA (me_arg)->ts.u.derived != containing_dt) && (CLASS_DATA (me_arg)->ts.u.derived != resolve_bindings_derived)) { gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of " @@ -16097,6 +16456,7 @@ resolve_typebound_procedures (gfc_symbol* derived) resolve_bindings_derived = derived; resolve_bindings_result = true; + containing_dt = derived; /* Needed for checks of PDTs. */ if (derived->f2k_derived->tb_sym_root) gfc_traverse_symtree (derived->f2k_derived->tb_sym_root, &resolve_typebound_procedure); @@ -16104,6 +16464,7 @@ resolve_typebound_procedures (gfc_symbol* derived) if (derived->f2k_derived->tb_uop_root) gfc_traverse_symtree (derived->f2k_derived->tb_uop_root, &resolve_typebound_user_op); + containing_dt = NULL; for (op = 0; op != GFC_INTRINSIC_OPS; ++op) { @@ -16326,6 +16687,26 @@ resolve_component (gfc_component *c, gfc_symbol *sym) return false; } + if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pdt_template + && !sym->attr.pdt_type && !sym->attr.pdt_template + && !(gfc_get_derived_super_type (sym) + && (gfc_get_derived_super_type (sym)->attr.pdt_type + || gfc_get_derived_super_type (sym)->attr.pdt_template))) + { + gfc_actual_arglist *type_spec_list; + if (gfc_get_pdt_instance (c->param_list, &c->ts.u.derived, + &type_spec_list) + != MATCH_YES) + return false; + gfc_free_actual_arglist (c->param_list); + c->param_list = type_spec_list; + if (!sym->attr.pdt_type) + sym->attr.pdt_comp = 1; + } + else if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pdt_type + && !sym->attr.pdt_type) + sym->attr.pdt_comp = 1; + if (c->attr.proc_pointer && c->ts.interface) { gfc_symbol *ifc = c->ts.interface; @@ -16520,27 +16901,30 @@ resolve_component (gfc_component *c, gfc_symbol *sym) && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL)) { gfc_error ("Component %qs of %qs at %L has the same name as an" - " inherited type-bound procedure", - c->name, sym->name, &c->loc); + " inherited type-bound procedure", + c->name, sym->name, &c->loc); return false; } if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer - && !c->ts.deferred) - { - if (c->ts.u.cl->length == NULL - || (!resolve_charlen(c->ts.u.cl)) - || !gfc_is_constant_expr (c->ts.u.cl->length)) - { - gfc_error ("Character length of component %qs needs to " - "be a constant specification expression at %L", - c->name, - c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc); - return false; - } + && !c->ts.deferred) + { + if (sym->attr.pdt_template || c->attr.pdt_string) + gfc_correct_parm_expr (sym, &c->ts.u.cl->length); + + if (c->ts.u.cl->length == NULL + || !resolve_charlen(c->ts.u.cl) + || !gfc_is_constant_expr (c->ts.u.cl->length)) + { + gfc_error ("Character length of component %qs needs to " + "be a constant specification expression at %L", + c->name, + c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc); + return false; + } if (c->ts.u.cl->length && c->ts.u.cl->length->ts.type != BT_INTEGER) - { + { if (!c->ts.u.cl->length->error) { gfc_error ("Character length expression of component %qs at %L " @@ -16557,8 +16941,8 @@ resolve_component (gfc_component *c, gfc_symbol *sym) && !c->attr.pointer && !c->attr.allocatable) { gfc_error ("Character component %qs of %qs at %L with deferred " - "length must be a POINTER or ALLOCATABLE", - c->name, sym->name, &c->loc); + "length must be a POINTER or ALLOCATABLE", + c->name, sym->name, &c->loc); return false; } @@ -16573,14 +16957,14 @@ resolve_component (gfc_component *c, gfc_symbol *sym) sprintf (name, "_%s_length", c->name); strlen = gfc_find_component (sym, name, true, true, NULL); if (strlen == NULL) - { - if (!gfc_add_component (sym, name, &strlen)) - return false; - strlen->ts.type = BT_INTEGER; - strlen->ts.kind = gfc_charlen_int_kind; - strlen->attr.access = ACCESS_PRIVATE; - strlen->attr.artificial = 1; - } + { + if (!gfc_add_component (sym, name, &strlen)) + return false; + strlen->ts.type = BT_INTEGER; + strlen->ts.kind = gfc_charlen_int_kind; + strlen->attr.access = ACCESS_PRIVATE; + strlen->attr.artificial = 1; + } } if (c->ts.type == BT_DERIVED @@ -16590,27 +16974,27 @@ resolve_component (gfc_component *c, gfc_symbol *sym) && !c->ts.u.derived->attr.use_assoc && !gfc_check_symbol_access (c->ts.u.derived) && !gfc_notify_std (GFC_STD_F2003, "the component %qs is a " - "PRIVATE type and cannot be a component of " - "%qs, which is PUBLIC at %L", c->name, - sym->name, &sym->declared_at)) + "PRIVATE type and cannot be a component of " + "%qs, which is PUBLIC at %L", c->name, + sym->name, &sym->declared_at)) return false; if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS) { gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) " - "type %s", c->name, &c->loc, sym->name); + "type %s", c->name, &c->loc, sym->name); return false; } if (sym->attr.sequence) { if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0) - { + { gfc_error ("Component %s of SEQUENCE type declared at %L does " - "not have the SEQUENCE attribute", - c->ts.u.derived->name, &sym->declared_at); - return false; - } + "not have the SEQUENCE attribute", + c->ts.u.derived->name, &sym->declared_at); + return false; + } } if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic) @@ -16618,7 +17002,7 @@ resolve_component (gfc_component *c, gfc_symbol *sym) else if (c->ts.type == BT_CLASS && c->attr.class_ok && CLASS_DATA (c)->ts.u.derived->attr.generic) CLASS_DATA (c)->ts.u.derived - = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived); + = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived); /* If an allocatable component derived type is of the same type as the enclosing derived type, we need a vtable generating so that @@ -16631,10 +17015,10 @@ resolve_component (gfc_component *c, gfc_symbol *sym) derived type list; even in formal namespaces, where derived type pointer components might not have been declared. */ if (c->ts.type == BT_DERIVED - && c->ts.u.derived - && c->ts.u.derived->components - && c->attr.pointer - && sym != c->ts.u.derived) + && c->ts.u.derived + && c->ts.u.derived->components + && c->attr.pointer + && sym != c->ts.u.derived) add_dt_to_dt_list (c->ts.u.derived); if (c->as && c->as->type != AS_DEFERRED @@ -16642,8 +17026,8 @@ resolve_component (gfc_component *c, gfc_symbol *sym) return false; if (!gfc_resolve_array_spec (c->as, - !(c->attr.pointer || c->attr.proc_pointer - || c->attr.allocatable))) + !(c->attr.pointer || c->attr.proc_pointer + || c->attr.allocatable))) return false; if (c->initializer && !sym->attr.vtype @@ -16819,8 +17203,8 @@ resolve_fl_derived0 (gfc_symbol *sym) return false; /* Now add the caf token field, where needed. */ - if (flag_coarray != GFC_FCOARRAY_NONE - && !sym->attr.is_class && !sym->attr.vtype) + if (flag_coarray == GFC_FCOARRAY_LIB && !sym->attr.is_class + && !sym->attr.vtype) { for (c = sym->components; c; c = c->next) if (!c->attr.dimension && !c->attr.codimension @@ -18059,16 +18443,16 @@ skip_interfaces: || (a->dummy && !a->pointer && a->intent == INTENT_OUT && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)) apply_default_init (sym); + else if (a->function && !a->pointer && !a->allocatable && !a->use_assoc + && sym->result) + /* Default initialization for function results. */ + apply_default_init (sym->result); else if (a->function && sym->result && a->access != ACCESS_PRIVATE && (sym->ts.u.derived->attr.alloc_comp || sym->ts.u.derived->attr.pointer_comp)) /* Mark the result symbol to be referenced, when it has allocatable components. */ sym->result->attr.referenced = 1; - else if (a->function && !a->pointer && !a->allocatable && !a->use_assoc - && sym->result) - /* Default initialization for function results. */ - apply_default_init (sym->result); } if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc index 208251b..00b02f3 100644 --- a/gcc/fortran/simplify.cc +++ b/gcc/fortran/simplify.cc @@ -120,10 +120,26 @@ static int get_kind (bt type, gfc_expr *k, const char *name, int default_kind) { int kind; + gfc_expr *tmp; if (k == NULL) return default_kind; + if (k->expr_type == EXPR_VARIABLE + && k->symtree->n.sym->ts.type == BT_DERIVED + && k->symtree->n.sym->ts.u.derived->attr.pdt_type) + { + gfc_ref *ref; + for (ref = k->ref; ref; ref = ref->next) + if (!ref->next && ref->type == REF_COMPONENT + && ref->u.c.component->attr.pdt_kind + && ref->u.c.component->initializer) + { + tmp = gfc_copy_expr (ref->u.c.component->initializer); + gfc_replace_expr (k, tmp); + } + } + if (k->expr_type != EXPR_CONSTANT) { gfc_error ("KIND parameter of %s at %L must be an initialization " @@ -885,7 +901,8 @@ gfc_simplify_acos (gfc_expr *x) if (mpfr_cmp_si (x->value.real, 1) > 0 || mpfr_cmp_si (x->value.real, -1) < 0) { - gfc_error ("Argument of ACOS at %L must be between -1 and 1", + gfc_error ("Argument of ACOS at %L must be within the closed " + "interval [-1, 1]", &x->where); return &gfc_bad_expr; } @@ -1162,7 +1179,8 @@ gfc_simplify_asin (gfc_expr *x) if (mpfr_cmp_si (x->value.real, 1) > 0 || mpfr_cmp_si (x->value.real, -1) < 0) { - gfc_error ("Argument of ASIN at %L must be between -1 and 1", + gfc_error ("Argument of ASIN at %L must be within the closed " + "interval [-1, 1]", &x->where); return &gfc_bad_expr; } @@ -1183,6 +1201,7 @@ gfc_simplify_asin (gfc_expr *x) } +#if MPFR_VERSION < MPFR_VERSION_NUM(4,2,0) /* Convert radians to degrees, i.e., x * 180 / pi. */ static void @@ -1196,6 +1215,7 @@ rad2deg (mpfr_t x) mpfr_div (x, x, tmp, GFC_RND_MODE); mpfr_clear (tmp); } +#endif /* Simplify ACOSD(X) where the returned value has units of degree. */ @@ -1211,14 +1231,19 @@ gfc_simplify_acosd (gfc_expr *x) if (mpfr_cmp_si (x->value.real, 1) > 0 || mpfr_cmp_si (x->value.real, -1) < 0) { - gfc_error ("Argument of ACOSD at %L must be between -1 and 1", - &x->where); + gfc_error ( + "Argument of ACOSD at %L must be within the closed interval [-1, 1]", + &x->where); return &gfc_bad_expr; } result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); +#if MPFR_VERSION >= MPFR_VERSION_NUM(4,2,0) + mpfr_acosu (result->value.real, x->value.real, 360, GFC_RND_MODE); +#else mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE); rad2deg (result->value.real); +#endif return range_check (result, "ACOSD"); } @@ -1237,14 +1262,19 @@ gfc_simplify_asind (gfc_expr *x) if (mpfr_cmp_si (x->value.real, 1) > 0 || mpfr_cmp_si (x->value.real, -1) < 0) { - gfc_error ("Argument of ASIND at %L must be between -1 and 1", - &x->where); + gfc_error ( + "Argument of ASIND at %L must be within the closed interval [-1, 1]", + &x->where); return &gfc_bad_expr; } result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); +#if MPFR_VERSION >= MPFR_VERSION_NUM(4,2,0) + mpfr_asinu (result->value.real, x->value.real, 360, GFC_RND_MODE); +#else mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE); rad2deg (result->value.real); +#endif return range_check (result, "ASIND"); } @@ -1261,8 +1291,12 @@ gfc_simplify_atand (gfc_expr *x) return NULL; result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); +#if MPFR_VERSION >= MPFR_VERSION_NUM(4,2,0) + mpfr_atanu (result->value.real, x->value.real, 360, GFC_RND_MODE); +#else mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE); rad2deg (result->value.real); +#endif return range_check (result, "ATAND"); } @@ -1369,7 +1403,7 @@ gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x) if (mpfr_zero_p (y->value.real) && mpfr_zero_p (x->value.real)) { - gfc_error ("If first argument of ATAN2 at %L is zero, then the " + gfc_error ("If the first argument of ATAN2 at %L is zero, then the " "second argument must not be zero", &y->where); return &gfc_bad_expr; } @@ -1948,14 +1982,19 @@ gfc_simplify_atan2d (gfc_expr *y, gfc_expr *x) if (mpfr_zero_p (y->value.real) && mpfr_zero_p (x->value.real)) { - gfc_error ("If first argument of ATAN2D at %L is zero, then the " + gfc_error ("If the first argument of ATAN2D at %L is zero, then the " "second argument must not be zero", &y->where); return &gfc_bad_expr; } result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); +#if MPFR_VERSION >= MPFR_VERSION_NUM(4,2,0) + mpfr_atan2u (result->value.real, y->value.real, x->value.real, 360, + GFC_RND_MODE); +#else mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE); rad2deg (result->value.real); +#endif return range_check (result, "ATAN2D"); } @@ -1990,6 +2029,8 @@ gfc_simplify_cos (gfc_expr *x) } +#if MPFR_VERSION < MPFR_VERSION_NUM(4,2,0) +/* Used by trigd_fe.inc. */ static void deg2rad (mpfr_t x) { @@ -2001,11 +2042,13 @@ deg2rad (mpfr_t x) mpfr_mul (x, x, d2r, GFC_RND_MODE); mpfr_clear (d2r); } +#endif +#if MPFR_VERSION < MPFR_VERSION_NUM(4,2,0) /* Simplification routines for SIND, COSD, TAND. */ #include "trigd_fe.inc" - +#endif /* Simplify COSD(X) where X has the unit of degree. */ @@ -2018,8 +2061,12 @@ gfc_simplify_cosd (gfc_expr *x) return NULL; result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); +#if MPFR_VERSION >= MPFR_VERSION_NUM(4,2,0) + mpfr_cosu (result->value.real, x->value.real, 360, GFC_RND_MODE); +#else mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); simplify_cosd (result->value.real); +#endif return range_check (result, "COSD"); } @@ -2036,8 +2083,12 @@ gfc_simplify_sind (gfc_expr *x) return NULL; result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); +#if MPFR_VERSION >= MPFR_VERSION_NUM(4,2,0) + mpfr_sinu (result->value.real, x->value.real, 360, GFC_RND_MODE); +#else mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); simplify_sind (result->value.real); +#endif return range_check (result, "SIND"); } @@ -2054,8 +2105,12 @@ gfc_simplify_tand (gfc_expr *x) return NULL; result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); +#if MPFR_VERSION >= MPFR_VERSION_NUM(4,2,0) + mpfr_tanu (result->value.real, x->value.real, 360, GFC_RND_MODE); +#else mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); simplify_tand (result->value.real); +#endif return range_check (result, "TAND"); } @@ -2078,7 +2133,11 @@ gfc_simplify_cotand (gfc_expr *x) result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); mpfr_set (result->value.real, x->value.real, GFC_RND_MODE); mpfr_add_ui (result->value.real, result->value.real, 90, GFC_RND_MODE); +#if MPFR_VERSION >= MPFR_VERSION_NUM(4,2,0) + mpfr_tanu (result->value.real, result->value.real, 360, GFC_RND_MODE); +#else simplify_tand (result->value.real); +#endif mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE); return range_check (result, "COTAND"); @@ -2112,6 +2171,250 @@ gfc_simplify_cosh (gfc_expr *x) return range_check (result, "COSH"); } +gfc_expr * +gfc_simplify_acospi (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + if (mpfr_cmp_si (x->value.real, 1) > 0 || mpfr_cmp_si (x->value.real, -1) < 0) + { + gfc_error ( + "Argument of ACOSPI at %L must be within the closed interval [-1, 1]", + &x->where); + return &gfc_bad_expr; + } + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + +#if MPFR_VERSION >= MPFR_VERSION_NUM(4, 2, 0) + mpfr_acospi (result->value.real, x->value.real, GFC_RND_MODE); +#else + mpfr_t pi, tmp; + mpfr_inits2 (2 * mpfr_get_prec (x->value.real), pi, tmp, NULL); + mpfr_const_pi (pi, GFC_RND_MODE); + mpfr_acos (tmp, x->value.real, GFC_RND_MODE); + mpfr_div (result->value.real, tmp, pi, GFC_RND_MODE); + mpfr_clears (pi, tmp, NULL); +#endif + + return result; +} + +gfc_expr * +gfc_simplify_asinpi (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + if (mpfr_cmp_si (x->value.real, 1) > 0 || mpfr_cmp_si (x->value.real, -1) < 0) + { + gfc_error ( + "Argument of ASINPI at %L must be within the closed interval [-1, 1]", + &x->where); + return &gfc_bad_expr; + } + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + +#if MPFR_VERSION >= MPFR_VERSION_NUM(4, 2, 0) + mpfr_asinpi (result->value.real, x->value.real, GFC_RND_MODE); +#else + mpfr_t pi, tmp; + mpfr_inits2 (2 * mpfr_get_prec (x->value.real), pi, tmp, NULL); + mpfr_const_pi (pi, GFC_RND_MODE); + mpfr_asin (tmp, x->value.real, GFC_RND_MODE); + mpfr_div (result->value.real, tmp, pi, GFC_RND_MODE); + mpfr_clears (pi, tmp, NULL); +#endif + + return result; +} + +gfc_expr * +gfc_simplify_atanpi (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + +#if MPFR_VERSION >= MPFR_VERSION_NUM(4, 2, 0) + mpfr_atanpi (result->value.real, x->value.real, GFC_RND_MODE); +#else + mpfr_t pi, tmp; + mpfr_inits2 (2 * mpfr_get_prec (x->value.real), pi, tmp, NULL); + mpfr_const_pi (pi, GFC_RND_MODE); + mpfr_atan (tmp, x->value.real, GFC_RND_MODE); + mpfr_div (result->value.real, tmp, pi, GFC_RND_MODE); + mpfr_clears (pi, tmp, NULL); +#endif + + return range_check (result, "ATANPI"); +} + +gfc_expr * +gfc_simplify_atan2pi (gfc_expr *y, gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + if (mpfr_zero_p (y->value.real) && mpfr_zero_p (x->value.real)) + { + gfc_error ("If the first argument of ATAN2PI at %L is zero, then the " + "second argument must not be zero", + &y->where); + return &gfc_bad_expr; + } + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + +#if MPFR_VERSION >= MPFR_VERSION_NUM(4, 2, 0) + mpfr_atan2pi (result->value.real, y->value.real, x->value.real, GFC_RND_MODE); +#else + mpfr_t pi, tmp; + mpfr_inits2 (2 * mpfr_get_prec (x->value.real), pi, tmp, NULL); + mpfr_const_pi (pi, GFC_RND_MODE); + mpfr_atan2 (tmp, y->value.real, x->value.real, GFC_RND_MODE); + mpfr_div (result->value.real, tmp, pi, GFC_RND_MODE); + mpfr_clears (pi, tmp, NULL); +#endif + + return range_check (result, "ATAN2PI"); +} + +gfc_expr * +gfc_simplify_cospi (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + +#if MPFR_VERSION >= MPFR_VERSION_NUM(4, 2, 0) + mpfr_cospi (result->value.real, x->value.real, GFC_RND_MODE); +#else + mpfr_t cs, n, r, two; + int s; + + mpfr_inits2 (2 * mpfr_get_prec (x->value.real), cs, n, r, two, NULL); + + mpfr_abs (r, x->value.real, GFC_RND_MODE); + mpfr_modf (n, r, r, GFC_RND_MODE); + + if (mpfr_cmp_d (r, 0.5) == 0) + { + mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); + return result; + } + + mpfr_set_ui (two, 2, GFC_RND_MODE); + mpfr_fmod (cs, n, two, GFC_RND_MODE); + s = mpfr_cmp_ui (cs, 0) == 0 ? 1 : -1; + + mpfr_const_pi (cs, GFC_RND_MODE); + mpfr_mul (cs, cs, r, GFC_RND_MODE); + mpfr_cos (cs, cs, GFC_RND_MODE); + mpfr_mul_si (result->value.real, cs, s, GFC_RND_MODE); + + mpfr_clears (cs, n, r, two, NULL); +#endif + + return range_check (result, "COSPI"); +} + +gfc_expr * +gfc_simplify_sinpi (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + +#if MPFR_VERSION >= MPFR_VERSION_NUM(4, 2, 0) + mpfr_sinpi (result->value.real, x->value.real, GFC_RND_MODE); +#else + mpfr_t sn, n, r, two; + int s; + + mpfr_inits2 (2 * mpfr_get_prec (x->value.real), sn, n, r, two, NULL); + + mpfr_abs (r, x->value.real, GFC_RND_MODE); + mpfr_modf (n, r, r, GFC_RND_MODE); + + if (mpfr_cmp_d (r, 0.0) == 0) + { + mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); + return result; + } + + mpfr_set_ui (two, 2, GFC_RND_MODE); + mpfr_fmod (sn, n, two, GFC_RND_MODE); + s = mpfr_cmp_si (x->value.real, 0) < 0 ? -1 : 1; + s *= mpfr_cmp_ui (sn, 0) == 0 ? 1 : -1; + + mpfr_const_pi (sn, GFC_RND_MODE); + mpfr_mul (sn, sn, r, GFC_RND_MODE); + mpfr_sin (sn, sn, GFC_RND_MODE); + mpfr_mul_si (result->value.real, sn, s, GFC_RND_MODE); + + mpfr_clears (sn, n, r, two, NULL); +#endif + + return range_check (result, "SINPI"); +} + +gfc_expr * +gfc_simplify_tanpi (gfc_expr *x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + +#if MPFR_VERSION >= MPFR_VERSION_NUM(4, 2, 0) + mpfr_tanpi (result->value.real, x->value.real, GFC_RND_MODE); +#else + mpfr_t tn, n, r; + int s; + + mpfr_inits2 (2 * mpfr_get_prec (x->value.real), tn, n, r, NULL); + + mpfr_abs (r, x->value.real, GFC_RND_MODE); + mpfr_modf (n, r, r, GFC_RND_MODE); + + if (mpfr_cmp_d (r, 0.0) == 0) + { + mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); + return result; + } + + s = mpfr_cmp_si (x->value.real, 0) < 0 ? -1 : 1; + + mpfr_const_pi (tn, GFC_RND_MODE); + mpfr_mul (tn, tn, r, GFC_RND_MODE); + mpfr_tan (tn, tn, GFC_RND_MODE); + mpfr_mul_si (result->value.real, tn, s, GFC_RND_MODE); + + mpfr_clears (tn, n, r, NULL); +#endif + + return range_check (result, "TANPI"); +} gfc_expr * gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind) diff --git a/gcc/fortran/st.cc b/gcc/fortran/st.cc index f7f67b1..2281bf6 100644 --- a/gcc/fortran/st.cc +++ b/gcc/fortran/st.cc @@ -86,6 +86,10 @@ gfc_free_statement (gfc_code *p) gfc_free_expr (p->expr1); if (p->expr2) gfc_free_expr (p->expr2); + if (p->expr3) + gfc_free_expr (p->expr3); + if (p->expr4) + gfc_free_expr (p->expr4); switch (p->op) { diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc index 81aa81d..8211d92 100644 --- a/gcc/fortran/symbol.cc +++ b/gcc/fortran/symbol.cc @@ -5500,7 +5500,16 @@ gfc_namespace * gfc_get_procedure_ns (gfc_symbol *sym) { if (sym->formal_ns - && sym->formal_ns->proc_name == sym) + && sym->formal_ns->proc_name == sym + /* For module procedures used in submodules, there are two namespaces. + The one generated by the host association of the module is directly + accessible through SYM->FORMAL_NS but doesn't have any parent set. + The one generated by the parser is only accessible by walking the + contained namespace but has its parent set. Prefer the one generated + by the parser below. */ + && !(sym->attr.used_in_submodule + && sym->attr.contained + && sym->formal_ns->parent == nullptr)) return sym->formal_ns; /* The above should have worked in most cases. If it hasn't, try some other @@ -5515,6 +5524,10 @@ gfc_get_procedure_ns (gfc_symbol *sym) if (ns->proc_name == sym) return ns; + if (sym->formal_ns + && sym->formal_ns->proc_name == sym) + return sym->formal_ns; + if (sym->formal) for (gfc_formal_arglist *f = sym->formal; f != nullptr; f = f->next) if (f->sym) diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 9606131..e2b17a7 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -284,16 +284,6 @@ gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value) } -/* This provides address access to the data field. This should only be - used by array allocation, passing this on to the runtime. */ - -tree -gfc_conv_descriptor_data_addr (tree desc) -{ - tree field = gfc_get_descriptor_field (desc, DATA_FIELD); - return gfc_build_addr_expr (NULL_TREE, field); -} - static tree gfc_conv_descriptor_offset (tree desc) { @@ -1426,12 +1416,6 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype, tmp2 = gfc_class_len_get (class_expr); gfc_add_modify (pre, tmp, tmp2); } - - if (rhs_function) - { - tmp = gfc_class_data_get (class_expr); - gfc_conv_descriptor_offset_set (pre, tmp, gfc_index_zero_node); - } } else if (rhs_ss->info->data.array.descriptor) { @@ -1991,14 +1975,17 @@ static void gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc, tree offset, gfc_se * se, gfc_expr * expr) { - tree tmp; + tree tmp, offset_eval; gfc_conv_expr (se, expr); /* Store the value. */ tmp = build_fold_indirect_ref_loc (input_location, gfc_conv_descriptor_data_get (desc)); - tmp = gfc_build_array_ref (tmp, offset, NULL); + /* The offset may change, so get its value now and use that to free memory. + */ + offset_eval = gfc_evaluate_now (offset, &se->pre); + tmp = gfc_build_array_ref (tmp, offset_eval, NULL); if (expr->expr_type == EXPR_FUNCTION && expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp) @@ -3118,7 +3105,6 @@ trans_array_constructor (gfc_ss * ss, locus * where) gfc_array_index_type, offsetvar, gfc_index_one_node); tmp = gfc_evaluate_now (tmp, &outer_loop->pre); - gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp); if (*loop_ubound0 && VAR_P (*loop_ubound0)) gfc_add_modify (&outer_loop->pre, *loop_ubound0, tmp); else @@ -3150,8 +3136,7 @@ finish: the reference. */ if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS) && finalblock.head != NULL_TREE) - gfc_add_block_to_block (&loop->post, &finalblock); - + gfc_prepend_expr_to_block (&loop->post, finalblock.head); } @@ -3370,18 +3355,51 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, break; case GFC_SS_FUNCTION: - /* Array function return value. We call the function and save its - result in a temporary for use inside the loop. */ - gfc_init_se (&se, NULL); - se.loop = loop; - se.ss = ss; - if (gfc_is_class_array_function (expr)) - expr->must_finalize = 1; - gfc_conv_expr (&se, expr); - gfc_add_block_to_block (&outer_loop->pre, &se.pre); - gfc_add_block_to_block (&outer_loop->post, &se.post); - gfc_add_block_to_block (&outer_loop->post, &se.finalblock); - ss_info->string_length = se.string_length; + { + /* Array function return value. We call the function and save its + result in a temporary for use inside the loop. */ + gfc_init_se (&se, NULL); + se.loop = loop; + se.ss = ss; + bool class_func = gfc_is_class_array_function (expr); + if (class_func) + expr->must_finalize = 1; + gfc_conv_expr (&se, expr); + gfc_add_block_to_block (&outer_loop->pre, &se.pre); + if (class_func + && se.expr + && GFC_CLASS_TYPE_P (TREE_TYPE (se.expr))) + { + tree tmp = gfc_class_data_get (se.expr); + info->descriptor = tmp; + info->data = gfc_conv_descriptor_data_get (tmp); + info->offset = gfc_conv_descriptor_offset_get (tmp); + for (gfc_ss *s = ss; s; s = s->parent) + for (int n = 0; n < s->dimen; n++) + { + int dim = s->dim[n]; + tree tree_dim = gfc_rank_cst[dim]; + + tree start; + start = gfc_conv_descriptor_lbound_get (tmp, tree_dim); + start = gfc_evaluate_now (start, &outer_loop->pre); + info->start[dim] = start; + + tree end; + end = gfc_conv_descriptor_ubound_get (tmp, tree_dim); + end = gfc_evaluate_now (end, &outer_loop->pre); + info->end[dim] = end; + + tree stride; + stride = gfc_conv_descriptor_stride_get (tmp, tree_dim); + stride = gfc_evaluate_now (stride, &outer_loop->pre); + info->stride[dim] = stride; + } + } + gfc_add_block_to_block (&outer_loop->post, &se.post); + gfc_add_block_to_block (&outer_loop->post, &se.finalblock); + ss_info->string_length = se.string_length; + } break; case GFC_SS_CONSTRUCTOR: @@ -3418,6 +3436,183 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, } +/* Given an array descriptor expression DESCR and its data pointer DATA, decide + whether to either save the data pointer to a variable and use the variable or + use the data pointer expression directly without any intermediary variable. + */ + +static bool +save_descriptor_data (tree descr, tree data) +{ + return !(DECL_P (data) + || (TREE_CODE (data) == ADDR_EXPR + && DECL_P (TREE_OPERAND (data, 0))) + || (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (descr)) + && TREE_CODE (descr) == COMPONENT_REF + && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (descr, 0))))); +} + + +/* Type of the DATA argument passed to walk_tree by substitute_subexpr_in_expr + and used by maybe_substitute_expr. */ + +typedef struct +{ + tree target, repl; +} +substitute_t; + + +/* Check if the expression in *TP is equal to the substitution target provided + in DATA->TARGET and replace it with DATA->REPL in that case. This is a + callback function for use with walk_tree. */ + +static tree +maybe_substitute_expr (tree *tp, int *walk_subtree, void *data) +{ + substitute_t *subst = (substitute_t *) data; + if (*tp == subst->target) + { + *tp = subst->repl; + *walk_subtree = 0; + } + + return NULL_TREE; +} + + +/* Substitute in EXPR any occurence of TARGET with REPLACEMENT. */ + +static void +substitute_subexpr_in_expr (tree target, tree replacement, tree expr) +{ + substitute_t subst; + subst.target = target; + subst.repl = replacement; + + walk_tree (&expr, maybe_substitute_expr, &subst, nullptr); +} + + +/* Save REF to a fresh variable in all of REPLACEMENT_ROOTS, appending extra + code to CODE. Before returning, add REF to REPLACEMENT_ROOTS and clear + REF. */ + +static void +save_ref (tree &code, tree &ref, vec<tree> &replacement_roots) +{ + stmtblock_t tmp_block; + gfc_init_block (&tmp_block); + tree var = gfc_evaluate_now (ref, &tmp_block); + gfc_add_expr_to_block (&tmp_block, code); + code = gfc_finish_block (&tmp_block); + + unsigned i; + tree repl_root; + FOR_EACH_VEC_ELT (replacement_roots, i, repl_root) + substitute_subexpr_in_expr (ref, var, repl_root); + + replacement_roots.safe_push (ref); + ref = NULL_TREE; +} + + +/* Save the descriptor reference VALUE to storage pointed by DESC_PTR. Before + that, try to factor subexpressions of VALUE to variables, adding extra code + to BLOCK. + + The candidate references to factoring are dereferenced pointers because they + are cheap to copy and array descriptors because they are often the base of + multiple subreferences. */ + +static void +set_factored_descriptor_value (tree *desc_ptr, tree value, stmtblock_t *block) +{ + /* As the reference is processed from outer to inner, variable definitions + will be generated in reversed order, so can't be put directly in BLOCK. + We use TMP_BLOCK instead. */ + tree accumulated_code = NULL_TREE; + + /* The current candidate to factoring. */ + tree saveable_ref = NULL_TREE; + + /* The root expressions in which we look for subexpressions to replace with + variables. */ + auto_vec<tree> replacement_roots; + replacement_roots.safe_push (value); + + tree data_ref = value; + tree next_ref = NULL_TREE; + + /* If the candidate reference is not followed by a subreference, it can't be + saved to a variable as it may be reallocatable, and we have to keep the + parent reference to be able to store the new pointer value in case of + reallocation. */ + bool maybe_reallocatable = true; + + while (true) + { + if (!maybe_reallocatable + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (data_ref))) + saveable_ref = data_ref; + + if (TREE_CODE (data_ref) == INDIRECT_REF) + { + next_ref = TREE_OPERAND (data_ref, 0); + + if (!maybe_reallocatable) + { + if (saveable_ref != NULL_TREE && saveable_ref != data_ref) + { + /* A reference worth saving has been seen, and now the pointer + to the current reference is also worth saving. If the + previous reference to save wasn't the current one, do save + it now. Otherwise drop it as we prefer saving the + pointer. */ + save_ref (accumulated_code, saveable_ref, replacement_roots); + } + + /* Don't evaluate the pointer to a variable yet; do it only if the + variable would be significantly more simple than the reference + it replaces. That is if the reference contains anything + different from NOPs, COMPONENTs and DECLs. */ + saveable_ref = next_ref; + } + } + else if (TREE_CODE (data_ref) == COMPONENT_REF) + { + maybe_reallocatable = false; + next_ref = TREE_OPERAND (data_ref, 0); + } + else if (TREE_CODE (data_ref) == NOP_EXPR) + next_ref = TREE_OPERAND (data_ref, 0); + else + { + if (DECL_P (data_ref)) + break; + + if (TREE_CODE (data_ref) == ARRAY_REF) + { + maybe_reallocatable = false; + next_ref = TREE_OPERAND (data_ref, 0); + } + + if (saveable_ref != NULL_TREE) + /* We have seen a reference worth saving. Do it now. */ + save_ref (accumulated_code, saveable_ref, replacement_roots); + + if (TREE_CODE (data_ref) != ARRAY_REF) + break; + } + + data_ref = next_ref; + } + + *desc_ptr = value; + gfc_add_expr_to_block (block, accumulated_code); +} + + /* Translate expressions for the descriptor and data pointer of a SS. */ /*GCC ARRAYS*/ @@ -3438,7 +3633,7 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base) se.descriptor_only = 1; gfc_conv_expr_lhs (&se, ss_info->expr); gfc_add_block_to_block (block, &se.pre); - info->descriptor = se.expr; + set_factored_descriptor_value (&info->descriptor, se.expr, block); ss_info->string_length = se.string_length; ss_info->class_container = se.class_container; @@ -3464,17 +3659,14 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base) Otherwise we must evaluate it now to avoid breaking dependency analysis by pulling the expressions for elemental array indices inside the loop. */ - if (!(DECL_P (tmp) - || (TREE_CODE (tmp) == ADDR_EXPR - && DECL_P (TREE_OPERAND (tmp, 0))) - || (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) - && TREE_CODE (se.expr) == COMPONENT_REF - && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (se.expr, 0)))))) + if (save_descriptor_data (se.expr, tmp) && !ss->is_alloc_lhs) tmp = gfc_evaluate_now (tmp, block); info->data = tmp; tmp = gfc_conv_array_offset (se.expr); - info->offset = gfc_evaluate_now (tmp, block); + if (!ss->is_alloc_lhs) + tmp = gfc_evaluate_now (tmp, block); + info->offset = tmp; /* Make absolutely sure that the saved_offset is indeed saved so that the variable is still accessible after the loops @@ -4767,13 +4959,12 @@ gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body) static void evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values, - tree desc, int dim, bool lbound, bool deferred) + tree desc, int dim, bool lbound, bool deferred, bool save_value) { gfc_se se; gfc_expr * input_val = values[dim]; tree *output = &bounds[dim]; - if (input_val) { /* Specified section bound. */ @@ -4799,7 +4990,8 @@ evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values, *output = lbound ? gfc_conv_array_lbound (desc, dim) : gfc_conv_array_ubound (desc, dim); } - *output = gfc_evaluate_now (*output, block); + if (save_value) + *output = gfc_evaluate_now (*output, block); } @@ -4832,18 +5024,18 @@ gfc_conv_section_startstride (stmtblock_t * block, gfc_ss * ss, int dim) || ar->dimen_type[dim] == DIMEN_THIS_IMAGE); desc = info->descriptor; stride = ar->stride[dim]; - + bool save_value = !ss->is_alloc_lhs; /* Calculate the start of the range. For vector subscripts this will be the range of the vector. */ evaluate_bound (block, info->start, ar->start, desc, dim, true, - ar->as->type == AS_DEFERRED); + ar->as->type == AS_DEFERRED, save_value); /* Similarly calculate the end. Although this is not used in the scalarizer, it is needed when checking bounds and where the end is an expression with side-effects. */ evaluate_bound (block, info->end, ar->end, desc, dim, false, - ar->as->type == AS_DEFERRED); + ar->as->type == AS_DEFERRED, save_value); /* Calculate the stride. */ @@ -4854,7 +5046,11 @@ gfc_conv_section_startstride (stmtblock_t * block, gfc_ss * ss, int dim) gfc_init_se (&se, NULL); gfc_conv_expr_type (&se, stride, gfc_array_index_type); gfc_add_block_to_block (block, &se.pre); - info->stride[dim] = gfc_evaluate_now (se.expr, block); + tree value = se.expr; + if (save_value) + info->stride[dim] = gfc_evaluate_now (value, block); + else + info->stride[dim] = value; } } @@ -5203,7 +5399,8 @@ done: int dim = ss->dim[n]; info->start[dim] = gfc_index_zero_node; - info->end[dim] = gfc_index_zero_node; + if (ss_info->type != GFC_SS_FUNCTION) + info->end[dim] = gfc_index_zero_node; info->stride[dim] = gfc_index_one_node; } break; @@ -5888,6 +6085,46 @@ set_loop_bounds (gfc_loopinfo *loop) } +/* Last attempt to set the loop bounds, in case they depend on an allocatable + function result. */ + +static void +late_set_loop_bounds (gfc_loopinfo *loop) +{ + int n, dim; + gfc_array_info *info; + gfc_ss **loopspec; + + loopspec = loop->specloop; + + for (n = 0; n < loop->dimen; n++) + { + /* Set the extents of this range. */ + if (loop->from[n] == NULL_TREE + || loop->to[n] == NULL_TREE) + { + /* We should have found the scalarization loop specifier. If not, + that's bad news. */ + gcc_assert (loopspec[n]); + + info = &loopspec[n]->info->data.array; + dim = loopspec[n]->dim[n]; + + if (loopspec[n]->info->type == GFC_SS_FUNCTION + && info->start[dim] + && info->end[dim]) + { + loop->from[n] = info->start[dim]; + loop->to[n] = info->end[dim]; + } + } + } + + for (loop = loop->nested; loop; loop = loop->next) + late_set_loop_bounds (loop); +} + + /* Initialize the scalarization loop. Creates the loop variables. Determines the range of the loop variables. Creates a temporary if required. Also generates code for scalar expressions which have been @@ -5906,6 +6143,8 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) allocating the temporary. */ gfc_add_loop_ss_code (loop, loop->ss, false, where); + late_set_loop_bounds (loop); + tmp_ss = loop->temp_ss; /* If we want a temporary then create it. */ if (tmp_ss != NULL) @@ -5962,9 +6201,11 @@ gfc_set_delta (gfc_loopinfo *loop) gfc_ss_type ss_type; ss_type = ss->info->type; - if (ss_type != GFC_SS_SECTION - && ss_type != GFC_SS_COMPONENT - && ss_type != GFC_SS_CONSTRUCTOR) + if (!(ss_type == GFC_SS_SECTION + || ss_type == GFC_SS_COMPONENT + || ss_type == GFC_SS_CONSTRUCTOR + || (ss_type == GFC_SS_FUNCTION + && gfc_is_class_array_function (ss->info->expr)))) continue; info = &ss->info->data.array; @@ -5989,7 +6230,10 @@ gfc_set_delta (gfc_loopinfo *loop) gfc_array_index_type, info->start[dim], tmp); - info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre); + if (ss->is_alloc_lhs) + info->delta[dim] = tmp; + else + info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre); } } } @@ -6113,8 +6357,8 @@ static tree gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock, stmtblock_t * descriptor_block, tree * overflow, - tree expr3_elem_size, tree *nelems, gfc_expr *expr3, - tree expr3_desc, bool e3_has_nodescriptor, gfc_expr *expr, + tree expr3_elem_size, gfc_expr *expr3, tree expr3_desc, + bool e3_has_nodescriptor, gfc_expr *expr, tree *element_size, bool explicit_ts) { tree type; @@ -6390,7 +6634,6 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, if (rank == 0) return *element_size; - *nelems = gfc_evaluate_now (stride, pblock); stride = fold_convert (size_type_node, stride); /* First check for overflow. Since an array of type character can @@ -6479,9 +6722,8 @@ retrieve_last_ref (gfc_ref **ref_in, gfc_ref **prev_ref_in) bool gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, tree errlen, tree label_finish, tree expr3_elem_size, - tree *nelems, gfc_expr *expr3, tree e3_arr_desc, - bool e3_has_nodescriptor, gfc_omp_namelist *omp_alloc, - bool explicit_ts) + gfc_expr *expr3, tree e3_arr_desc, bool e3_has_nodescriptor, + gfc_omp_namelist *omp_alloc, bool explicit_ts) { tree tmp; tree pointer; @@ -6612,7 +6854,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, coarray ? ref->u.ar.as->corank : 0, &offset, lower, upper, &se->pre, &set_descriptor_block, &overflow, - expr3_elem_size, nelems, expr3, e3_arr_desc, + expr3_elem_size, expr3, e3_arr_desc, e3_has_nodescriptor, expr, &element_size, explicit_ts); @@ -6777,8 +7019,6 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, else gfc_add_expr_to_block (&se->pre, set_descriptor); - expr->symtree->n.sym->allocated_in_scope = 1; - return true; } @@ -8258,14 +8498,6 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) else gcc_assert (se->ss == ss); - if (!is_pointer_array (se->expr)) - { - tmp = gfc_get_element_type (TREE_TYPE (se->expr)); - tmp = fold_convert (gfc_array_index_type, - size_in_bytes (tmp)); - gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp); - } - se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); gfc_conv_expr (se, expr); @@ -8468,7 +8700,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) gcc_assert (n == codim - 1); evaluate_bound (&loop.pre, info->start, ar->start, info->descriptor, n + ndim, true, - ar->as->type == AS_DEFERRED); + ar->as->type == AS_DEFERRED, true); loop.from[n + loop.dimen] = info->start[n + ndim]; } else @@ -8680,6 +8912,19 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) gfc_rank_cst[dim], stride); } + /* For deferred-length character we need to take the dynamic length + into account for the dataptr offset. */ + if (expr->ts.type == BT_CHARACTER + && expr->ts.deferred + && expr->ts.u.cl->backend_decl + && VAR_P (expr->ts.u.cl->backend_decl)) + { + tree base_type = TREE_TYPE (base); + base = fold_build2_loc (input_location, MULT_EXPR, base_type, base, + fold_convert (base_type, + expr->ts.u.cl->backend_decl)); + } + for (n = loop.dimen; n < loop.dimen + codim; n++) { from = loop.from[n]; @@ -9201,6 +9446,15 @@ gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, bool g77, gfc_add_expr_to_block (&se->pre, tmp); } + else if (pass_optional && full_array_var && sym->as && sym->as->rank != 0) + { + /* Perform calculation of bounds and strides of optional array dummy + only if the argument is present. */ + tmp = build3_v (COND_EXPR, gfc_conv_expr_present (sym), + gfc_finish_block (&se->pre), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&se->pre, tmp); + } } /* Deallocate the allocatable components of structures that are @@ -9337,9 +9591,8 @@ gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, bool g77, new_field = gfc_conv_descriptor_dtype (new_desc); gfc_add_modify (&se->pre, new_field, old_field); - old_field = gfc_conv_descriptor_offset (old_desc); - new_field = gfc_conv_descriptor_offset (new_desc); - gfc_add_modify (&se->pre, new_field, old_field); + old_field = gfc_conv_descriptor_offset_get (old_desc); + gfc_conv_descriptor_offset_set (&se->pre, new_desc, old_field); for (int i = 0; i < expr->rank; i++) { @@ -10479,6 +10732,15 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, cdecl, NULL_TREE); dcmp = fold_convert (TREE_TYPE (comp), dcmp); + if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pdt_type + && !c->attr.allocatable) + { + tmp = gfc_copy_alloc_comp (c->ts.u.derived, comp, dcmp, + 0, 0); + gfc_add_expr_to_block (&fnblock, tmp); + continue; + } + if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable) { tree ftn_tree; @@ -10598,7 +10860,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, false, false, size, NULL_TREE); gfc_add_expr_to_block (&fnblock, tmp); } - else if (c->attr.pdt_array) + else if (c->attr.pdt_array + && !c->attr.allocatable && !c->attr.pointer) { tmp = duplicate_allocatable (dcmp, comp, ctype, c->as ? c->as->rank : 0, @@ -10662,9 +10925,23 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, if (c_expr) { gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp)); + gfc_add_block_to_block (&fnblock, &tse.pre); gfc_add_modify (&fnblock, comp, tse.expr); + gfc_add_block_to_block (&fnblock, &tse.post); } } + else if (c->initializer && !c->attr.pdt_string && !c->attr.pdt_array + && !c->as && !(c->ts.type == BT_DERIVED + && c->ts.u.derived->attr.pdt_type)) /* Take care of arrays. */ + { + gfc_se tse; + gfc_expr *c_expr; + c_expr = c->initializer; + gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp)); + gfc_add_block_to_block (&fnblock, &tse.pre); + gfc_add_modify (&fnblock, comp, tse.expr); + gfc_add_block_to_block (&fnblock, &tse.post); + } if (c->attr.pdt_string) { @@ -10683,7 +10960,9 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, strlen = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (strlen), decl, strlen, NULL_TREE); + gfc_add_block_to_block (&fnblock, &tse.pre); gfc_add_modify (&fnblock, strlen, tse.expr); + gfc_add_block_to_block (&fnblock, &tse.post); c->ts.u.cl->backend_decl = strlen; } gfc_free_expr (e); @@ -10730,17 +11009,21 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, gfc_conv_expr_type (&tse, e, gfc_array_index_type); gfc_free_expr (e); lower = tse.expr; + gfc_add_block_to_block (&fnblock, &tse.pre); gfc_conv_descriptor_lbound_set (&fnblock, comp, gfc_rank_cst[i], lower); + gfc_add_block_to_block (&fnblock, &tse.post); e = gfc_copy_expr (c->as->upper[i]); gfc_insert_parameter_exprs (e, pdt_param_list); gfc_conv_expr_type (&tse, e, gfc_array_index_type); gfc_free_expr (e); upper = tse.expr; + gfc_add_block_to_block (&fnblock, &tse.pre); gfc_conv_descriptor_ubound_set (&fnblock, comp, gfc_rank_cst[i], upper); + gfc_add_block_to_block (&fnblock, &tse.post); gfc_conv_descriptor_stride_set (&fnblock, comp, gfc_rank_cst[i], size); @@ -10801,17 +11084,15 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, && c->ts.u.derived && c->ts.u.derived->attr.pdt_type && !(c->attr.pointer || c->attr.allocatable)) { - bool is_deferred = false; gfc_actual_arglist *tail = c->param_list; for (; tail; tail = tail->next) - if (!tail->expr) - is_deferred = true; + if (tail->expr) + gfc_insert_parameter_exprs (tail->expr, pdt_param_list); - tail = is_deferred ? pdt_param_list : c->param_list; tmp = gfc_allocate_pdt_comp (c->ts.u.derived, comp, c->as ? c->as->rank : 0, - tail); + c->param_list); gfc_add_expr_to_block (&fnblock, tmp); } @@ -10897,7 +11178,11 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, comp = gfc_class_data_get (comp); /* Recurse in to PDT components. */ - if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) + if (((c->ts.type == BT_DERIVED + && !c->attr.allocatable && !c->attr.pointer) + || (c->ts.type == BT_CLASS + && !CLASS_DATA (c)->attr.allocatable + && !CLASS_DATA (c)->attr.pointer)) && c->ts.u.derived && c->ts.u.derived->attr.pdt_type) { tmp = gfc_check_pdt_dummy (c->ts.u.derived, comp, @@ -11100,9 +11385,27 @@ gfc_allocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank, /* Recursively traverse an object of parameterized derived type, generating code to deallocate parameterized components. */ +static bool +has_parameterized_comps (gfc_symbol * der_type) +{ + /* A type without parameterized components causes gimplifier problems. */ + bool parameterized_comps = false; + for (gfc_component *c = der_type->components; c; c = c->next) + if (c->attr.pdt_array || c->attr.pdt_string) + parameterized_comps = true; + else if (c->ts.type == BT_DERIVED + && c->ts.u.derived->attr.pdt_type + && strcmp (der_type->name, c->ts.u.derived->name)) + parameterized_comps = has_parameterized_comps (c->ts.u.derived); + return parameterized_comps; +} + tree gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank) { + if (!has_parameterized_comps (der_type)) + return NULL_TREE; + return structure_alloc_comps (der_type, decl, NULL_TREE, rank, DEALLOCATE_PDT_COMP, 0, NULL); } @@ -11204,6 +11507,9 @@ gfc_is_reallocatable_lhs (gfc_expr *expr) gfc_ref * ref; gfc_symbol *sym; + if (!flag_realloc_lhs) + return false; + if (!expr->ref) return false; @@ -11328,6 +11634,55 @@ concat_str_length (gfc_expr* expr) } +/* Among the scalarization chain of LOOP, find the element associated with an + allocatable array on the lhs of an assignment and evaluate its fields + (bounds, offset, etc) to new variables, putting the new code in BLOCK. This + function is to be called after putting the reallocation code in BLOCK and + before the beginning of the scalarization loop body. + + The fields to be saved are expected to hold on entry to the function + expressions referencing the array descriptor. Especially the expressions + shouldn't be already temporary variable references as the value saved before + reallocation would be incorrect after reallocation. + At the end of the function, the expressions have been replaced with variable + references. */ + +static void +update_reallocated_descriptor (stmtblock_t *block, gfc_loopinfo *loop) +{ + for (gfc_ss *s = loop->ss; s != gfc_ss_terminator; s = s->loop_chain) + { + if (!s->is_alloc_lhs) + continue; + + gcc_assert (s->info->type == GFC_SS_SECTION); + gfc_array_info *info = &s->info->data.array; + +#define SAVE_VALUE(value) \ + do \ + { \ + value = gfc_evaluate_now (value, block); \ + } \ + while (0) + + if (save_descriptor_data (info->descriptor, info->data)) + SAVE_VALUE (info->data); + SAVE_VALUE (info->offset); + info->saved_offset = info->offset; + for (int i = 0; i < s->dimen; i++) + { + int dim = s->dim[i]; + SAVE_VALUE (info->start[dim]); + SAVE_VALUE (info->end[dim]); + SAVE_VALUE (info->stride[dim]); + SAVE_VALUE (info->delta[dim]); + } + +#undef SAVE_VALUE + } +} + + /* Allocate the lhs of an assignment to an allocatable array, otherwise reallocate it. */ @@ -11366,7 +11721,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, tree lbd; tree class_expr2 = NULL_TREE; int n; - int dim; gfc_array_spec * as; bool coarray = (flag_coarray == GFC_FCOARRAY_LIB && gfc_caf_attr (expr1, true).codimension); @@ -11421,14 +11775,61 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, && !expr2->value.function.isym) expr2->ts.u.cl->backend_decl = rss->info->string_length; - gfc_start_block (&fblock); - /* Since the lhs is allocatable, this must be a descriptor type. Get the data and array size. */ desc = linfo->descriptor; gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))); array1 = gfc_conv_descriptor_data_get (desc); + /* If the data is null, set the descriptor bounds and offset. This suppresses + the maybe used uninitialized warning. Note that the always false variable + prevents this block from ever being executed, and makes sure that the + optimizers are able to remove it. Component references are not subject to + the warnings, so we don't uselessly complicate the generated code for them. + */ + for (ref = expr1->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + break; + + if (!ref) + { + stmtblock_t unalloc_init_block; + gfc_init_block (&unalloc_init_block); + tree guard = gfc_create_var (logical_type_node, "unallocated_init_guard"); + gfc_add_modify (&unalloc_init_block, guard, logical_false_node); + + gfc_start_block (&loop_pre_block); + for (n = 0; n < expr1->rank; n++) + { + gfc_conv_descriptor_lbound_set (&loop_pre_block, desc, + gfc_rank_cst[n], + gfc_index_one_node); + gfc_conv_descriptor_ubound_set (&loop_pre_block, desc, + gfc_rank_cst[n], + gfc_index_zero_node); + gfc_conv_descriptor_stride_set (&loop_pre_block, desc, + gfc_rank_cst[n], + gfc_index_zero_node); + } + + gfc_conv_descriptor_offset_set (&loop_pre_block, desc, + gfc_index_zero_node); + + tmp = fold_build2_loc (input_location, EQ_EXPR, + logical_type_node, array1, + build_int_cst (TREE_TYPE (array1), 0)); + tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + logical_type_node, tmp, guard); + tmp = build3_v (COND_EXPR, tmp, + gfc_finish_block (&loop_pre_block), + build_empty_stmt (input_location)); + gfc_prepend_expr_to_block (&loop->pre, tmp); + gfc_prepend_expr_to_block (&loop->pre, + gfc_finish_block (&unalloc_init_block)); + } + + gfc_start_block (&fblock); + if (expr2) desc2 = rss->info->data.array.descriptor; else @@ -11541,45 +11942,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, array1, build_int_cst (TREE_TYPE (array1), 0)); cond_null= gfc_evaluate_now (cond_null, &fblock); - /* If the data is null, set the descriptor bounds and offset. This suppresses - the maybe used uninitialized warning and forces the use of malloc because - the size is zero in all dimensions. Note that this block is only executed - if the lhs is unallocated and is only applied once in any namespace. - Component references are not subject to the warnings. */ - for (ref = expr1->ref; ref; ref = ref->next) - if (ref->type == REF_COMPONENT) - break; - - if (!expr1->symtree->n.sym->allocated_in_scope && !ref) - { - gfc_start_block (&loop_pre_block); - for (n = 0; n < expr1->rank; n++) - { - gfc_conv_descriptor_lbound_set (&loop_pre_block, desc, - gfc_rank_cst[n], - gfc_index_one_node); - gfc_conv_descriptor_ubound_set (&loop_pre_block, desc, - gfc_rank_cst[n], - gfc_index_zero_node); - gfc_conv_descriptor_stride_set (&loop_pre_block, desc, - gfc_rank_cst[n], - gfc_index_zero_node); - } - - tmp = gfc_conv_descriptor_offset (desc); - gfc_add_modify (&loop_pre_block, tmp, gfc_index_zero_node); - - tmp = fold_build2_loc (input_location, EQ_EXPR, - logical_type_node, array1, - build_int_cst (TREE_TYPE (array1), 0)); - tmp = build3_v (COND_EXPR, tmp, - gfc_finish_block (&loop_pre_block), - build_empty_stmt (input_location)); - gfc_prepend_expr_to_block (&loop->pre, tmp); - - expr1->symtree->n.sym->allocated_in_scope = 1; - } - tmp = build3_v (COND_EXPR, cond_null, build1_v (GOTO_EXPR, jump_label1), build_empty_stmt (input_location)); @@ -11734,21 +12096,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, running offset. Use the saved_offset instead. */ tmp = gfc_conv_descriptor_offset (desc); gfc_add_modify (&fblock, tmp, offset); - if (linfo->saved_offset - && VAR_P (linfo->saved_offset)) - gfc_add_modify (&fblock, linfo->saved_offset, tmp); - - /* Now set the deltas for the lhs. */ - for (n = 0; n < expr1->rank; n++) - { - tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]); - dim = lss->dim[n]; - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, tmp, - loop->from[dim]); - if (linfo->delta[dim] && VAR_P (linfo->delta[dim])) - gfc_add_modify (&fblock, linfo->delta[dim], tmp); - } /* Take into account _len of unlimited polymorphic entities, so that span for array descriptors and allocation sizes are computed correctly. */ @@ -11970,18 +12317,18 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, tmp = build3_v (COND_EXPR, cond_null, alloc_expr, realloc_expr); gfc_add_expr_to_block (&fblock, tmp); - /* Make sure that the scalarizer data pointer is updated. */ - if (linfo->data && VAR_P (linfo->data)) - { - tmp = gfc_conv_descriptor_data_get (desc); - gfc_add_modify (&fblock, linfo->data, tmp); - } - /* Add the label for same shape lhs and rhs. */ tmp = build1_v (LABEL_EXPR, jump_label2); gfc_add_expr_to_block (&fblock, tmp); - return gfc_finish_block (&fblock); + tree realloc_code = gfc_finish_block (&fblock); + + stmtblock_t result_block; + gfc_init_block (&result_block); + gfc_add_expr_to_block (&result_block, realloc_code); + update_reallocated_descriptor (&result_block, loop); + + return gfc_finish_block (&result_block); } @@ -12067,8 +12414,16 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) && !INTEGER_CST_P (sym->ts.u.cl->backend_decl)) { if (sym->ts.deferred && !sym->ts.u.cl->length && !sym->attr.dummy) - gfc_add_modify (&init, sym->ts.u.cl->backend_decl, - build_zero_cst (TREE_TYPE (sym->ts.u.cl->backend_decl))); + { + tree len_expr = sym->ts.u.cl->backend_decl; + tree init_val = build_zero_cst (TREE_TYPE (len_expr)); + if (VAR_P (len_expr) + && sym->attr.save + && !DECL_INITIAL (len_expr)) + DECL_INITIAL (len_expr) = init_val; + else + gfc_add_modify (&init, len_expr, init_val); + } gfc_conv_string_length (sym->ts.u.cl, NULL, &init); gfc_trans_vla_type_sizes (sym, &init); @@ -12410,6 +12765,15 @@ gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr) return head2; } +static gfc_ss * +gfc_walk_conditional_expr (gfc_ss *ss, gfc_expr *expr) +{ + gfc_ss *head; + + head = gfc_walk_subexpr (ss, expr->value.conditional.true_expr); + head = gfc_walk_subexpr (head, expr->value.conditional.false_expr); + return head; +} /* Reverse a SS chain. */ @@ -12682,6 +13046,10 @@ gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr) head = gfc_walk_op_expr (ss, expr); return head; + case EXPR_CONDITIONAL: + head = gfc_walk_conditional_expr (ss, expr); + return head; + case EXPR_FUNCTION: head = gfc_walk_function_expr (ss, expr); return head; diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 1bb3294..345a975 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -20,9 +20,8 @@ along with GCC; see the file COPYING3. If not see /* Generate code to initialize and allocate an array. Statements are added to se, which should contain an expression for the array descriptor. */ -bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree, - tree, tree *, gfc_expr *, tree, bool, - gfc_omp_namelist *, bool); +bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree, tree, + gfc_expr *, tree, bool, gfc_omp_namelist *, bool); /* Allow the bounds of a loop to be set from a callee's array spec. */ void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *, @@ -174,7 +173,6 @@ void gfc_get_descriptor_offsets_for_info (const_tree, tree *, tree *, tree *, tr tree *, tree *, tree *, tree *); 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_span_get (tree); tree gfc_conv_descriptor_dtype (tree); diff --git a/gcc/fortran/trans-common.cc b/gcc/fortran/trans-common.cc index 2db50da..135d304 100644 --- a/gcc/fortran/trans-common.cc +++ b/gcc/fortran/trans-common.cc @@ -469,9 +469,6 @@ build_common_decl (gfc_common_head *com, tree union_type, bool is_init) gfc_set_decl_location (decl, &com->where); - if (com->threadprivate) - set_decl_tls_model (decl, decl_default_tls_model (decl)); - if (com->omp_device_type != OMP_DEVICE_TYPE_UNSET) { tree c = build_omp_clause (UNKNOWN_LOCATION, OMP_CLAUSE_DEVICE_TYPE); @@ -536,6 +533,10 @@ build_common_decl (gfc_common_head *com, tree union_type, bool is_init) DECL_COMMON (decl) = 0; DECL_DEFER_OUTPUT (decl) = 0; } + + if (com->threadprivate) + set_decl_tls_model (decl, decl_default_tls_model (decl)); + return decl; } diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index 43bd7be..c31c756 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -197,6 +197,7 @@ tree gfor_fndecl_string_scan; tree gfor_fndecl_string_verify; tree gfor_fndecl_string_trim; tree gfor_fndecl_string_minmax; +tree gfor_fndecl_string_split; tree gfor_fndecl_adjustl; tree gfor_fndecl_adjustr; tree gfor_fndecl_select_string; @@ -208,6 +209,7 @@ tree gfor_fndecl_string_scan_char4; tree gfor_fndecl_string_verify_char4; tree gfor_fndecl_string_trim_char4; tree gfor_fndecl_string_minmax_char4; +tree gfor_fndecl_string_split_char4; tree gfor_fndecl_adjustl_char4; tree gfor_fndecl_adjustr_char4; tree gfor_fndecl_select_string_char4; @@ -223,6 +225,12 @@ tree gfor_fndecl_iargc; tree gfor_fndecl_kill; tree gfor_fndecl_kill_sub; tree gfor_fndecl_is_contiguous0; +tree gfor_fndecl_fstat_i4_sub; +tree gfor_fndecl_fstat_i8_sub; +tree gfor_fndecl_lstat_i4_sub; +tree gfor_fndecl_lstat_i8_sub; +tree gfor_fndecl_stat_i4_sub; +tree gfor_fndecl_stat_i8_sub; /* Intrinsic functions implemented in Fortran. */ @@ -821,11 +829,6 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym) } } - /* Handle threadprivate variables. */ - if (sym->attr.threadprivate - && (TREE_STATIC (decl) || DECL_EXTERNAL (decl))) - set_decl_tls_model (decl, decl_default_tls_model (decl)); - if (sym->attr.omp_allocate && TREE_STATIC (decl)) { struct gfc_omp_namelist *n; @@ -844,6 +847,11 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym) if (sym->attr.ext_attr & (1 << EXT_ATTR_WEAK)) declare_weak (decl); + /* Handle threadprivate variables. */ + if (sym->attr.threadprivate + && (TREE_STATIC (decl) || DECL_EXTERNAL (decl))) + set_decl_tls_model (decl, decl_default_tls_model (decl)); + gfc_finish_decl_attrs (decl, &sym->attr); } @@ -1680,6 +1688,11 @@ gfc_get_symbol_decl (gfc_symbol * sym) && !(sym->attr.use_assoc || sym->attr.dummy)) gfc_defer_symbol_init (sym); + if ((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_comp) + && gfc_current_ns == sym->ns + && !(sym->attr.use_assoc || sym->attr.dummy)) + gfc_defer_symbol_init (sym); + /* Dummy PDT 'len' parameters should be checked when they are explicit. */ if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) @@ -2216,13 +2229,13 @@ get_proc_pointer_decl (gfc_symbol *sym) false, true); } + add_attributes_to_decl (&decl, sym); + /* Handle threadprivate procedure pointers. */ if (sym->attr.threadprivate && (TREE_STATIC (decl) || DECL_EXTERNAL (decl))) set_decl_tls_model (decl, decl_default_tls_model (decl)); - add_attributes_to_decl (&decl, sym); - return decl; } @@ -3569,6 +3582,12 @@ gfc_build_intrinsic_function_decls (void) build_pointer_type (pchar1_type_node), integer_type_node, integer_type_node); + gfor_fndecl_string_split = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX ("string_split")), ". . R . R . . ", + gfc_charlen_type_node, 6, gfc_charlen_type_node, pchar1_type_node, + gfc_charlen_type_node, pchar1_type_node, gfc_charlen_type_node, + gfc_logical4_type_node); + gfor_fndecl_adjustl = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("adjustl")), ". W . R ", void_type_node, 3, pchar1_type_node, gfc_charlen_type_node, @@ -3641,6 +3660,12 @@ gfc_build_intrinsic_function_decls (void) build_pointer_type (pchar4_type_node), integer_type_node, integer_type_node); + gfor_fndecl_string_split_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX ("string_split_char4")), ". . R . R . . ", + gfc_charlen_type_node, 6, gfc_charlen_type_node, pchar4_type_node, + gfc_charlen_type_node, pchar4_type_node, gfc_charlen_type_node, + gfc_logical4_type_node); + gfor_fndecl_adjustl_char4 = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("adjustl_char4")), ". W . R ", void_type_node, 3, pchar4_type_node, gfc_charlen_type_node, @@ -3896,6 +3921,34 @@ gfc_build_intrinsic_function_decls (void) gfc_int4_type_node, 1, pvoid_type_node); DECL_PURE_P (gfor_fndecl_is_contiguous0) = 1; TREE_NOTHROW (gfor_fndecl_is_contiguous0) = 1; + + gfor_fndecl_fstat_i4_sub = gfc_build_library_function_decl ( + get_identifier (PREFIX ("fstat_i4_sub")), void_type_node, + 3, gfc_pint4_type_node, gfc_pint4_type_node, gfc_pint4_type_node); + + gfor_fndecl_fstat_i8_sub = gfc_build_library_function_decl ( + get_identifier (PREFIX ("fstat_i8_sub")), void_type_node, + 3, gfc_pint8_type_node, gfc_pint8_type_node, gfc_pint8_type_node); + + gfor_fndecl_lstat_i4_sub = gfc_build_library_function_decl ( + get_identifier (PREFIX ("lstat_i4_sub")), void_type_node, + 4, pchar_type_node, gfc_pint4_type_node, gfc_pint4_type_node, + gfc_charlen_type_node); + + gfor_fndecl_lstat_i8_sub = gfc_build_library_function_decl ( + get_identifier (PREFIX ("lstat_i8_sub")), void_type_node, + 4, pchar_type_node, gfc_pint8_type_node, gfc_pint8_type_node, + gfc_charlen_type_node); + + gfor_fndecl_stat_i4_sub = gfc_build_library_function_decl ( + get_identifier (PREFIX ("stat_i4_sub")), void_type_node, + 4, pchar_type_node, gfc_pint4_type_node, gfc_pint4_type_node, + gfc_charlen_type_node); + + gfor_fndecl_stat_i8_sub = gfc_build_library_function_decl ( + get_identifier (PREFIX ("stat_i8_sub")), void_type_node, + 4, pchar_type_node, gfc_pint8_type_node, gfc_pint8_type_node, + gfc_charlen_type_node); } @@ -4773,16 +4826,33 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) /* Nullify explicit return class arrays on entry. */ tree type; tmp = get_proc_result (proc_sym); - if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp))) - { - gfc_start_block (&init); - tmp = gfc_class_data_get (tmp); - type = TREE_TYPE (gfc_conv_descriptor_data_get (tmp)); - gfc_conv_descriptor_data_set (&init, tmp, build_int_cst (type, 0)); - gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); - } + if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp))) + { + gfc_start_block (&init); + tmp = gfc_class_data_get (tmp); + type = TREE_TYPE (gfc_conv_descriptor_data_get (tmp)); + gfc_conv_descriptor_data_set (&init, tmp, build_int_cst (type, 0)); + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); + } } + sym = (proc_sym->attr.function + && proc_sym != proc_sym->result) ? proc_sym->result : NULL; + + if (sym && !sym->attr.allocatable && !sym->attr.pointer + && sym->ts.type == BT_DERIVED + && sym->ts.u.derived + && !gfc_has_default_initializer (sym->ts.u.derived) + && sym->ts.u.derived->attr.pdt_type) + { + gfc_init_block (&tmpblock); + tmp = gfc_allocate_pdt_comp (sym->ts.u.derived, + sym->backend_decl, + sym->as ? sym->as->rank : 0, + sym->param_list); + gfc_add_expr_to_block (&tmpblock, tmp); + gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL); + } /* Initialize the INTENT(OUT) derived type dummy arguments. This should be done here so that the offsets and lbounds of arrays @@ -4856,25 +4926,28 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) if (sym->ts.type == BT_DERIVED && sym->ts.u.derived - && sym->ts.u.derived->attr.pdt_type) + && (sym->ts.u.derived->attr.pdt_type || sym->ts.u.derived->attr.pdt_comp)) { is_pdt_type = true; gfc_init_block (&tmpblock); - if (!(sym->attr.dummy - || sym->attr.pointer - || sym->attr.allocatable)) + if (!sym->attr.dummy && !sym->attr.pointer) { - tmp = gfc_allocate_pdt_comp (sym->ts.u.derived, - sym->backend_decl, - sym->as ? sym->as->rank : 0, - sym->param_list); - gfc_add_expr_to_block (&tmpblock, tmp); - if (!sym->attr.result) + if (!sym->attr.allocatable) + { + tmp = gfc_allocate_pdt_comp (sym->ts.u.derived, + sym->backend_decl, + sym->as ? sym->as->rank : 0, + sym->param_list); + gfc_add_expr_to_block (&tmpblock, tmp); + } + + if (!sym->attr.result && !sym->ts.u.derived->attr.alloc_comp) tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived, sym->backend_decl, sym->as ? sym->as->rank : 0); else tmp = NULL_TREE; + gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), tmp); } else if (sym->attr.dummy) @@ -4922,20 +4995,6 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) } } - if (sym->attr.pointer && sym->attr.dimension - && sym->attr.save == SAVE_NONE - && !sym->attr.use_assoc - && !sym->attr.host_assoc - && !sym->attr.dummy - && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl))) - { - gfc_init_block (&tmpblock); - gfc_conv_descriptor_span_set (&tmpblock, sym->backend_decl, - build_int_cst (gfc_array_index_type, 0)); - gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), - NULL_TREE); - } - if (sym->ts.type == BT_CLASS && (sym->attr.save || flag_max_stack_var_size == 0) && CLASS_DATA (sym)->attr.allocatable) @@ -5134,18 +5193,31 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) se.descriptor_only = 1; gfc_conv_expr (&se, e); descriptor = se.expr; - se.expr = gfc_conv_descriptor_data_addr (se.expr); - se.expr = build_fold_indirect_ref_loc (input_location, se.expr); + se.expr = gfc_conv_descriptor_data_get (se.expr); } gfc_free_expr (e); if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT) { /* Nullify when entering the scope. */ - tmp = fold_build2_loc (input_location, MODIFY_EXPR, - TREE_TYPE (se.expr), se.expr, - fold_convert (TREE_TYPE (se.expr), - null_pointer_node)); + if (sym->ts.type == BT_CLASS + && (CLASS_DATA (sym)->attr.dimension + || CLASS_DATA (sym)->attr.codimension)) + { + stmtblock_t nullify; + gfc_init_block (&nullify); + gfc_conv_descriptor_data_set (&nullify, descriptor, + null_pointer_node); + tmp = gfc_finish_block (&nullify); + } + else + { + tree typed_null = fold_convert (TREE_TYPE (se.expr), + null_pointer_node); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + TREE_TYPE (se.expr), se.expr, + typed_null); + } if (sym->attr.optional) { tree present = gfc_conv_expr_present (sym); @@ -5326,7 +5398,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) continue; /* 'omp allocate( {purpose: allocator, value: align}, {purpose: init-stmtlist, value: cleanup-stmtlist}, - {purpose: size-var, value: last-size-expr}} + {purpose: size-var, value: last-size-expr} ) where init-stmt/cleanup-stmt is the STATEMENT list to find the try-final block; last-size-expr is to find the location after which to add the code and 'size-var' is for the proper size, cf. diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 8d9448e..271d263 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -714,6 +714,8 @@ gfc_get_class_from_expr (tree expr) { tree tmp; tree type; + bool array_descr_found = false; + bool comp_after_descr_found = false; for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0)) { @@ -725,6 +727,8 @@ gfc_get_class_from_expr (tree expr) { if (GFC_CLASS_TYPE_P (type)) return tmp; + if (GFC_DESCRIPTOR_TYPE_P (type)) + array_descr_found = true; if (type != TYPE_CANONICAL (type)) type = TYPE_CANONICAL (type); else @@ -732,6 +736,23 @@ gfc_get_class_from_expr (tree expr) } if (VAR_P (tmp) || TREE_CODE (tmp) == PARM_DECL) break; + + /* Avoid walking up the reference chain too far. For class arrays, the + array descriptor is a direct component (through a pointer) of the class + container. So there is exactly one COMPONENT_REF between a class + container and its child array descriptor. After seeing an array + descriptor, we can give up on the second COMPONENT_REF we see, if no + class container was found until that point. */ + if (array_descr_found) + { + if (comp_after_descr_found) + { + if (TREE_CODE (tmp) == COMPONENT_REF) + return NULL_TREE; + } + else if (TREE_CODE (tmp) == COMPONENT_REF) + comp_after_descr_found = true; + } } if (POINTER_TYPE_P (TREE_TYPE (tmp))) @@ -1147,7 +1168,6 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e, else { parmse->ss = ss; - parmse->use_offset = 1; gfc_conv_expr_descriptor (parmse, e); /* Array references with vector subscripts and non-variable expressions @@ -2782,9 +2802,11 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, start.expr = gfc_evaluate_now (start.expr, &se->pre); /* Change the start of the string. */ - if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE - || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE) - && TYPE_STRING_FLAG (TREE_TYPE (se->expr))) + if (((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE + || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE) + && TYPE_STRING_FLAG (TREE_TYPE (se->expr))) + || (POINTER_TYPE_P (TREE_TYPE (se->expr)) + && TREE_CODE (TREE_TYPE (TREE_TYPE (se->expr))) != ARRAY_TYPE)) tmp = se->expr; else tmp = build_fold_indirect_ref_loc (input_location, @@ -2795,6 +2817,15 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, tmp = gfc_build_array_ref (tmp, start.expr, NULL_TREE, true); se->expr = gfc_build_addr_expr (type, tmp); } + else if (POINTER_TYPE_P (TREE_TYPE (tmp))) + { + tree diff; + diff = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, start.expr, + build_one_cst (gfc_charlen_type_node)); + diff = fold_convert (size_type_node, diff); + se->expr + = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (tmp), tmp, diff); + } } /* Length = end + 1 - start. */ @@ -4337,6 +4368,58 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr) gfc_add_block_to_block (&se->post, &lse.post); } +static void +gfc_conv_conditional_expr (gfc_se *se, gfc_expr *expr) +{ + gfc_se cond_se, true_se, false_se; + tree condition, true_val, false_val; + tree type; + + gfc_init_se (&cond_se, se); + gfc_init_se (&true_se, se); + gfc_init_se (&false_se, se); + + gfc_conv_expr (&cond_se, expr->value.conditional.condition); + gfc_add_block_to_block (&se->pre, &cond_se.pre); + condition = gfc_evaluate_now (cond_se.expr, &se->pre); + + true_se.want_pointer = se->want_pointer; + gfc_conv_expr (&true_se, expr->value.conditional.true_expr); + true_val = true_se.expr; + false_se.want_pointer = se->want_pointer; + gfc_conv_expr (&false_se, expr->value.conditional.false_expr); + false_val = false_se.expr; + + if (true_se.pre.head != NULL_TREE || false_se.pre.head != NULL_TREE) + gfc_add_expr_to_block ( + &se->pre, + fold_build3_loc (input_location, COND_EXPR, void_type_node, condition, + true_se.pre.head != NULL_TREE + ? gfc_finish_block (&true_se.pre) + : build_empty_stmt (input_location), + false_se.pre.head != NULL_TREE + ? gfc_finish_block (&false_se.pre) + : build_empty_stmt (input_location))); + + if (true_se.post.head != NULL_TREE || false_se.post.head != NULL_TREE) + gfc_add_expr_to_block ( + &se->post, + fold_build3_loc (input_location, COND_EXPR, void_type_node, condition, + true_se.post.head != NULL_TREE + ? gfc_finish_block (&true_se.post) + : build_empty_stmt (input_location), + false_se.post.head != NULL_TREE + ? gfc_finish_block (&false_se.post) + : build_empty_stmt (input_location))); + + type = gfc_typenode_for_spec (&expr->ts); + if (se->want_pointer) + type = build_pointer_type (type); + + se->expr = fold_build3_loc (input_location, COND_EXPR, type, condition, + true_val, false_val); +} + /* If a string's length is one, we convert it to a single character. */ tree @@ -4625,6 +4708,16 @@ get_builtin_fn (gfc_symbol * sym) && !strcmp (sym->name, "omp_is_initial_device")) return builtin_decl_explicit (BUILT_IN_OMP_IS_INITIAL_DEVICE); + if (!gfc_option.disable_omp_get_initial_device + && flag_openmp && sym->attr.function && sym->ts.type == BT_INTEGER + && !strcmp (sym->name, "omp_get_initial_device")) + return builtin_decl_explicit (BUILT_IN_OMP_GET_INITIAL_DEVICE); + + if (!gfc_option.disable_omp_get_num_devices + && flag_openmp && sym->attr.function && sym->ts.type == BT_INTEGER + && !strcmp (sym->name, "omp_get_num_devices")) + return builtin_decl_explicit (BUILT_IN_OMP_GET_NUM_DEVICES); + if (!gfc_option.disable_acc_on_device && flag_openacc && sym->attr.function && sym->ts.type == BT_LOGICAL && !strcmp (sym->name, "acc_on_device_h")) @@ -5276,6 +5369,13 @@ gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping, gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2); break; + case EXPR_CONDITIONAL: + gfc_apply_interface_mapping_to_expr (mapping, + expr->value.conditional.true_expr); + gfc_apply_interface_mapping_to_expr (mapping, + expr->value.conditional.false_expr); + break; + case EXPR_FUNCTION: for (actual = expr->value.function.actual; actual; actual = actual->next) gfc_apply_interface_mapping_to_expr (mapping, actual->expr); @@ -5443,16 +5543,6 @@ gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77, /* Translate the expression. */ gfc_conv_expr (&rse, expr); - /* Reset the offset for the function call since the loop - is zero based on the data pointer. Note that the temp - comes first in the loop chain since it is added second. */ - if (gfc_is_class_array_function (expr)) - { - tmp = loop.ss->loop_chain->info->data.array.descriptor; - gfc_conv_descriptor_offset_set (&loop.pre, tmp, - gfc_index_zero_node); - } - gfc_conv_tmp_array_ref (&lse); if (intent != INTENT_OUT) @@ -6479,6 +6569,20 @@ conv_cond_temp (gfc_se * parmse, gfc_expr * e, tree cond) } +/* Returns true if the type specified in TS is a character type whose length + is constant. Otherwise returns false. */ + +static bool +gfc_const_length_character_type_p (gfc_typespec *ts) +{ + return (ts->type == BT_CHARACTER + && ts->u.cl + && ts->u.cl->length + && ts->u.cl->length->expr_type == EXPR_CONSTANT + && ts->u.cl->length->ts.type == BT_INTEGER); +} + + /* Helper function for the handling of (currently) scalar dummy variables with the VALUE attribute. Argument parmse should already be set up. */ static void @@ -6489,6 +6593,20 @@ conv_dummy_value (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym, gcc_assert (fsym && fsym->attr.value && !fsym->attr.dimension); + if (e && e->ts.type == BT_DERIVED && e->ts.u.derived->attr.pdt_type) + { + tmp = gfc_create_var (TREE_TYPE (parmse->expr), "PDT"); + gfc_add_modify (&parmse->pre, tmp, parmse->expr); + gfc_add_expr_to_block (&parmse->pre, + gfc_copy_alloc_comp (e->ts.u.derived, + parmse->expr, tmp, + e->rank, 0)); + parmse->expr = tmp; + tmp = gfc_deallocate_pdt_comp (e->ts.u.derived, tmp, e->rank); + gfc_add_expr_to_block (&parmse->post, tmp); + return; + } + /* Absent actual argument for optional scalar dummy. */ if ((e == NULL || e->expr_type == EXPR_NULL) && fsym->attr.optional) { @@ -6520,6 +6638,26 @@ conv_dummy_value (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym, return; } + /* Truncate a too long constant character actual argument. */ + if (gfc_const_length_character_type_p (&fsym->ts) + && e->expr_type == EXPR_CONSTANT + && mpz_cmp_ui (fsym->ts.u.cl->length->value.integer, + e->value.character.length) < 0) + { + gfc_charlen_t flen = mpz_get_ui (fsym->ts.u.cl->length->value.integer); + + /* Truncate actual string argument. */ + gfc_conv_expr (parmse, e); + parmse->expr = gfc_build_wide_string_const (e->ts.kind, flen, + e->value.character.string); + parmse->string_length = build_int_cst (gfc_charlen_type_node, flen); + + /* Indicate value,optional scalar dummy argument as present. */ + if (fsym->attr.optional) + vec_safe_push (optionalargs, boolean_true_node); + return; + } + /* gfortran argument passing conventions: actual arguments to CHARACTER(len=1),VALUE dummy arguments are actually passed by value. @@ -7510,7 +7648,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, || CLASS_DATA (fsym)->attr.codimension)) { /* Pass a class array. */ - parmse.use_offset = 1; gfc_conv_expr_descriptor (&parmse, e); bool defer_to_dealloc_blk = false; @@ -7888,21 +8025,21 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, se->ss->info->class_container = arg1_cntnr; } - if (fsym && e) + /* Obtain the character length of an assumed character length procedure + from the typespec of the actual argument. */ + if (e + && parmse.string_length == NULL_TREE + && e->ts.type == BT_PROCEDURE + && e->symtree->n.sym->ts.type == BT_CHARACTER + && e->symtree->n.sym->ts.u.cl->length != NULL + && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT) { - /* Obtain the character length of an assumed character length - length procedure from the typespec. */ - if (fsym->ts.type == BT_CHARACTER - && parmse.string_length == NULL_TREE - && e->ts.type == BT_PROCEDURE - && e->symtree->n.sym->ts.type == BT_CHARACTER - && e->symtree->n.sym->ts.u.cl->length != NULL - && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT) - { - gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl); - parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl; - } + gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl); + parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl; + } + if (fsym && e) + { /* Obtain the character length for a NULL() actual with a character MOLD argument. Otherwise substitute a suitable dummy length. Here we handle non-optional dummies of non-bind(c) procedures. */ @@ -8138,7 +8275,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, msg = xasprintf ("Pointer actual argument '%s' is not " "associated", e->symtree->n.sym->name); else if (attr.proc_pointer && !e->value.function.actual - && (fsym == NULL || !fsym_attr.proc_pointer)) + && (fsym == NULL + || (!fsym_attr.proc_pointer && !fsym_attr.optional))) msg = xasprintf ("Proc-pointer actual argument '%s' is not " "associated", e->symtree->n.sym->name); else @@ -8821,28 +8959,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr)) && expr->must_finalize) { - int n; - if (se->ss && se->ss->loop) - { - gfc_add_block_to_block (&se->ss->loop->pre, &se->pre); - se->expr = gfc_evaluate_now (se->expr, &se->ss->loop->pre); - tmp = gfc_class_data_get (se->expr); - info->descriptor = tmp; - info->data = gfc_conv_descriptor_data_get (tmp); - info->offset = gfc_conv_descriptor_offset_get (tmp); - for (n = 0; n < se->ss->loop->dimen; n++) - { - tree dim = gfc_rank_cst[n]; - se->ss->loop->to[n] = gfc_conv_descriptor_ubound_get (tmp, dim); - se->ss->loop->from[n] = gfc_conv_descriptor_lbound_get (tmp, dim); - } - } - else - { - /* TODO Eliminate the doubling of temporaries. This - one is necessary to ensure no memory leakage. */ - se->expr = gfc_evaluate_now (se->expr, &se->pre); - } + /* TODO Eliminate the doubling of temporaries. This + one is necessary to ensure no memory leakage. */ + se->expr = gfc_evaluate_now (se->expr, &se->pre); /* Finalize the result, if necessary. */ attr = expr->value.function.esym @@ -9569,8 +9688,8 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm, /* Shift the lbound and ubound of temporaries to being unity, rather than zero, based. Always calculate the offset. */ + gfc_conv_descriptor_offset_set (&block, dest, gfc_index_zero_node); offset = gfc_conv_descriptor_offset_get (dest); - gfc_add_modify (&block, offset, gfc_index_zero_node); tmp2 =gfc_create_var (gfc_array_index_type, NULL); for (n = 0; n < expr->rank; n++) @@ -10404,6 +10523,10 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr) gfc_conv_expr_op (se, expr); break; + case EXPR_CONDITIONAL: + gfc_conv_conditional_expr (se, expr); + break; + case EXPR_FUNCTION: gfc_conv_function_expr (se, expr); break; @@ -10547,6 +10670,13 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr) return; } + if (expr->expr_type == EXPR_CONDITIONAL) + { + se->want_pointer = 1; + gfc_conv_expr (se, expr); + return; + } + if (expr->expr_type == EXPR_FUNCTION && ((expr->value.function.esym && expr->value.function.esym->result @@ -11134,11 +11264,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) { rse.expr = gfc_class_data_get (rse.expr); gfc_add_modify (&lse.pre, desc, rse.expr); - /* Set the lhs span. */ - tmp = TREE_TYPE (rse.expr); - tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp)); - tmp = fold_convert (gfc_array_index_type, tmp); - gfc_conv_descriptor_span_set (&lse.pre, desc, tmp); } else { @@ -12849,16 +12974,19 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, gfc_init_se (&lse, NULL); gfc_init_se (&rse, NULL); + gfc_fix_class_refs (expr1); + + realloc_flag = flag_realloc_lhs + && gfc_is_reallocatable_lhs (expr1) + && expr2->rank + && !is_runtime_conformable (expr1, expr2); + /* Walk the lhs. */ lss = gfc_walk_expr (expr1); - if (gfc_is_reallocatable_lhs (expr1)) + if (realloc_flag) { lss->no_bounds_check = 1; - if (!(expr2->expr_type == EXPR_FUNCTION - && expr2->value.function.isym != NULL - && !(expr2->value.function.isym->elemental - || expr2->value.function.isym->conversion))) - lss->is_alloc_lhs = 1; + lss->is_alloc_lhs = 1; } else lss->no_bounds_check = expr1->no_bounds_check; @@ -12906,11 +13034,6 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, assoc_assign = is_assoc_assign (expr1, expr2); - realloc_flag = flag_realloc_lhs - && gfc_is_reallocatable_lhs (expr1) - && expr2->rank - && !is_runtime_conformable (expr1, expr2); - /* Only analyze the expressions for coarray properties, when in coarray-lib mode. Avoid false-positive uninitialized diagnostics with initializing the codimension flag unconditionally. */ @@ -12922,6 +13045,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp); } + tree reallocation = NULL_TREE; if (lss != gfc_ss_terminator) { /* The assignment needs scalarization. */ @@ -12940,8 +13064,12 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, /* Walk the rhs. */ rss = gfc_walk_expr (expr2); if (rss == gfc_ss_terminator) - /* The rhs is scalar. Add a ss for the expression. */ - rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2); + { + /* The rhs is scalar. Add a ss for the expression. */ + rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2); + lss->is_alloc_lhs = 0; + } + /* When doing a class assign, then the handle to the rhs needs to be a pointer to allow for polymorphism. */ if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2)) @@ -12990,6 +13118,15 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY; } + /* F2003: Allocate or reallocate lhs of allocatable array. */ + if (realloc_flag) + { + realloc_lhs_warning (expr1->ts.type, true, &expr1->where); + ompws_flags &= ~OMPWS_SCALARIZER_WS; + reallocation = gfc_alloc_allocatable_for_assignment (&loop, expr1, + expr2); + } + /* Start the scalarized loop body. */ gfc_start_scalarized_body (&loop, &body); } @@ -13076,26 +13213,39 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, } /* Deallocate the lhs parameterized components if required. */ - if (dealloc && expr2->expr_type == EXPR_FUNCTION - && !expr1->symtree->n.sym->attr.associate_var) + if (dealloc + && !expr1->symtree->n.sym->attr.associate_var + && ((expr1->ts.type == BT_DERIVED + && expr1->ts.u.derived + && expr1->ts.u.derived->attr.pdt_type) + || (expr1->ts.type == BT_CLASS + && CLASS_DATA (expr1)->ts.u.derived + && CLASS_DATA (expr1)->ts.u.derived->attr.pdt_type))) { - if (expr1->ts.type == BT_DERIVED - && expr1->ts.u.derived - && expr1->ts.u.derived->attr.pdt_type) + bool pdt_dep = gfc_check_dependency (expr1, expr2, true); + + tmp = lse.expr; + if (pdt_dep) { - tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, lse.expr, - expr1->rank); - gfc_add_expr_to_block (&lse.pre, tmp); + /* Create a temporary for deallocation after assignment. */ + tmp = gfc_create_var (TREE_TYPE (lse.expr), "pdt_tmp"); + gfc_add_modify (&lse.pre, tmp, lse.expr); } - else if (expr1->ts.type == BT_CLASS - && CLASS_DATA (expr1)->ts.u.derived - && CLASS_DATA (expr1)->ts.u.derived->attr.pdt_type) + + if (expr1->ts.type == BT_DERIVED) + tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, tmp, + expr1->rank); + else if (expr1->ts.type == BT_CLASS) { - tmp = gfc_class_data_get (lse.expr); + tmp = gfc_class_data_get (tmp); tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr1)->ts.u.derived, tmp, expr1->rank); - gfc_add_expr_to_block (&lse.pre, tmp); } + + if (tmp && pdt_dep) + gfc_add_expr_to_block (&rse.post, tmp); + else if (tmp) + gfc_add_expr_to_block (&lse.pre, tmp); } } @@ -13298,15 +13448,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, gfc_add_expr_to_block (&body, tmp); } - /* F2003: Allocate or reallocate lhs of allocatable array. */ - if (realloc_flag) - { - realloc_lhs_warning (expr1->ts.type, true, &expr1->where); - ompws_flags &= ~OMPWS_SCALARIZER_WS; - tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2); - if (tmp != NULL_TREE) - gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp); - } + if (reallocation != NULL_TREE) + gfc_add_expr_to_block (&loop.code[loop.dimen - 1], reallocation); if (maybe_workshare) ompws_flags &= ~OMPWS_SCALARIZER_BODY; @@ -13321,6 +13464,22 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, gfc_cleanup_loop (&loop); } + /* Since parameterized components cannot have default initializers, + the default PDT constructor leaves them unallocated. Do the + allocation now. */ + if (init_flag && expr1->ts.type == BT_DERIVED + && expr1->ts.u.derived->attr.pdt_type + && !expr1->symtree->n.sym->attr.allocatable + && !expr1->symtree->n.sym->attr.dummy) + { + gfc_symbol *sym = expr1->symtree->n.sym; + tmp = gfc_allocate_pdt_comp (sym->ts.u.derived, + sym->backend_decl, + sym->as ? sym->as->rank : 0, + sym->param_list); + gfc_add_expr_to_block (&block, tmp); + } + return gfc_finish_block (&block); } @@ -13384,7 +13543,7 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, { tmp = gfc_trans_zero_assign (expr1); if (tmp) - return tmp; + return tmp; } /* Special case copying one array to another. */ @@ -13395,7 +13554,7 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, { tmp = gfc_trans_array_copy (expr1, expr2); if (tmp) - return tmp; + return tmp; } /* Special case initializing an array from a constant array constructor. */ diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index 440cbdd..d1c2a80 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -1052,7 +1052,7 @@ conv_caf_func_index (stmtblock_t *block, gfc_namespace *ns, const char *pat, index_st->n.sym->value = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, &gfc_current_locus); - mpz_init_set_si (index_st->n.sym->value->value.integer, -1); + mpz_set_si (index_st->n.sym->value->value.integer, -1); index_st->n.sym->ts.type = BT_INTEGER; index_st->n.sym->ts.kind = gfc_default_integer_kind; gfc_set_sym_referenced (index_st->n.sym); @@ -3466,6 +3466,74 @@ else return gfc_finish_block (&block); } +static tree +conv_intrinsic_split (gfc_code *code) +{ + stmtblock_t block, post_block; + gfc_se se; + gfc_expr *string_expr, *set_expr, *pos_expr, *back_expr; + tree string, string_len; + tree set, set_len; + tree pos, pos_for_call; + tree back; + tree fndecl, call; + + string_expr = code->ext.actual->expr; + set_expr = code->ext.actual->next->expr; + pos_expr = code->ext.actual->next->next->expr; + back_expr = code->ext.actual->next->next->next->expr; + + gfc_start_block (&block); + gfc_init_block (&post_block); + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, string_expr); + gfc_conv_string_parameter (&se); + gfc_add_block_to_block (&block, &se.pre); + gfc_add_block_to_block (&post_block, &se.post); + string = se.expr; + string_len = se.string_length; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, set_expr); + gfc_conv_string_parameter (&se); + gfc_add_block_to_block (&block, &se.pre); + gfc_add_block_to_block (&post_block, &se.post); + set = se.expr; + set_len = se.string_length; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, pos_expr); + gfc_add_block_to_block (&block, &se.pre); + gfc_add_block_to_block (&post_block, &se.post); + pos = se.expr; + pos_for_call = fold_convert (gfc_charlen_type_node, pos); + + if (back_expr) + { + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, back_expr); + gfc_add_block_to_block (&block, &se.pre); + gfc_add_block_to_block (&post_block, &se.post); + back = se.expr; + } + else + back = logical_false_node; + + if (string_expr->ts.kind == 1) + fndecl = gfor_fndecl_string_split; + else if (string_expr->ts.kind == 4) + fndecl = gfor_fndecl_string_split_char4; + else + gcc_unreachable (); + + call = build_call_expr_loc (input_location, fndecl, 6, string_len, string, + set_len, set, pos_for_call, back); + gfc_add_modify (&block, pos, fold_convert (TREE_TYPE (pos), call)); + + gfc_add_block_to_block (&block, &post_block); + return gfc_finish_block (&block); +} /* Return a character string containing the tty name. */ @@ -4715,22 +4783,6 @@ maybe_absent_optional_variable (gfc_expr *e) } -/* Remove unneeded kind= argument from actual argument list when the - result conversion is dealt with in a different place. */ - -static void -strip_kind_from_actual (gfc_actual_arglist * actual) -{ - for (gfc_actual_arglist *a = actual; a; a = a->next) - { - if (a && a->name && strcmp (a->name, "kind") == 0) - { - gfc_free_expr (a->expr); - a->expr = NULL; - } - } -} - /* Emit code for minloc or maxloc intrinsic. There are many different cases we need to handle. For performance reasons we sometimes create two loops instead of one, where the second one is much simpler. @@ -4925,7 +4977,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) tree b_if, b_else; tree back; gfc_loopinfo loop, *ploop; - gfc_actual_arglist *actual, *array_arg, *dim_arg, *mask_arg, *kind_arg; + gfc_actual_arglist *array_arg, *dim_arg, *mask_arg, *kind_arg; gfc_actual_arglist *back_arg; gfc_ss *arrayss = nullptr; gfc_ss *maskss = nullptr; @@ -4944,8 +4996,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) int n; bool optional_mask; - actual = expr->value.function.actual; - array_arg = actual; + array_arg = expr->value.function.actual; dim_arg = array_arg->next; mask_arg = dim_arg->next; kind_arg = mask_arg->next; @@ -4954,14 +5005,16 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) bool dim_present = dim_arg->expr != nullptr; bool nested_loop = dim_present && expr->rank > 0; - /* The last argument, BACK, is passed by value. Ensure that - by setting its name to %VAL. */ - for (gfc_actual_arglist *a = actual; a; a = a->next) + /* Remove kind. */ + if (kind_arg->expr) { - if (a->next == NULL) - a->name = "%VAL"; + gfc_free_expr (kind_arg->expr); + kind_arg->expr = NULL; } + /* Pass BACK argument by value. */ + back_arg->name = "%VAL"; + if (se->ss) { if (se->ss->info->useflags) @@ -4983,25 +5036,19 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) } } - arrayexpr = actual->expr; + arrayexpr = array_arg->expr; - /* Special case for character maxloc. Remove unneeded actual - arguments, then call a library function. */ + /* Special case for character maxloc. Remove unneeded "dim" actual + argument, then call a library function. */ if (arrayexpr->ts.type == BT_CHARACTER) { gcc_assert (expr->rank == 0); - gfc_actual_arglist *a = actual; - strip_kind_from_actual (a); - while (a) + if (dim_arg->expr) { - if (a->name && strcmp (a->name, "dim") == 0) - { - gfc_free_expr (a->expr); - a->expr = NULL; - } - a = a->next; + gfc_free_expr (dim_arg->expr); + dim_arg->expr = NULL; } gfc_conv_intrinsic_funcall (se, expr); return; @@ -5824,6 +5871,126 @@ gfc_conv_intrinsic_findloc (gfc_se *se, gfc_expr *expr) } +/* Emit code for fstat, lstat and stat intrinsic subroutines. */ + +static tree +conv_intrinsic_fstat_lstat_stat_sub (gfc_code *code) +{ + stmtblock_t block; + gfc_se se, se_stat; + tree unit = NULL_TREE; + tree name = NULL_TREE; + tree slen = NULL_TREE; + tree vals; + tree arg3 = NULL_TREE; + tree stat = NULL_TREE ; + tree present = NULL_TREE; + tree tmp; + int kind; + + gfc_init_block (&block); + gfc_init_se (&se, NULL); + + switch (code->resolved_isym->id) + { + case GFC_ISYM_FSTAT: + /* Deal with the UNIT argument. */ + gfc_conv_expr (&se, code->ext.actual->expr); + gfc_add_block_to_block (&block, &se.pre); + unit = gfc_evaluate_now (se.expr, &block); + unit = gfc_build_addr_expr (NULL_TREE, unit); + gfc_add_block_to_block (&block, &se.post); + break; + + case GFC_ISYM_LSTAT: + case GFC_ISYM_STAT: + /* Deal with the NAME argument. */ + gfc_conv_expr (&se, code->ext.actual->expr); + gfc_conv_string_parameter (&se); + gfc_add_block_to_block (&block, &se.pre); + name = se.expr; + slen = se.string_length; + gfc_add_block_to_block (&block, &se.post); + break; + + default: + gcc_unreachable (); + } + + /* Deal with the VALUES argument. */ + gfc_init_se (&se, NULL); + gfc_conv_expr_descriptor (&se, code->ext.actual->next->expr); + vals = gfc_build_addr_expr (NULL_TREE, se.expr); + gfc_add_block_to_block (&block, &se.pre); + gfc_add_block_to_block (&block, &se.post); + kind = code->ext.actual->next->expr->ts.kind; + + /* Deal with an optional STATUS. */ + if (code->ext.actual->next->next->expr) + { + gfc_init_se (&se_stat, NULL); + gfc_conv_expr (&se_stat, code->ext.actual->next->next->expr); + stat = gfc_create_var (gfc_get_int_type (kind), "_stat"); + arg3 = gfc_build_addr_expr (NULL_TREE, stat); + + /* Handle case of status being an optional dummy. */ + gfc_symbol *sym = code->ext.actual->next->next->expr->symtree->n.sym; + if (sym->attr.dummy && sym->attr.optional) + { + present = gfc_conv_expr_present (sym); + arg3 = fold_build3_loc (input_location, COND_EXPR, + TREE_TYPE (arg3), present, arg3, + fold_convert (TREE_TYPE (arg3), + null_pointer_node)); + } + } + + /* Call library function depending on KIND of VALUES argument. */ + switch (code->resolved_isym->id) + { + case GFC_ISYM_FSTAT: + tmp = (kind == 4 ? gfor_fndecl_fstat_i4_sub : gfor_fndecl_fstat_i8_sub); + break; + case GFC_ISYM_LSTAT: + tmp = (kind == 4 ? gfor_fndecl_lstat_i4_sub : gfor_fndecl_lstat_i8_sub); + break; + case GFC_ISYM_STAT: + tmp = (kind == 4 ? gfor_fndecl_stat_i4_sub : gfor_fndecl_stat_i8_sub); + break; + default: + gcc_unreachable (); + } + + if (code->resolved_isym->id == GFC_ISYM_FSTAT) + tmp = build_call_expr_loc (input_location, tmp, 3, unit, vals, + stat ? arg3 : null_pointer_node); + else + tmp = build_call_expr_loc (input_location, tmp, 4, name, vals, + stat ? arg3 : null_pointer_node, slen); + gfc_add_expr_to_block (&block, tmp); + + /* Handle kind conversion of status. */ + if (stat && stat != se_stat.expr) + { + stmtblock_t block2; + + gfc_init_block (&block2); + gfc_add_modify (&block2, se_stat.expr, + fold_convert (TREE_TYPE (se_stat.expr), stat)); + + if (present) + { + tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block2), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block, tmp); + } + else + gfc_add_block_to_block (&block, &block2); + } + + return gfc_finish_block (&block); +} + /* Emit code for minval or maxval intrinsic. There are many different cases we need to handle. For performance reasons we sometimes create two loops instead of one, where the second one is much simpler. @@ -8604,7 +8771,12 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) argse.string_length); else if (arg->expr->ts.type == BT_CLASS) { - class_ref = TREE_OPERAND (argse.expr, 0); + if (UNLIMITED_POLY (source_expr) + && DECL_LANG_SPECIFIC (source_expr->symtree->n.sym->backend_decl)) + class_ref = GFC_DECL_SAVED_DESCRIPTOR + (source_expr->symtree->n.sym->backend_decl); + else + class_ref = TREE_OPERAND (argse.expr, 0); tmp = gfc_class_vtab_size_get (class_ref); if (UNLIMITED_POLY (arg->expr)) tmp = gfc_resize_class_size_with_len (&argse.pre, class_ref, tmp); @@ -9871,38 +10043,40 @@ conv_isocbinding_function (gfc_se *se, gfc_expr *expr) static tree conv_isocbinding_subroutine (gfc_code *code) { - gfc_se se; - gfc_se cptrse; - gfc_se fptrse; - gfc_se shapese; - gfc_ss *shape_ss; - tree desc, dim, tmp, stride, offset; + gfc_expr *cptr, *fptr, *shape, *lower; + gfc_se se, cptrse, fptrse, shapese, lowerse; + gfc_ss *shape_ss, *lower_ss; + tree desc, dim, tmp, stride, offset, lbound, ubound; stmtblock_t body, block; gfc_loopinfo loop; - gfc_actual_arglist *arg = code->ext.actual; + gfc_actual_arglist *arg; + + arg = code->ext.actual; + cptr = arg->expr; + fptr = arg->next->expr; + shape = arg->next->next ? arg->next->next->expr : NULL; + lower = shape && arg->next->next->next ? arg->next->next->next->expr : NULL; gfc_init_se (&se, NULL); gfc_init_se (&cptrse, NULL); - gfc_conv_expr (&cptrse, arg->expr); + gfc_conv_expr (&cptrse, cptr); gfc_add_block_to_block (&se.pre, &cptrse.pre); gfc_add_block_to_block (&se.post, &cptrse.post); gfc_init_se (&fptrse, NULL); - if (arg->next->expr->rank == 0) + if (fptr->rank == 0) { fptrse.want_pointer = 1; - gfc_conv_expr (&fptrse, arg->next->expr); + gfc_conv_expr (&fptrse, fptr); 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)); + if (fptr->symtree->n.sym->attr.proc_pointer + && fptr->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_add_expr_to_block (&se.pre, se.expr); gfc_add_block_to_block (&se.pre, &se.post); return gfc_finish_block (&se.pre); @@ -9912,7 +10086,7 @@ conv_isocbinding_subroutine (gfc_code *code) /* Get the descriptor of the Fortran pointer. */ fptrse.descriptor_only = 1; - gfc_conv_expr_descriptor (&fptrse, arg->next->expr); + gfc_conv_expr_descriptor (&fptrse, fptr); gfc_add_block_to_block (&block, &fptrse.pre); desc = fptrse.expr; @@ -9929,18 +10103,33 @@ conv_isocbinding_subroutine (gfc_code *code) /* Start scalarization of the bounds, using the shape argument. */ - shape_ss = gfc_walk_expr (arg->next->next->expr); + shape_ss = gfc_walk_expr (shape); gcc_assert (shape_ss != gfc_ss_terminator); gfc_init_se (&shapese, NULL); + if (lower) + { + lower_ss = gfc_walk_expr (lower); + gcc_assert (lower_ss != gfc_ss_terminator); + gfc_init_se (&lowerse, NULL); + } gfc_init_loopinfo (&loop); gfc_add_ss_to_loop (&loop, shape_ss); + if (lower) + gfc_add_ss_to_loop (&loop, lower_ss); gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop, &arg->next->expr->where); + gfc_conv_loop_setup (&loop, &fptr->where); gfc_mark_ss_chain_used (shape_ss, 1); + if (lower) + gfc_mark_ss_chain_used (lower_ss, 1); gfc_copy_loopinfo_to_se (&shapese, &loop); shapese.ss = shape_ss; + if (lower) + { + gfc_copy_loopinfo_to_se (&lowerse, &loop); + lowerse.ss = lower_ss; + } stride = gfc_create_var (gfc_array_index_type, "stride"); offset = gfc_create_var (gfc_array_index_type, "offset"); @@ -9951,27 +10140,44 @@ conv_isocbinding_subroutine (gfc_code *code) gfc_start_scalarized_body (&loop, &body); dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - loop.loopvar[0], loop.from[0]); + loop.loopvar[0], loop.from[0]); + + if (lower) + { + gfc_conv_expr (&lowerse, lower); + gfc_add_block_to_block (&body, &lowerse.pre); + lbound = fold_convert (gfc_array_index_type, lowerse.expr); + gfc_add_block_to_block (&body, &lowerse.post); + } + else + lbound = gfc_index_one_node; /* Set bounds and stride. */ - gfc_conv_descriptor_lbound_set (&body, desc, dim, gfc_index_one_node); + gfc_conv_descriptor_lbound_set (&body, desc, dim, lbound); gfc_conv_descriptor_stride_set (&body, desc, dim, stride); - gfc_conv_expr (&shapese, arg->next->next->expr); + gfc_conv_expr (&shapese, shape); gfc_add_block_to_block (&body, &shapese.pre); - gfc_conv_descriptor_ubound_set (&body, desc, dim, shapese.expr); + ubound = fold_build2_loc ( + input_location, MINUS_EXPR, gfc_array_index_type, + fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, lbound, + fold_convert (gfc_array_index_type, shapese.expr)), + gfc_index_one_node); + gfc_conv_descriptor_ubound_set (&body, desc, dim, ubound); gfc_add_block_to_block (&body, &shapese.post); /* Calculate offset. */ + tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + stride, lbound); gfc_add_modify (&body, offset, fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, offset, stride)); + gfc_array_index_type, offset, tmp)); + /* 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))); + 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); @@ -13122,6 +13328,8 @@ conv_intrinsic_move_alloc (gfc_code *code) } gfc_conv_expr_descriptor (&to_se, to_expr); gfc_conv_expr_descriptor (&from_se, from_expr); + gfc_add_block_to_block (&block, &to_se.pre); + gfc_add_block_to_block (&block, &from_se.pre); /* 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. */ @@ -13195,6 +13403,9 @@ conv_intrinsic_move_alloc (gfc_code *code) if (fin_label) gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, fin_label)); + gfc_add_block_to_block (&block, &to_se.post); + gfc_add_block_to_block (&block, &from_se.post); + return gfc_finish_block (&block); } @@ -13261,6 +13472,12 @@ gfc_conv_intrinsic_subroutine (gfc_code *code) res = conv_intrinsic_free (code); break; + case GFC_ISYM_FSTAT: + case GFC_ISYM_LSTAT: + case GFC_ISYM_STAT: + res = conv_intrinsic_fstat_lstat_stat_sub (code); + break; + case GFC_ISYM_RANDOM_INIT: res = conv_intrinsic_random_init (code); break; @@ -13277,6 +13494,10 @@ gfc_conv_intrinsic_subroutine (gfc_code *code) res = conv_intrinsic_system_clock (code); break; + case GFC_ISYM_SPLIT: + res = conv_intrinsic_split (code); + break; + default: res = NULL_TREE; break; diff --git a/gcc/fortran/trans-io.cc b/gcc/fortran/trans-io.cc index 824f232..9360bdd 100644 --- a/gcc/fortran/trans-io.cc +++ b/gcc/fortran/trans-io.cc @@ -2499,7 +2499,8 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, for (c = ts->u.derived->components; c; c = c->next) { /* Ignore hidden string lengths. */ - if (c->name[0] == '_') + if (c->name[0] == '_' + || c->attr.pdt_kind || c->attr.pdt_len) continue; field = c->backend_decl; @@ -2645,7 +2646,9 @@ gfc_trans_transfer (gfc_code * code) && ((expr->symtree->n.sym->ts.type == BT_DERIVED && expr->ts.deferred) || (expr->symtree->n.sym->assoc && expr->symtree->n.sym->assoc->variable) - || gfc_expr_attr (expr).pointer)) + || gfc_expr_attr (expr).pointer + || (expr->symtree->n.sym->attr.pointer + && gfc_expr_attr (expr).target))) goto scalarize; /* With array-bounds checking enabled, force scalarization in some diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc index 0b8150f..69a70d7 100644 --- a/gcc/fortran/trans-openmp.cc +++ b/gcc/fortran/trans-openmp.cc @@ -2478,6 +2478,26 @@ gfc_omp_deep_mapping_do (bool is_cnt, const gimple *ctx, tree clause, else while (TREE_CODE (tmp) == COMPONENT_REF || TREE_CODE (tmp) == ARRAY_REF) tmp = TREE_OPERAND (tmp, TREE_CODE (tmp) == COMPONENT_REF ? 1 : 0); + if (TREE_CODE (tmp) == MEM_REF) + tmp = TREE_OPERAND (tmp, 0); + if (TREE_CODE (tmp) == SSA_NAME) + { + gimple *def_stmt = SSA_NAME_DEF_STMT (tmp); + if (gimple_code (def_stmt) == GIMPLE_ASSIGN) + { + tmp = gimple_assign_rhs1 (def_stmt); + if (poly) + { + tmp = TYPE_FIELDS (type); + type = TREE_TYPE (tmp); + } + else + while (TREE_CODE (tmp) == COMPONENT_REF + || TREE_CODE (tmp) == ARRAY_REF) + tmp = TREE_OPERAND (tmp, + TREE_CODE (tmp) == COMPONENT_REF ? 1 : 0); + } + } /* If the clause argument is nonallocatable, skip is-allocate check. */ if (GFC_DECL_GET_SCALAR_ALLOCATABLE (tmp) || GFC_DECL_GET_SCALAR_POINTER (tmp) @@ -2772,8 +2792,13 @@ gfc_trans_omp_variable_list (enum omp_clause_code code, gfc_omp_namelist *namelist, tree list, bool declare_simd) { + /* PARAMETER (named constants) are excluded as OpenACC 3.4 permits them now + as 'var' but permits compilers to ignore them. In expressions, it should + have been replaced by the value (and this function should not be called + anyway) and for var-using clauses, they should just be skipped. */ for (; namelist != NULL; namelist = namelist->next) - if (namelist->sym->attr.referenced || declare_simd) + if ((namelist->sym->attr.referenced || declare_simd) + && namelist->sym->attr.flavor != FL_PARAMETER) { tree t = gfc_trans_omp_variable (namelist->sym, declare_simd); if (t != error_mark_node) @@ -4009,7 +4034,8 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, case OMP_LIST_MAP: for (; n != NULL; n = n->next) { - if (!n->sym->attr.referenced) + if (!n->sym->attr.referenced + || n->sym->attr.flavor == FL_PARAMETER) continue; location_t map_loc = gfc_get_location (&n->where); @@ -4966,7 +4992,8 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, case OMP_LIST_CACHE: for (; n != NULL; n = n->next) { - if (!n->sym->attr.referenced) + if (!n->sym->attr.referenced + && n->sym->attr.flavor != FL_PARAMETER) continue; switch (list) @@ -6028,6 +6055,10 @@ gfc_trans_oacc_wait_directive (gfc_code *code) args->quick_push (gfc_convert_expr_to_tree (&block, el->expr)); stmt = build_call_expr_loc_vec (loc, stmt, args); + if (clauses->if_expr) + stmt = build3_loc (input_location, COND_EXPR, void_type_node, + gfc_convert_expr_to_tree (&block, clauses->if_expr), + stmt, NULL_TREE); gfc_add_expr_to_block (&block, stmt); vec_free (args); @@ -9683,11 +9714,12 @@ gfc_trans_omp_declare_variant (gfc_namespace *ns, gfc_namespace *parent_ns) { gfc_symtree *proc_st; gfc_find_sym_tree (variant_proc_name, gfc_current_ns, 1, &proc_st); - variant_proc_sym = proc_st->n.sym; + variant_proc_sym = proc_st ? proc_st->n.sym : NULL; } if (variant_proc_sym == NULL) { - gfc_error ("Cannot find symbol %qs", variant_proc_name); + gfc_error ("Cannot find symbol %qs at %L", variant_proc_name, + &odv->where); continue; } set_selectors = omp_check_context_selector @@ -9703,6 +9735,12 @@ gfc_trans_omp_declare_variant (gfc_namespace *ns, gfc_namespace *parent_ns) variant_proc_name, &odv->where); variant_proc_sym = NULL; } + else if (variant_proc_sym == ns->proc_name) + { + gfc_error ("variant %qs at %L is the same as base function", + variant_proc_name, &odv->where); + variant_proc_sym = NULL; + } else if (omp_get_context_selector (set_selectors, OMP_TRAIT_SET_CONSTRUCT, OMP_TRAIT_CONSTRUCT_SIMD) diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc index 487b768..f25335d 100644 --- a/gcc/fortran/trans-stmt.cc +++ b/gcc/fortran/trans-stmt.cc @@ -377,6 +377,57 @@ get_intrinsic_for_code (gfc_code *code) } +/* Handle the OpenACC routines acc_attach{,_async} and + acc_detach{,_finalize}{,_async} explicitly. This is required as the + the corresponding device pointee is attached to the corresponding device + pointer, but if a temporary array descriptor is created for the call, + that one is used as pointer instead of the original pointer. */ + +tree +gfc_trans_call_acc_attach_detach (gfc_code *code) +{ + stmtblock_t block; + gfc_se ptr_addr_se, async_se; + tree fn; + + fn = code->resolved_sym->backend_decl; + if (fn == NULL) + { + fn = gfc_get_symbol_decl (code->resolved_sym); + code->resolved_sym->backend_decl = fn; + } + + gfc_start_block (&block); + + gfc_init_se (&ptr_addr_se, NULL); + ptr_addr_se.descriptor_only = 1; + ptr_addr_se.want_pointer = 1; + gfc_conv_expr (&ptr_addr_se, code->ext.actual->expr); + gfc_add_block_to_block (&block, &ptr_addr_se.pre); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (ptr_addr_se.expr))) + ptr_addr_se.expr = gfc_conv_descriptor_data_get (ptr_addr_se.expr); + ptr_addr_se.expr = build_fold_addr_expr (ptr_addr_se.expr); + + bool async = code->ext.actual->next != NULL; + if (async) + { + gfc_init_se (&async_se, NULL); + gfc_conv_expr (&async_se, code->ext.actual->next->expr); + fn = build_call_expr_loc (gfc_get_location (&code->loc), fn, 2, + ptr_addr_se.expr, async_se.expr); + } + else + fn = build_call_expr_loc (gfc_get_location (&code->loc), + fn, 1, ptr_addr_se.expr); + gfc_add_expr_to_block (&block, fn); + gfc_add_block_to_block (&block, &ptr_addr_se.post); + if (async) + gfc_add_block_to_block (&block, &async_se.post); + + return gfc_finish_block (&block); +} + + /* Translate the CALL statement. Builds a call to an F95 subroutine. */ tree @@ -392,13 +443,32 @@ gfc_trans_call (gfc_code * code, bool dependency_check, tree tmp; bool is_intrinsic_mvbits; + gcc_assert (code->resolved_sym); + + /* Unfortunately, acc_attach* and acc_detach* need some special treatment for + attaching the the pointee to a pointer as GCC might introduce a temporary + array descriptor, whose data component is then used as to be attached to + pointer. */ + if (flag_openacc + && code->resolved_sym->attr.subroutine + && code->resolved_sym->formal + && code->resolved_sym->formal->sym->ts.type == BT_ASSUMED + && code->resolved_sym->formal->sym->attr.dimension + && code->resolved_sym->formal->sym->as->type == AS_ASSUMED_RANK + && startswith (code->resolved_sym->name, "acc_") + && (!strcmp (code->resolved_sym->name + 4, "attach") + || !strcmp (code->resolved_sym->name + 4, "attach_async") + || !strcmp (code->resolved_sym->name + 4, "detach") + || !strcmp (code->resolved_sym->name + 4, "detach_async") + || !strcmp (code->resolved_sym->name + 4, "detach_finalize") + || !strcmp (code->resolved_sym->name + 4, "detach_finalize_async"))) + return gfc_trans_call_acc_attach_detach (code); + /* A CALL starts a new block because the actual arguments may have to be evaluated first. */ gfc_init_se (&se, NULL); gfc_start_block (&se.pre); - gcc_assert (code->resolved_sym); - ss = gfc_ss_terminator; if (code->resolved_sym->attr.elemental) ss = gfc_walk_elemental_function_args (ss, code->ext.actual, @@ -1806,9 +1876,6 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) bool class_target; bool unlimited; tree desc; - tree offset; - tree dim; - int n; tree charlen; bool need_len_assign; bool whole_array = true; @@ -2046,7 +2113,6 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) if (sym->assoc->variable || cst_array_ctor) { se.direct_byref = 1; - se.use_offset = 1; se.expr = desc; GFC_DECL_PTR_ARRAY_P (sym->backend_decl) = 1; } @@ -2113,16 +2179,6 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) dim, gfc_index_one_node); } - /* If this is a subreference array pointer associate name use the - associate variable element size for the value of 'span'. */ - if (sym->attr.subref_array_pointer && !se.direct_byref) - { - gcc_assert (e->expr_type == EXPR_VARIABLE); - tmp = gfc_get_array_span (se.expr, e); - - gfc_conv_descriptor_span_set (&se.pre, desc, tmp); - } - if (e->expr_type == EXPR_FUNCTION && sym->ts.type == BT_DERIVED && sym->ts.u.derived @@ -2233,21 +2289,6 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) desc = gfc_class_data_get (se.expr); - /* Set the offset. */ - offset = gfc_index_zero_node; - for (n = 0; n < e->rank; n++) - { - dim = gfc_rank_cst[n]; - tmp = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - gfc_conv_descriptor_stride_get (desc, dim), - gfc_conv_descriptor_lbound_get (desc, dim)); - offset = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - offset, tmp); - } - gfc_conv_descriptor_offset_set (&se.pre, desc, offset); - if (need_len_assign) { if (e->symtree @@ -2424,9 +2465,10 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) { tmp = sym->backend_decl; if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) - tmp = gfc_conv_descriptor_data_get (tmp); - gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp), - null_pointer_node)); + gfc_conv_descriptor_data_set (&se.pre, tmp, null_pointer_node); + else + gfc_add_modify (&se.pre, tmp, + fold_convert (TREE_TYPE (tmp), null_pointer_node)); } lhs = gfc_lval_expr_from_sym (sym); @@ -6640,7 +6682,6 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate) stmtblock_t block; stmtblock_t post; stmtblock_t final_block; - tree nelems; bool upoly_expr, tmp_expr3_len_flag = false, al_len_needs_set, is_coarray; bool needs_caf_sync, caf_refs_comp; bool e3_has_nodescriptor = false; @@ -7172,7 +7213,6 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate) to handle the complete array allocation. Only the element size needs to be provided, which is done most of the time by the pre-evaluation step. */ - nelems = NULL_TREE; if (expr3_len && (code->expr3->ts.type == BT_CHARACTER || code->expr3->ts.type == BT_CLASS)) { @@ -7243,9 +7283,8 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate) } - if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, - label_finish, tmp, &nelems, - e3rhs ? e3rhs : code->expr3, + if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish, + tmp, e3rhs ? e3rhs : code->expr3, e3_is == E3_DESC ? expr3 : NULL_TREE, e3_has_nodescriptor, omp_alloc_item, code->ext.alloc.ts.type != BT_UNKNOWN)) @@ -7883,6 +7922,8 @@ gfc_trans_deallocate (gfc_code *code) gfc_expr *expr = gfc_copy_expr (al->expr); bool is_coarray = false, is_coarray_array = false; int caf_mode = 0; + gfc_ref * ref; + gfc_actual_arglist * param_list; gcc_assert (expr->expr_type == EXPR_VARIABLE); @@ -7898,9 +7939,18 @@ gfc_trans_deallocate (gfc_code *code) /* Deallocate PDT components that are parameterized. */ tmp = NULL; + param_list = expr->param_list; + if (!param_list && expr->symtree->n.sym->param_list) + param_list = expr->symtree->n.sym->param_list; + for (ref = expr->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT + && ref->u.c.component->ts.type == BT_DERIVED + && ref->u.c.component->ts.u.derived->attr.pdt_type + && ref->u.c.component->param_list) + param_list = ref->u.c.component->param_list; if (expr->ts.type == BT_DERIVED - && expr->ts.u.derived->attr.pdt_type - && expr->symtree->n.sym->param_list) + && ((expr->ts.u.derived->attr.pdt_type && param_list) + || expr->ts.u.derived->attr.pdt_comp)) tmp = gfc_deallocate_pdt_comp (expr->ts.u.derived, se.expr, expr->rank); else if (expr->ts.type == BT_CLASS && CLASS_DATA (expr)->ts.u.derived->attr.pdt_type diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc index f898075..dfdac60 100644 --- a/gcc/fortran/trans-types.cc +++ b/gcc/fortran/trans-types.cc @@ -800,6 +800,9 @@ gfc_init_kinds (void) gfc_index_integer_kind = get_int_kind_from_name (PTRDIFF_TYPE); + if (flag_external_blas64 && gfc_index_integer_kind != gfc_integer_8_kind) + gfc_fatal_error ("-fexternal-blas64 requires a 64-bit system"); + /* Pick a kind the same size as the C "int" type. */ gfc_c_int_kind = INT_TYPE_SIZE / 8; @@ -1132,6 +1135,7 @@ gfc_init_types (void) { type = gfc_build_uint_type (gfc_character_kinds[index].bit_size); type = build_qualified_type (type, TYPE_UNQUALIFIED); + TYPE_STRING_FLAG (type) = 1; snprintf (name_buf, sizeof(name_buf), "character(kind=%d)", gfc_character_kinds[index].kind); PUSH_TYPE (name_buf, type); @@ -3187,7 +3191,7 @@ copy_derived_types: for (c = derived->components; c; c = c->next) { /* Do not add a caf_token field for class container components. */ - if ((codimen || coarray_flag) && !c->attr.dimension + if (codimen && coarray_flag && !c->attr.dimension && !c->attr.codimension && (c->attr.allocatable || c->attr.pointer) && !derived->attr.is_class) { @@ -3231,13 +3235,14 @@ gfc_return_by_reference (gfc_symbol * sym) /* Possibly return complex numbers by reference for g77 compatibility. We don't do this for calls to intrinsics (as the library uses the - -fno-f2c calling convention), nor for calls to functions which always + -fno-f2c calling convention) except for calls to specific wrappers + (_gfortran_f2c_specific_*), nor for calls to functions which always require an explicit interface, as no compatibility problems can arise there. */ if (flag_f2c && sym->ts.type == BT_COMPLEX && !sym->attr.pointer && !sym->attr.allocatable - && !sym->attr.intrinsic && !sym->attr.always_explicit) + && !sym->attr.always_explicit) return 1; return 0; @@ -3436,6 +3441,7 @@ gfc_get_function_type (gfc_symbol * sym, gfc_actual_arglist *actual_args, } } if (sym->backend_decl == error_mark_node && actual_args != NULL + && sym->ts.interface == NULL && sym->formal == NULL && (sym->attr.proc == PROC_EXTERNAL || sym->attr.proc == PROC_UNKNOWN)) gfc_get_formal_from_actual_arglist (sym, actual_args); diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc index fdeb1e8..47396c3 100644 --- a/gcc/fortran/trans.cc +++ b/gcc/fortran/trans.cc @@ -822,6 +822,7 @@ gfc_allocate_using_malloc (stmtblock_t * block, tree pointer, tree tmp, error_cond; stmtblock_t on_error; tree status_type = status ? TREE_TYPE (status) : NULL_TREE; + bool cond_is_true = cond == boolean_true_node; /* If successful and stat= is given, set status to 0. */ if (status != NULL_TREE) @@ -834,11 +835,13 @@ gfc_allocate_using_malloc (stmtblock_t * block, tree pointer, tmp = fold_build2_loc (input_location, MAX_EXPR, size_type_node, size, build_int_cst (size_type_node, 1)); - tmp = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_MALLOC), 1, tmp); - if (cond == boolean_true_node) + if (!cond_is_true) + tmp = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_MALLOC), 1, tmp); + else tmp = alt_alloc; - else if (cond) + + if (!cond_is_true && cond) tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond, alt_alloc, tmp); @@ -1737,7 +1740,7 @@ gfc_finalize_tree_expr (gfc_se *se, gfc_symbol *derived, gfc_call_free (data_ptr), build_empty_stmt (input_location)); gfc_add_expr_to_block (&se->loop->post, tmp); - gfc_add_modify (&se->loop->post, data_ptr, data_null); + gfc_conv_descriptor_data_set (&se->loop->post, desc, data_null); } else { @@ -1751,7 +1754,7 @@ gfc_finalize_tree_expr (gfc_se *se, gfc_symbol *derived, gfc_call_free (data_ptr), build_empty_stmt (input_location)); gfc_add_expr_to_block (&se->finalblock, tmp); - gfc_add_modify (&se->finalblock, data_ptr, data_null); + gfc_conv_descriptor_data_set (&se->finalblock, desc, data_null); } } } diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 461b0cd..1d04b22 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -105,10 +105,6 @@ typedef struct gfc_se /* If set, will pass subref descriptors without a temporary. */ unsigned force_no_tmp:1; - /* Unconditionally calculate offset for array segments and constant - arrays in gfc_conv_expr_descriptor. */ - unsigned use_offset:1; - unsigned want_coarray:1; /* Scalarization parameters. */ @@ -961,6 +957,7 @@ extern GTY(()) tree gfor_fndecl_string_scan; extern GTY(()) tree gfor_fndecl_string_verify; extern GTY(()) tree gfor_fndecl_string_trim; extern GTY(()) tree gfor_fndecl_string_minmax; +extern GTY(()) tree gfor_fndecl_string_split; extern GTY(()) tree gfor_fndecl_adjustl; extern GTY(()) tree gfor_fndecl_adjustr; extern GTY(()) tree gfor_fndecl_select_string; @@ -972,6 +969,7 @@ extern GTY(()) tree gfor_fndecl_string_scan_char4; extern GTY(()) tree gfor_fndecl_string_verify_char4; extern GTY(()) tree gfor_fndecl_string_trim_char4; extern GTY(()) tree gfor_fndecl_string_minmax_char4; +extern GTY(()) tree gfor_fndecl_string_split_char4; extern GTY(()) tree gfor_fndecl_adjustl_char4; extern GTY(()) tree gfor_fndecl_adjustr_char4; extern GTY(()) tree gfor_fndecl_select_string_char4; @@ -985,6 +983,12 @@ extern GTY(()) tree gfor_fndecl_iargc; extern GTY(()) tree gfor_fndecl_kill; extern GTY(()) tree gfor_fndecl_kill_sub; extern GTY(()) tree gfor_fndecl_is_contiguous0; +extern GTY(()) tree gfor_fndecl_fstat_i4_sub; +extern GTY(()) tree gfor_fndecl_fstat_i8_sub; +extern GTY(()) tree gfor_fndecl_lstat_i4_sub; +extern GTY(()) tree gfor_fndecl_lstat_i8_sub; +extern GTY(()) tree gfor_fndecl_stat_i4_sub; +extern GTY(()) tree gfor_fndecl_stat_i8_sub; /* Implemented in Fortran. */ extern GTY(()) tree gfor_fndecl_sc_kind; |