diff options
Diffstat (limited to 'gcc/fortran')
53 files changed, 9051 insertions, 1704 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index e6ecc8d..4fd2183 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,1758 @@ +2025-12-08 Harald Anlauf <anlauf@gmx.de> + Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/123025 + * decl.cc (match_char_length): Add a check for the + obsolete '*' style of character declarations in the + alternate branch of checking so we dont miss two + use cases: + +2025-12-06 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/122693 + * array.cc (gfc_match_array_constructor): Stash and restore + gfc_current_ns after the call to 'gfc_match_type_spec'. + +2025-12-06 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/122670 + * decl.cc (gfc_get_pdt_instance): Ensure that, in an interface + body, PDT instances imported implicitly if the template has + been explicitly imported. + * module.cc (read_module): If a PDT template appears in a use + only statement, implicitly add the instances as well. + +2025-12-06 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/122669 + * resolve.cc (resolve_allocate_deallocate): Mold expressions + with an array reference and a constant size must be resolved + for each allocate object. + +2025-12-06 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/122578 + * primary.cc (gfc_match_varspec): Try to resolve a typebound + generic procedure selector expression to provide the associate + name with a type. Also, resolve component calls. In both cases, + make a copy of the selector expression to guard against changes + made by gfc_resolve_expr. + +2025-12-05 Harald Anlauf <anlauf@gmx.de> + + PR fortran/122977 + * expr.cc (gfc_is_simply_contiguous): For an associate variable + check whether the associate target is contiguous. + * resolve.cc (resolve_symbol): Skip array type check for an + associate variable when the target has the contiguous attribute. + +2025-12-05 Tobias Burnus <tburnus@baylibre.com> + + * openmp.cc (resolve_omp_clauses): Permit zero with + DYN_GROUPPRIVATE clause. + * trans-openmp.cc (fallback): Generate TREE code + for DYN_GROUPPRIVATE and remove 'sorry'. + +2025-12-03 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/103371 + * decl.cc (gfc_get_pdt_instance): Remove the requirement that + PDT components be of the same type as the enclosing type. Apply + initializers other than the default to PDT components. + * primary.cc (gfc_match_rvalue): Make combination of the two + actual_arglists conditional on 'type_spec_list' having been + seen as well together with applying component names to all the + arguments. + * trans-decl.cc (gfc_init_default_dt): Add 'pdt_ok' to the args + and use it to signal that a PDT can be default initialized. + (gfc_init_default_pdt): New function to check that a pdt is OK + for default intialization before calling gfc_init_default_dt. + (gfc_trans_deferred_vars): Use gfc_init_default_pdt. + * trans.h: Add bool 'pdt_ok' to prototype with defaul value of + false. + +2025-12-01 Christopher Albert <albert@tugraz.at> + Harald Anlauf <anlauf@gcc.gnu.org> + + PR fortran/107721 + PR fortran/102417 + * arith.cc (eval_intrinsic): Call gfc_check_constructor_type on + array constructor operands with explicit type-spec to ensure + element type conversion before operations. Resolve character + array constructors before CONCAT operations. + (reduce_binary_ac, reduce_binary_ca, reduce_binary_aa): Preserve + character length info in result arrays. + * array.cc (check_constructor_type): Simplify non-constant + expressions before type checking to handle parenthesized elements. + Handle nested character array constructors with explicit type-spec + when outer constructor has no type-spec. + (gfc_resolve_character_array_constructor): Recursively propagate + type-spec to nested array constructors. If the nested constructor + has an explicit type-spec, resolve it first before propagating + the outer type-spec. + +2025-12-01 Tobias Burnus <tburnus@baylibre.com> + + * gfortran.texi (Default exponents): Remove spurious @menu entry. + +2025-11-30 Andrew Pinski <andrew.pinski@oss.qualcomm.com> + + * lang.opt.urls: Regenerate. + +2025-11-28 Tobias Burnus <tburnus@baylibre.com> + + PR c/122892 + * openmp.cc (gfc_resolve_omp_allocate): Reject non-local + static variables with cgroup/pteam/thread allocators. + * parse.cc: Permit OMP ALLOCATE in BLOCK DATA. + +2025-11-26 Tobias Burnus <tburnus@baylibre.com> + + * dump-parse-tree.cc (show_attr): Handle OpenMP's 'local' clause + and the 'groupprivate' directive. + (show_omp_clauses): Handle dyn_groupprivate. + * frontend-passes.cc (gfc_code_walker): Walk dyn_groupprivate. + * gfortran.h (enum gfc_statement): Add ST_OMP_GROUPPRIVATE. + (enum gfc_omp_fallback, gfc_add_omp_groupprivate, + gfc_add_omp_declare_target_local): New. + * match.h (gfc_match_omp_groupprivate): New. + * module.cc (enum ab_attribute, mio_symbol_attribute, load_commons, + write_common_0): Handle 'groupprivate' + declare target's 'local'. + * openmp.cc (gfc_omp_directives): Add 'groupprivate'. + (gfc_free_omp_clauses): Free dyn_groupprivate. + (enum omp_mask2): Add OMP_CLAUSE_LOCAL and OMP_CLAUSE_DYN_GROUPPRIVATE. + (gfc_match_omp_clauses): Match them. + (OMP_TARGET_CLAUSES): Add OMP_CLAUSE_DYN_GROUPPRIVATE. + (OMP_DECLARE_TARGET_CLAUSES): Add OMP_CLAUSE_LOCAL. + (gfc_match_omp_declare_target): Handle groupprivate + fixes. + (gfc_match_omp_threadprivate): Code move to and calling now ... + (gfc_match_omp_thread_group_private): ... this new function. + Also handle groupprivate. + (gfc_match_omp_groupprivate): New. + (resolve_omp_clauses): Resolve dyn_groupprivate. + * parse.cc (decode_omp_directive): Match groupprivate. + (case_omp_decl, parse_spec, gfc_ascii_statement): Handle it. + * resolve.cc (resolve_symbol): Handle groupprivate. + * symbol.cc (gfc_check_conflict, gfc_copy_attr): Handle 'local' + and 'groupprivate'. + (gfc_add_omp_groupprivate, gfc_add_omp_declare_target_local): New. + * trans-common.cc (build_common_decl, + accumulate_equivalence_attributes): Print 'sorry' for + groupprivate and declare target's local. + * trans-decl.cc (add_attributes_to_decl): Likewise.. + * trans-openmp.cc (gfc_trans_omp_clauses): Print 'sorry' for + dyn_groupprivate. + (fallback): Process declare target with link/local as + done for 'enter'. + +2025-11-26 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/104650 + * decl.cc (gfc_get_pdt_instance): If the PDT template has + finalizers, make a new f2k_derived namespace for this intance + and copy the template namespace into it. Set the instance + template_sym field to point to the template. + * expr.cc (gfc_check_pointer_assign): Allow array value pointer + lvalues to point to scalar null expressions in initialization. + * gfortran.h : Add the template_sym field to gfc_symbol. + * resolve.cc (gfc_resolve_finalizers): For a pdt_type, copy the + final subroutines with the same type argument into the pdt_type + finalizer list. Prevent final subroutine type checking and + creation of the vtab for pdt_templates. + * symbol.cc (gfc_free_symbol): Do not call gfc_free_namespace + for pdt_type with finalizers. Instead, free the finalizers and + the namespace. + +2025-11-24 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/122766 + * decl.cc (gfc_match_decl_type_spec): A pdt_type found while + parsing a contains section can only arise from the typespec of + a function declaration. This can be retained in the typespec. + Once we are parsing the function, the first reference to this + derived type will find that it has no symtree. Provide it with + one so that gfc_use_derived does not complain and, again,retain + it in the typespec. + +2025-11-18 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/32365 + * parse.cc (parse_executable): Reject declaration/OpenMP + specification statements seen after executable code + unconditionally, keeping the legacy DATA diagnostic as + a warning. + +2025-11-17 Harald Anlauf <anlauf@gmx.de> + + PR fortran/122709 + * resolve.cc (resolve_assoc_var): If the associate target is a + contiguous pointer, so is the associate variable. + +2025-11-17 Thomas Koenig <tkoenig@gcc.gnu.org> + + * gfortran.texi: Remove section "Experimental features for future + Fortran revisions". Move documentation of UNSIGNED into Extensions. + Mention flang compatibility. + +2025-11-17 Jakub Jelinek <jakub@redhat.com> + + * parse.cc (gfc_parse_file): Avoid arithmetics or + bitwise operations between enumerators from different enums. + +2025-11-14 Yuao Ma <c8ef@outlook.com> + + * trans-expr.cc (conv_dummy_value): Add check for NULL allocatable. + +2025-11-14 Harald Anlauf <anlauf@gmx.de> + + PR fortran/117070 + * array.cc (check_constructor): Allow procedures as potential + target of a procedure pointer. + +2025-11-13 Andrew Stubbs <ams@codesourcery.com> + Kwok Cheung Yeung <kcyeung@baylibre.com> + Thomas Schwinge <tschwinge@baylibre.com> + + * openmp.cc (is_predefined_allocator): Use GOMP_OMP_PREDEF_ALLOC_MAX + and GOMP_OMPX_PREDEF_ALLOC_MIN/MAX instead of hardcoded values in the + comment. + +2025-11-13 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE> + + PR other/122638 + * gfortran.texi (OpenMP): Fix syntax. + * intrinsic.texi (UINT): Fix syntax. + +2025-11-13 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/96255 + * match.cc (apply_typespec_to_iterator): Call gfc_set_sym_referenced + for both new and shadow iterator symbols. + +2025-11-12 Tobias Burnus <tburnus@baylibre.com> + + PR libgomp/119677 + * intrinsic.texi (OpenMP Modules): Add omp_default_device. + * openmp.cc (gfc_resolve_omp_context_selector): Accept + omp_default_device as conforming device number. + +2025-11-11 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/96255 + * resolve.cc (gfc_resolve_forall): Delete outer_sym + +2025-11-11 Christopher Albert <albert@tugraz.at> + + PR fortran/90519 + * trans-expr.cc (strip_parentheses): New helper function to strip + INTRINSIC_PARENTHESES operators from expressions. + (is_runtime_conformable): Use strip_parentheses to handle cases + like a = (a) when checking for self-assignment. + (gfc_trans_assignment_1): Strip parentheses before checking if + expr2 is a variable, ensuring deep_copy is enabled for cases like + a = (a). Also strip parentheses when checking for self-assignment + to avoid use-after-free in finalization. + (gfc_trans_scalar_assign): Add comment about parentheses handling. + * class.cc (generate_finalization_wrapper): Create separate result + symbol for finalizer wrapper functions instead of self-referencing + the procedure symbol, avoiding ICE in gimplify_call_expr. + +2025-11-11 Jerry DeLisle <jvdelisle@gcc.gnu.org> + Steve Kargl <kargl@gcc.gnu.org> + + PR fortran/96255 + * gfortran.h (gfc_forall_iterator): Add bool shadow field. + * match.cc (apply_typespec_to_iterator): New helper function to + consolidate shadow variable creation logic. + (match_forall_header): Add type-spec parsing for DO CONCURRENT + and FORALL. Create shadow variables when type-spec differs from + outer scope. Replace duplicated code with apply_typespec_to_iterator. + * resolve.cc (replace_in_expr_recursive): New function to recursively + walk expressions and replace symbol references. + (replace_in_code_recursive): New function to recursively walk code + blocks and replace symbol references. + (gfc_replace_forall_variable): New entry point for shadow variable + substitution. + (gfc_resolve_assign_in_forall): Skip many-to-one assignment warning + for DO CONCURRENT. + (gfc_count_forall_iterators): Handle both EXEC_FORALL and + EXEC_DO_CONCURRENT with assertion. + (gfc_resolve_forall): Skip F2018 obsolescence warning for DO + CONCURRENT. Fix memory allocation check. Add NULL checks for shadow + variables. Implement shadow variable walker. + (gfc_resolve_code): Set gfc_do_concurrent_flag for DO CONCURRENT + constructs to enable constraint checking. + +2025-11-10 Sandra Loosemore <sloosemore@baylibre.com> + + PR other/122243 + * lang.opt.urls: Regenerated. + +2025-11-08 Harald Anlauf <anlauf@gmx.de> + + PR fortran/113338 + * decl.cc (gfc_verify_c_interop_param): Allow further types of + dummy argument without the VALUE attribute as specified in + F2018 18.3.6 item (5). + +2025-11-08 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/121628 + * trans-array.cc (seen_derived_types): Move to file scope and + preserve/restore around generate_element_copy_wrapper. + * trans-intrinsic.cc (conv_intrinsic_atomic_op): Reuse + gfc_trans_force_lval when forcing addressable CAF temps. + +2025-11-06 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/121628 + * trans-array.cc (get_copy_helper_function_type): New function to + create function type for element copy helpers. + (get_copy_helper_pointer_type): New function to create pointer type + for element copy helpers. + (generate_element_copy_wrapper): New function to generate runtime + helper for element-wise deep copying of recursive types. + (structure_alloc_comps): Detect recursive allocatable array + components and use runtime helper instead of inline recursion. + Add includes for cgraph.h and function.h. + * trans-decl.cc (gfor_fndecl_cfi_deep_copy_array): New declaration + for runtime deep copy helper. + (gfc_build_builtin_function_decls): Initialize the runtime helper + declaration. + * trans-intrinsic.cc (conv_intrinsic_atomic_op): Enhance handling of + constant values in coarray atomic operations by detecting and + materializing address-of-constant expressions. + * trans.h (gfor_fndecl_cfi_deep_copy_array): Add external declaration. + +2025-11-05 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/122566 + * decl.cc (gfc_get_pdt_instance): Add non-PDT type exstention. + +2025-11-05 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/122501 + PR fortran/122524 + * primary.cc (gfc_convert_to_structure_constructor): Correct + whitespace issue. + (gfc_match_rvalue): Remove the attempt to match specific procs + before filling out PDT constructor. Instead, defer this until + resolution with the condition that there not be a following + arglist and more than one procedure in the generic interface. + +2025-11-05 Tobias Burnus <tburnus@baylibre.com> + + PR fortran/122570 + * openmp.cc (resolve_omp_metadirective): Fix 'skip' of + never matchable metadirective variants. + +2025-11-04 Harald Anlauf <anlauf@gmx.de> + + PR fortran/122564 + * resolve.cc (resolve_locality_spec): Delete temporary hash_set. + +2025-11-04 Paul-Antoine Arras <parras@baylibre.com> + + PR fortran/122369 + PR fortran/122508 + * gfortran.h (gfc_rebind_label): Declare new function. + * parse.cc (parse_omp_metadirective_body): Rebind labels to the outer + region. Maintain a vector of metadirective regions. + (gfc_parse_file): Initialise it. + * parse.h (GFC_PARSE_H): Declare it. + * symbol.cc (gfc_get_st_label): Look for existing labels in outer + metadirective regions. + (gfc_rebind_label): Define new function. + (gfc_define_st_label): Accept duplicate labels in metadirective body. + (gfc_reference_st_label): Accept shared DO termination labels in + metadirective body. + +2025-11-03 Steve Kargl <kargls@comcast.net> + + PR fortran/122513 + * resolve.cc (check_default_none_expr): Do not allow an + iterator in a locality spec. Allow a named constant to be + used within the loop. + +2025-11-01 Harald Anlauf <anlauf@gmx.de> + + PR fortran/78640 + * resolve.cc (resolve_fl_procedure): Check function result of a + pure function against F2018:C1585. + +2025-10-31 Yuao Ma <c8ef@outlook.com> + + * intrinsic.texi: Fix typo. + * trans-intrinsic.cc (conv_intrinsic_atomic_cas): Remove unreachable + code. + +2025-10-31 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/122452 + * primary.cc (gfc_match_rvalue): Give priority to specific + procedures in a generic interface with the same name as a + PDT template. If found, use as the procedure instead of the + constructor generated from the PDT template. + +2025-10-30 Mikael Morin <mikael@gcc.gnu.org> + + * trans-array.cc: Cleanup obsolete comment. + +2025-10-29 Yuao Ma <c8ef@outlook.com> + + * trans-expr.cc (gfc_conv_gfc_desc_to_cfi_desc): Remove unreachable + code. + +2025-10-29 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/122165 + * primary.cc (gfc_match_varspec): If the previous component ref + was a type specification parameter, a type inquiry ref cannot + follow. + +2025-10-29 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/122433 + PR fortran/122434 + * decl.cc (gfc_get_pdt_instance): Prevent a PDT component of + the same type as the template from being converted into an + instance. + * resolve.cc (gfc_impure_variable): The result of a pure + function is a valid allocate object since it is pure. + +2025-10-28 Yuao Ma <c8ef@outlook.com> + + PR fortran/122342 + * trans-const.cc (gfc_conv_constant): Create a variable for the + non-char pointer. + +2025-10-28 Paul-Antoine Arras <parras@baylibre.com> + + PR fortran/122439 + * openmp.cc (gfc_resolve_omp_context_selector): Skip selectors that have + OMP_TRAIT_INVALID. + +2025-10-27 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/922290 + PR fortran/95541 + * resolve.cc (resolve_typebound_intrinsic_op): Add pdt_template + to the list of preemted specifics. + * trans-stmt.cc (trans_associate_var): PDT array and string + components are separately allocated for each element of a PDT + array, so copy in and copy out the selector expression. + +2025-10-27 Richard Biener <rguenther@suse.de> + + PR middle-end/122325 + * options.cc (gfc_init_options_struct): Set flag_complex_method + to fortran rules. + +2025-10-26 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/122290 + * decl.cc (variable_decl): Matching component initializer + expressions in PDT templates should be done with gfc_match_expr + to avoid reduction too early. If the expression type is unknown + copy the component typespec. + (gfc_get_pdt_instance): Change comment from a TODO to an + explanation. Insert parameter values in initializers. For + components that are not marked with PDT attributes, do the + full reduction for init expressions. + * primary.cc (gfc_match_actual_arglist): Convert PDT kind exprs + using the component initializer. + * resolve.cc (resolve_typebound_intrinsic_op): Preempt + gfc_check_new_interface for pdt_types as well as entities used + in submodules. + * simplify.cc (get_kind): Remove PDT kind conversion. + +2025-10-25 Harald Anlauf <anlauf@gmx.de> + + PR fortran/114023 + * trans-expr.cc (gfc_trans_pointer_assignment): Always set dtype + when remapping a pointer. For unlimited polymorphic LHS use + elem_len from RHS. + * trans-intrinsic.cc (gfc_conv_is_contiguous_expr): Extend inline + generated code for IS_CONTIGUOUS for pointer arguments to detect + when span differs from the element size. + +2025-10-24 Harald Anlauf <anlauf@gmx.de> + + PR fortran/122386 + * dependency.cc (gfc_ref_needs_temporary_p): Revert r16-518. + * trans-intrinsic.cc (gfc_conv_intrinsic_transfer): Force temporary + for SOURCE not being a simply-contiguous array. + +2025-10-24 Paul-Antoine Arras <parras@baylibre.com> + + PR fortran/121452 + * openmp.cc (resolve_omp_do): Allow CONTINUE as end statement of a + perfectly nested loop. + +2025-10-21 Paul-Antoine Arras <parras@baylibre.com> + + PR c/120180 + PR fortran/122306 + * gfortran.h (enum gfc_exec_op): Add EXEC_OMP_FIRST_OPENMP_EXEC and + EXEC_OMP_LAST_OPENMP_EXEC. + * openmp.cc (gfc_match_omp_context_selector): Remove static. Remove + checks on score. Add cleanup. Remove checks on trait properties. + (gfc_match_omp_context_selector_specification): Remove static. Adjust + calls to gfc_match_omp_context_selector. + (gfc_match_omp_declare_variant): Adjust call to + gfc_match_omp_context_selector_specification. + (match_omp_metadirective): Likewise. + (icode_code_error_callback): Reject all statements except + 'assume' and 'metadirective'. + (gfc_resolve_omp_context_selector): New function. + (resolve_omp_metadirective): Skip metadirectives which context selectors + can be statically resolved to false. Replace metadirective by its body + if only 'nothing' remains. + (gfc_resolve_omp_declare): Call gfc_resolve_omp_context_selector for + each variant. + +2025-10-21 Tobias Burnus <tburnus@baylibre.com> + + * openmp.cc (gfc_omp_directive): Add comment to 'allocate'; + add 6.x unimplemented directives as comment-out entries. + +2025-10-18 Yuao Ma <c8ef@outlook.com> + + * resolve.cc (resolve_conditional): Allow character in cond-expr. + * trans-const.cc (gfc_conv_constant): Handle want_pointer. + * trans-expr.cc (gfc_conv_conditional_expr): Fill se->string_length. + (gfc_conv_string_parameter): Handle COND_EXPR tree code. + +2025-10-17 Josef Melcr <jmelcr02@gmail.com> + + * f95-lang.cc (ATTR_CALLBACK_GOMP_LIST): New attr list + corresponding to the list in builtin-attrs.def. + +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 + * gfortran.h: Add formal_resolved to gfc_symbol. + * resolve.cc (gfc_resolve_formal_arglist): Set it. + (resolve_function): Do not call gfc_get_formal_from_actual_arglist + if we already resolved a formal arglist. + (resolve_call): Likewise. + +2025-05-10 Harald Anlauf <anlauf@gmx.de> + + PR fortran/102891 + * dependency.cc (gfc_ref_needs_temporary_p): Within an array + reference, inquiry references of complex variables generally + need a temporary. + +2025-05-10 Jakub Jelinek <jakub@redhat.com> + + PR fortran/120193 + * trans-types.cc (gfc_init_types): For flag_unsigned use + build_distinct_type_copy or build_variant_type_copy from + gfc_character_types[index_char] if index_char > -1 instead of + gfc_character_types[index_char] or + gfc_build_unsigned_type (&gfc_unsigned_kinds[index]). + +2025-05-08 Harald Anlauf <anlauf@gmx.de> + + PR fortran/120179 + * match.cc (gfc_match_do): Do not attempt to match end-of-statement + twice. + +2025-05-07 Paul Thomas <pault@gcc.gnu.org> + and Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/119948 + * primary.cc (match_variable): Module procedures with sym the + same as result can be treated as variables, although marked + external. + +2025-05-06 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/120049 + * check.cc (gfc_check_c_associated): Modify checks to avoid + ICE and allow use, intrinsic :: iso_c_binding from a separate + module file. + +2025-05-06 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/119928 + * interface.cc (gfc_check_dummy_characteristics): Do not issue + error if one dummy symbol has been generated from an actual + argument and the other one has OPTIONAL, INTENT, ALLOCATABLE, + POINTER, TARGET, VALUE, ASYNCHRONOUS or CONTIGUOUS. + (gfc_get_formal_from_actual_arglist): Do nothing if symbol + is a class. + +2025-05-04 Harald Anlauf <anlauf@gmx.de> + + PR fortran/119986 + * expr.cc (is_subref_array): When searching for array references, + do not terminate early so that inquiry references to complex + components work. + * primary.cc (gfc_variable_attr): A substring reference can refer + to either a scalar or array character variable. Adjust search + accordingly. + +2025-05-01 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/119948 + * resolve.cc (gfc_impure_variable): The result of a module + procedure with an interface declaration is not impure even if + the current namespace is not the same as the symbol's. + 2025-04-25 Harald Anlauf <anlauf@gmx.de> PR fortran/102900 diff --git a/gcc/fortran/arith.cc b/gcc/fortran/arith.cc index 82a8b6f..142f1b0 100644 --- a/gcc/fortran/arith.cc +++ b/gcc/fortran/arith.cc @@ -1565,6 +1565,8 @@ reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind, &op1->where); r->shape = gfc_copy_shape (op1->shape, op1->rank); + if (c->expr->ts.type == BT_CHARACTER) + r->ts.u.cl = c->expr->ts.u.cl; } else { @@ -1572,6 +1574,8 @@ reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), r = gfc_get_array_expr (op1->ts.type, op1->ts.kind, &op1->where); r->shape = gfc_get_shape (op1->rank); + if (op1->ts.type == BT_CHARACTER) + r->ts.u.cl = op1->ts.u.cl; } r->rank = op1->rank; r->corank = op1->corank; @@ -1629,6 +1633,8 @@ reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind, &op2->where); r->shape = gfc_copy_shape (op2->shape, op2->rank); + if (c->expr->ts.type == BT_CHARACTER) + r->ts.u.cl = c->expr->ts.u.cl; } else { @@ -1636,6 +1642,8 @@ reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), r = gfc_get_array_expr (op2->ts.type, op2->ts.kind, &op2->where); r->shape = gfc_get_shape (op2->rank); + if (op2->ts.type == BT_CHARACTER) + r->ts.u.cl = op2->ts.u.cl; } r->rank = op2->rank; r->corank = op2->corank; @@ -1697,11 +1705,15 @@ reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), { /* Handle zero-sized arrays. */ r = gfc_get_array_expr (op1->ts.type, op1->ts.kind, &op1->where); + if (op1->ts.type == BT_CHARACTER) + r->ts.u.cl = op1->ts.u.cl; } else { r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind, &op1->where); + if (c->expr->ts.type == BT_CHARACTER) + r->ts.u.cl = c->expr->ts.u.cl; } r->shape = gfc_copy_shape (op1->shape, op1->rank); r->rank = op1->rank; @@ -1921,6 +1933,29 @@ eval_intrinsic (gfc_intrinsic_op op, || !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2))) goto runtime; + /* For array constructors with explicit type-spec, ensure elements are + converted to the specified type before any operations. This handles + cases like [integer :: ([1.0])] ** 2 where parentheses would otherwise + cause the type-spec to be lost during constant folding. */ + if (op1->expr_type == EXPR_ARRAY && op1->ts.type != BT_UNKNOWN) + gfc_check_constructor_type (op1); + if (op2 != NULL && op2->expr_type == EXPR_ARRAY && op2->ts.type != BT_UNKNOWN) + gfc_check_constructor_type (op2); + + /* For CONCAT operations, also resolve character array constructors to + ensure elements are padded to the specified length before concatenation. + This ensures [character(16):: 'a','b'] // '|' pads to 16 chars first. */ + if (op == INTRINSIC_CONCAT) + { + if (op1->expr_type == EXPR_ARRAY && op1->ts.type == BT_CHARACTER + && op1->ts.u.cl && op1->ts.u.cl->length_from_typespec) + gfc_resolve_character_array_constructor (op1); + if (op2 != NULL && op2->expr_type == EXPR_ARRAY + && op2->ts.type == BT_CHARACTER + && op2->ts.u.cl && op2->ts.u.cl->length_from_typespec) + gfc_resolve_character_array_constructor (op2); + } + if (unary) rc = reduce_unary (eval.f2, op1, &result); else diff --git a/gcc/fortran/array.cc b/gcc/fortran/array.cc index fa177fa..471f0cb 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; } @@ -1333,6 +1344,7 @@ gfc_match_array_constructor (gfc_expr **result) match m; const char *end_delim; bool seen_ts; + gfc_namespace *old_ns = gfc_current_ns; head = NULL; seen_ts = false; @@ -1357,6 +1369,8 @@ gfc_match_array_constructor (gfc_expr **result) /* Try to match an optional "type-spec ::" */ gfc_clear_ts (&ts); m = gfc_match_type_spec (&ts); + gfc_current_ns = old_ns; + if (m == MATCH_YES) { seen_ts = (gfc_match (" ::") == MATCH_YES); @@ -1538,10 +1552,37 @@ check_constructor_type (gfc_constructor_base base, bool convert) { e = c->expr; + /* Simplify non-constant expressions (like parenthesized arrays) so type + conversion can work on the simplified result. This handles cases like + [integer :: ([1.0])] where ([1.0]) is an EXPR_OP that needs to be + simplified to an EXPR_ARRAY before type conversion. */ + if (convert && e->expr_type != EXPR_CONSTANT + && e->expr_type != EXPR_ARRAY) + gfc_simplify_expr (e, 0); + if (e->expr_type == EXPR_ARRAY) { - if (!check_constructor_type (e->value.constructor, convert)) - return false; + /* If the outer constructor has no type-spec (convert=false) and + the nested array has an explicit type-spec, process it separately + so its elements get converted according to its type-spec. This + handles cases like [[character(16) :: ['a','b']]] where the outer + constructor has no type-spec but the inner one does. + gfc_check_constructor_type will also update the global + constructor_ts and cons_state which propagates the type info + to the outer constructor. + For character types, length_from_typespec indicates an explicit + type-spec was provided. */ + if (!convert && e->ts.type == BT_CHARACTER + && e->ts.u.cl && e->ts.u.cl->length_from_typespec) + { + if (!gfc_check_constructor_type (e)) + return false; + } + else + { + if (!check_constructor_type (e->value.constructor, convert)) + return false; + } continue; } @@ -1633,6 +1674,12 @@ check_constructor (gfc_constructor_base ctor, bool (*check_function) (gfc_expr * if (!e) continue; + /* Allow procedures as potential target of a procedure pointer. */ + if (e->expr_type == EXPR_VARIABLE + && e->ts.type == BT_PROCEDURE + && e->symtree->n.sym->attr.flavor == FL_PROCEDURE) + continue; + if (e->expr_type != EXPR_ARRAY) { if (!(*check_function)(e)) @@ -2244,10 +2291,14 @@ gfc_resolve_character_array_constructor (gfc_expr *expr) { gfc_constructor *p; HOST_WIDE_INT found_length; + bool has_ts; gcc_assert (expr->expr_type == EXPR_ARRAY); gcc_assert (expr->ts.type == BT_CHARACTER); + /* Check if we have an explicit type-spec with length. */ + has_ts = expr->ts.u.cl && expr->ts.u.cl->length_from_typespec; + if (expr->ts.u.cl == NULL) { for (p = gfc_constructor_first (expr->value.constructor); @@ -2350,28 +2401,56 @@ got_charlen: if (found_length != -1) for (p = gfc_constructor_first (expr->value.constructor); p; p = gfc_constructor_next (p)) - if (p->expr->expr_type == EXPR_CONSTANT) - { - gfc_expr *cl = NULL; - HOST_WIDE_INT current_length = -1; - bool has_ts; + { + /* For non-constant expressions (like EXPR_OP from concatenation), + try to simplify them first so we can then pad/truncate. */ + if (p->expr->expr_type != EXPR_CONSTANT + && p->expr->ts.type == BT_CHARACTER) + gfc_simplify_expr (p->expr, 0); - if (p->expr->ts.u.cl && p->expr->ts.u.cl->length) + if (p->expr->expr_type == EXPR_CONSTANT) { - cl = p->expr->ts.u.cl->length; - gfc_extract_hwi (cl, ¤t_length); + gfc_expr *cl = NULL; + HOST_WIDE_INT current_length = -1; + + if (p->expr->ts.u.cl && p->expr->ts.u.cl->length) + { + cl = p->expr->ts.u.cl->length; + gfc_extract_hwi (cl, ¤t_length); + } + + /* If gfc_extract_int above set current_length, we implicitly + know the type is BT_INTEGER and it's EXPR_CONSTANT. */ + + if (! cl + || (current_length != -1 && current_length != found_length)) + gfc_set_constant_character_len (found_length, p->expr, + has_ts ? -1 : found_length); } - - /* If gfc_extract_int above set current_length, we implicitly - know the type is BT_INTEGER and it's EXPR_CONSTANT. */ - - has_ts = expr->ts.u.cl->length_from_typespec; - - if (! cl - || (current_length != -1 && current_length != found_length)) - gfc_set_constant_character_len (found_length, p->expr, - has_ts ? -1 : found_length); - } + else if (p->expr->expr_type == EXPR_ARRAY) + { + /* For nested array constructors, propagate the type-spec and + recursively resolve. This handles cases like + [character(16) :: ['a','b']] // "|". The inner constructor + may have BT_UNKNOWN type initially. */ + if (p->expr->ts.type == BT_UNKNOWN + || p->expr->ts.type == BT_CHARACTER) + { + if (p->expr->ts.type == BT_CHARACTER + && p->expr->ts.u.cl + && p->expr->ts.u.cl->length_from_typespec) + { + /* If the inner array has an explicit type-spec, we must + honor it first (e.g. truncate/pad to its length), + before coercing it to the outer length. */ + gfc_resolve_character_array_constructor (p->expr); + } + + p->expr->ts = expr->ts; + gfc_resolve_character_array_constructor (p->expr); + } + } + } } return true; diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc index 299c216..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,44 +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->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; - } + 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 - && (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_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; - } +check_1_error: + + 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) + { + 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; + + 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 (c_ptr_2 && !scalar_check (c_ptr_2, 1)) + 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; @@ -6064,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); @@ -6436,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; @@ -6444,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; @@ -6456,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; } @@ -6518,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; @@ -6537,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..079240c 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; } @@ -1731,10 +1733,12 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, { gfc_symbol *final, *array, *fini_coarray, *byte_stride, *sizes, *strides; gfc_symbol *ptr = NULL, *idx, *idx2, *is_contiguous, *offset, *nelem; + gfc_symbol *result = NULL; gfc_component *comp; gfc_namespace *sub_ns; gfc_code *last_code, *block; char *name; + char *result_name; bool finalizable_comp = false; gfc_expr *ancestor_wrapper = NULL, *rank; gfc_iterator *iter; @@ -1822,7 +1826,6 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, final->attr.function = 1; final->attr.pure = 0; final->attr.recursive = 1; - final->result = final; final->ts.type = BT_INTEGER; final->ts.kind = 4; final->attr.artificial = 1; @@ -1830,6 +1833,26 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, final->attr.if_source = IFSRC_DECL; if (ns->proc_name->attr.flavor == FL_MODULE) final->module = ns->proc_name->name; + + /* Create a separate result symbol instead of using final->result = final. + Self-referencing result symbols (final->result = final) create a cycle + in the symbol structure that causes an ICE in gimplify_call_expr when + the finalizer wrapper is used as a procedure pointer initializer. */ + result_name = xasprintf ("__result_%s", tname); + if (gfc_get_symbol (result_name, sub_ns, &result) != 0) + gfc_internal_error ("Failed to create finalizer result symbol"); + free (result_name); + + if (!gfc_add_flavor (&result->attr, FL_VARIABLE, result->name, + &gfc_current_locus) + || !gfc_add_result (&result->attr, result->name, &gfc_current_locus)) + gfc_internal_error ("Failed to set finalizer result attributes"); + + result->ts = final->ts; + result->attr.artificial = 1; + gfc_set_sym_referenced (result); + gfc_commit_symbol (result); + final->result = result; gfc_set_sym_referenced (final); gfc_commit_symbol (final); @@ -1957,7 +1980,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, /* Set return value to 0. */ last_code = gfc_get_code (EXEC_ASSIGN); - last_code->expr1 = gfc_lval_expr_from_sym (final); + last_code->expr1 = gfc_lval_expr_from_sym (result); last_code->expr2 = gfc_get_int_expr (4, NULL, 0); sub_ns->code = last_code; @@ -2314,6 +2337,7 @@ finish_assumed_rank: { gfc_symbol *stat; gfc_code *block = NULL; + gfc_expr *ptr_expr; if (!ptr) { @@ -2359,14 +2383,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..0e55171 100644 --- a/gcc/fortran/decl.cc +++ b/gcc/fortran/decl.cc @@ -1217,6 +1217,10 @@ match_char_length (gfc_expr **expr, bool *deferred, bool obsolescent_check) goto syntax; } + if (obsolescent_check + && !gfc_notify_std (GFC_STD_F95_OBS, "Old-style character length at %C")) + return MATCH_ERROR; + return MATCH_YES; syntax: @@ -1537,9 +1541,47 @@ gfc_verify_c_interop_param (gfc_symbol *sym) { if (sym->ns->proc_name->attr.is_bind_c == 1) { + bool f2018_allowed = gfc_option.allow_std & ~GFC_STD_OPT_F08; + bool f2018_added = false; + is_c_interop = (gfc_verify_c_interop(&(sym->ts)) ? 1 : 0); - if (is_c_interop != 1) + /* F2018:18.3.6 has the following text: + "(5) any dummy argument without the VALUE attribute corresponds to + a formal parameter of the prototype that is of a pointer type, and + either + • the dummy argument is interoperable with an entity of the + referenced type (ISO/IEC 9899:2011, 6.2.5, 7.19, and 7.20.1) of + the formal parameter (this is equivalent to the F2008 text), + • the dummy argument is a nonallocatable nonpointer variable of + type CHARACTER with assumed character length and the formal + parameter is a pointer to CFI_cdesc_t, + • the dummy argument is allocatable, assumed-shape, assumed-rank, + or a pointer without the CONTIGUOUS attribute, and the formal + parameter is a pointer to CFI_cdesc_t, or + • the dummy argument is assumed-type and not allocatable, + assumed-shape, assumed-rank, or a pointer, and the formal + parameter is a pointer to void," */ + if (is_c_interop == 0 && !sym->attr.value && f2018_allowed) + { + bool as_ar = (sym->as + && (sym->as->type == AS_ASSUMED_SHAPE + || sym->as->type == AS_ASSUMED_RANK)); + bool cond1 = (sym->ts.type == BT_CHARACTER + && !(sym->ts.u.cl && sym->ts.u.cl->length) + && !sym->attr.allocatable + && !sym->attr.pointer); + bool cond2 = (sym->attr.allocatable + || as_ar + || (IS_POINTER (sym) && !sym->attr.contiguous)); + bool cond3 = (sym->ts.type == BT_ASSUMED + && !sym->attr.allocatable + && !sym->attr.pointer + && !as_ar); + f2018_added = cond1 || cond2 || cond3; + } + + if (is_c_interop != 1 && !f2018_added) { /* Make personalized messages to give better feedback. */ if (sym->ts.type == BT_DERIVED) @@ -1723,13 +1765,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 +1788,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; @@ -3083,7 +3143,16 @@ variable_decl (int elem) goto cleanup; } - m = gfc_match_init_expr (&initializer); + if (gfc_comp_struct (gfc_current_state ()) + && gfc_current_block ()->attr.pdt_template) + { + m = gfc_match_expr (&initializer); + if (initializer && initializer->ts.type == BT_UNKNOWN) + initializer->ts = current_ts; + } + else + m = gfc_match_init_expr (&initializer); + if (m == MATCH_NO) { gfc_error ("Expected an initialization expression at %C"); @@ -3161,7 +3230,7 @@ variable_decl (int elem) gfc_error ("BOZ literal constant at %L cannot appear as an " "initializer", &initializer->where); m = MATCH_ERROR; - goto cleanup; + goto cleanup; } param->value = gfc_copy_expr (initializer); } @@ -3772,6 +3841,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 +3894,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 +3951,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,10 +3967,13 @@ 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; match m; + gfc_symtree *s = NULL; type_param_spec_list = NULL; @@ -3863,6 +3981,19 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, actual_param = param_list; sprintf (name, "Pdt%s", pdt->name); + /* Prevent a PDT component of the same type as the template from being + converted into an instance. Doing this results in the component being + lost. */ + if (gfc_current_state () == COMP_DERIVED + && !(gfc_state_stack->previous + && gfc_state_stack->previous->state == COMP_DERIVED) + && gfc_current_block ()->attr.pdt_template) + { + if (ext_param_list) + *ext_param_list = gfc_copy_actual_arglist (param_list); + return MATCH_YES; + } + /* Run through the parameter name list and pick up the actual parameter values or use the default values in the PDT declaration. */ for (; type_param_name_list; @@ -3932,6 +4063,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,9 +4093,15 @@ 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. */ + /* Variable expressions default to BT_PROCEDURE in the absence of an + initializer so allow for this. */ if (kind_expr->ts.type != BT_INTEGER && kind_expr->ts.type != BT_PROCEDURE) { @@ -4004,7 +4151,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) @@ -4027,10 +4183,29 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, goto error_return; } + /* If we are in an interface body, the instance will not have been imported. + Make sure that it is imported implicitly. */ + s = gfc_find_symtree (gfc_current_ns->sym_root, pdt->name); + if (gfc_current_ns->proc_name + && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY + && s && s->import_only && pdt->attr.imported) + { + s = gfc_find_symtree (gfc_current_ns->sym_root, instance->name); + if (!s) + { + gfc_get_sym_tree (instance->name, gfc_current_ns, &s, false, + &gfc_current_locus); + s->n.sym = instance; + } + s->n.sym->attr.imported = 1; + s->import_only = 1; + } + m = MATCH_YES; if (instance->attr.flavor == FL_DERIVED - && instance->attr.pdt_type) + && instance->attr.pdt_type + && instance->components) { instance->refs++; if (ext_param_list) @@ -4042,10 +4217,22 @@ 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; + /* In resolution, the finalizers are copied, according to the type of the + argument, to the instance finalizers. However, they are retained by the + template and procedures are freed there. */ + if (pdt->f2k_derived && pdt->f2k_derived->finalizers) + { + instance->f2k_derived = gfc_get_namespace (NULL, 0); + instance->template_sym = pdt; + *instance->f2k_derived = *pdt->f2k_derived; + } + /* Add the components, replacing the parameters in all expressions with the expressions for their values in 'type_param_spec_list'. */ c1 = pdt->components; @@ -4056,6 +4243,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. */ @@ -4070,30 +4262,36 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, to obtain the instance of the extended type. */ if (gfc_current_state () != COMP_DERIVED && c1 == pdt->components - && (c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS) - && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template + && c1->ts.type == BT_DERIVED + && c1->ts.u.derived && gfc_get_derived_super_type (*sym) == c2->ts.u.derived) { - gfc_formal_arglist *f; + if (c1->ts.u.derived->attr.pdt_template) + { + gfc_formal_arglist *f; - old_param_spec_list = type_param_spec_list; + old_param_spec_list = type_param_spec_list; - /* Obtain a spec list appropriate to the extended type..*/ - actual_param = gfc_copy_actual_arglist (type_param_spec_list); - type_param_spec_list = actual_param; - for (f = c1->ts.u.derived->formal; f && f->next; f = f->next) - actual_param = actual_param->next; - if (actual_param) - { - gfc_free_actual_arglist (actual_param->next); - actual_param->next = NULL; - } + /* Obtain a spec list appropriate to the extended type..*/ + actual_param = gfc_copy_actual_arglist (type_param_spec_list); + type_param_spec_list = actual_param; + for (f = c1->ts.u.derived->formal; f && f->next; f = f->next) + actual_param = actual_param->next; + if (actual_param) + { + gfc_free_actual_arglist (actual_param->next); + actual_param->next = NULL; + } - /* 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); - type_param_spec_list = old_param_spec_list; + /* 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, + &c2->param_list); + type_param_spec_list = old_param_spec_list; + } + else + c2->ts = c1->ts; c2->ts.u.derived->refs++; gfc_set_sym_referenced (c2->ts.u.derived); @@ -4143,20 +4341,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, @@ -4176,6 +4371,9 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, if (!c2->initializer && c1->initializer) c2->initializer = gfc_copy_expr (c1->initializer); + + if (c2->initializer) + gfc_insert_parameter_exprs (c2->initializer, type_param_spec_list); } /* Copy the array spec. */ @@ -4183,6 +4381,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 +4421,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 +4431,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 +4457,67 @@ 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 (!c1->initializer + || c1->initializer->expr_type != EXPR_FUNCTION) + c2->initializer = gfc_default_initializer (&c2->ts); + else + { + gfc_symtree *s; + c2->initializer = gfc_copy_expr (c1->initializer); + s = gfc_find_symtree (pdt->ns->sym_root, + gfc_dt_lower_string (c2->ts.u.derived->name)); + if (s) + c2->initializer->symtree = s; + c2->initializer->ts = c2->ts; + if (!s) + gfc_insert_parameter_exprs (c2->initializer, + type_param_spec_list); + gfc_simplify_expr (params->expr, 1); + } + } 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 (c2->initializer->ts.type == BT_UNKNOWN) + c2->initializer->ts = c2->ts; + gfc_insert_parameter_exprs (c2->initializer, type_param_spec_list); + /* The template initializers are parsed using gfc_match_expr rather + than gfc_match_init_expr. Apply the missing reduction to the + PDT instance initializers. */ + if (!gfc_reduce_init_expr (c2->initializer)) + { + gfc_free_expr (c2->initializer); + goto error_return; + } + gfc_simplify_expr (c2->initializer, 1); + } } + 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; @@ -4612,6 +4875,31 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) return m; } + /* This picks up function declarations with a PDT typespec. Since a + pdt_type has been generated, there is no more to do. Within the + function body, this type must be used for the typespec so that + the "being used before it is defined warning" does not arise. */ + if (ts->type == BT_DERIVED + && sym && sym->attr.pdt_type + && (gfc_current_state () == COMP_CONTAINS + || (gfc_current_state () == COMP_FUNCTION + && gfc_current_block ()->ts.type == BT_DERIVED + && gfc_current_block ()->ts.u.derived == sym + && !gfc_find_symtree (gfc_current_ns->sym_root, + sym->name)))) + { + if (gfc_current_state () == COMP_FUNCTION) + { + gfc_symtree *pdt_st; + pdt_st = gfc_new_symtree (&gfc_current_ns->sym_root, + sym->name); + pdt_st->n.sym = sym; + sym->refs++; + } + ts->u.derived = sym; + return MATCH_YES; + } + /* Defer association of the derived type until the end of the specification block. However, if the derived type can be found, add it to the typespec. */ @@ -4648,7 +4936,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) dt_sym = gfc_find_dt_in_generic (sym); /* Host associated PDTs can get confused with their constructors - because they ar instantiated in the template's namespace. */ + because they are instantiated in the template's namespace. */ if (!dt_sym) { if (gfc_find_symbol (dt_name, NULL, 1, &dt_sym)) @@ -4688,6 +4976,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 +5398,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 +5453,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 (f2018_allowed + && (current_import_state == IMPORT_ALL + || current_import_state == IMPORT_NONE)) + goto C8100; - if (gfc_current_ns->proc_name->attr.module_procedure) + 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 +5484,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 +5552,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 +5571,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 +5604,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 +5616,7 @@ gfc_match_import (void) st->n.sym = sym; sym->refs++; sym->attr.imported = 1; + st->import_only = 1; } goto next_item; @@ -5216,6 +5640,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 +6596,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 +7838,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 +9222,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 +11995,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 +12506,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..2a4ebb0 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; @@ -833,6 +843,8 @@ show_attr (symbol_attribute *attr, const char * module) fputs (" VALUE", dumpfile); if (attr->volatile_) fputs (" VOLATILE", dumpfile); + if (attr->omp_groupprivate) + fputs (" GROUPPRIVATE", dumpfile); if (attr->threadprivate) fputs (" THREADPRIVATE", dumpfile); if (attr->temporary) @@ -928,6 +940,8 @@ show_attr (symbol_attribute *attr, const char * module) fputs (" OMP-DECLARE-TARGET", dumpfile); if (attr->omp_declare_target_link) fputs (" OMP-DECLARE-TARGET-LINK", dumpfile); + if (attr->omp_declare_target_local) + fputs (" OMP-DECLARE-TARGET-LOCAL", dumpfile); if (attr->omp_declare_target_indirect) fputs (" OMP-DECLARE-TARGET-INDIRECT", dumpfile); if (attr->omp_device_type == OMP_DEVICE_TYPE_HOST) @@ -2201,6 +2215,20 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses) fputs (" DEPEND(source)", dumpfile); if (omp_clauses->doacross_source) fputs (" DOACROSS(source:)", dumpfile); + if (omp_clauses->dyn_groupprivate) + { + fputs (" DYN_GROUPPRIVATE(", dumpfile); + if (omp_clauses->fallback != OMP_FALLBACK_NONE) + fputs ("FALLBACK(", dumpfile); + if (omp_clauses->fallback == OMP_FALLBACK_ABORT) + fputs ("ABORT):", dumpfile); + else if (omp_clauses->fallback == OMP_FALLBACK_DEFAULT_MEM) + fputs ("DEFAULT_MEM):", dumpfile); + else if (omp_clauses->fallback == OMP_FALLBACK_NULL) + fputs ("NULL):", dumpfile); + show_expr (omp_clauses->dyn_groupprivate); + fputc (')', dumpfile); + } if (omp_clauses->capture) fputs (" CAPTURE", dumpfile); if (omp_clauses->depobj_update != OMP_DEPEND_UNSET) @@ -4371,6 +4399,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 +4445,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 07e9bac..054276e 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. */ @@ -1194,6 +1233,7 @@ is_subref_array (gfc_expr * e) what follows cannot be a subreference array, unless there is a substring reference. */ if (!seen_array && ref->type == REF_COMPONENT + && ref->next == NULL && ref->u.c.component->ts.type != BT_CHARACTER && ref->u.c.component->ts.type != BT_CLASS && !gfc_bt_struct (ref->u.c.component->ts.type)) @@ -1353,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(). */ @@ -1371,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 @@ -1837,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 @@ -1845,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); @@ -1861,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; } } @@ -1890,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); @@ -1920,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); @@ -1950,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; @@ -2356,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. */ @@ -2366,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) @@ -2522,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 @@ -3029,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; @@ -3505,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) { @@ -4364,7 +4577,8 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue, return false; } - if (lvalue->rank != rvalue->rank && !rank_remap) + if (lvalue->rank != rvalue->rank && !rank_remap + && !(rvalue->expr_type == EXPR_NULL && is_init_expr)) { gfc_error ("Different ranks in pointer assignment at %L", &lvalue->where); return false; @@ -4665,6 +4879,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) @@ -5550,6 +5810,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; @@ -5807,6 +6076,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) { @@ -5828,10 +6098,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; } @@ -6134,6 +6406,14 @@ gfc_is_simply_contiguous (gfc_expr *expr, bool strict, bool permit_element) || (sym->as && sym->as->type == AS_ASSUMED_SHAPE)))) return false; + /* An associate variable may point to a non-contiguous target. */ + if (ar && ar->type == AR_FULL + && sym->attr.associate_var && !sym->attr.contiguous + && sym->assoc + && sym->assoc->target) + return gfc_is_simply_contiguous (sym->assoc->target, strict, + permit_element); + if (!ar || ar->type == AR_FULL) return true; diff --git a/gcc/fortran/f95-lang.cc b/gcc/fortran/f95-lang.cc index 1f09553..06ffc67 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,8 @@ gfc_builtin_function (tree decl) #define ATTR_COLD_NORETURN_NOTHROW_LEAF_LIST \ (ECF_COLD | ECF_NORETURN | \ ECF_NOTHROW | ECF_LEAF) +#define ATTR_CALLBACK_GOMP_LIST (ECF_CB_1_2 | ATTR_NOTHROW_LIST) +#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..b699231 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); @@ -5631,6 +5645,7 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn, WALK_SUBEXPR (co->ext.omp_clauses->num_tasks); WALK_SUBEXPR (co->ext.omp_clauses->priority); WALK_SUBEXPR (co->ext.omp_clauses->detach); + WALK_SUBEXPR (co->ext.omp_clauses->dyn_groupprivate); WALK_SUBEXPR (co->ext.omp_clauses->novariants); WALK_SUBEXPR (co->ext.omp_clauses->nocontext); for (idx = 0; idx < ARRAY_SIZE (list_types); idx++) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 46310a0..72aecfb 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. */ @@ -300,6 +311,7 @@ enum gfc_statement ST_OMP_TASKLOOP, ST_OMP_END_TASKLOOP, ST_OMP_SCAN, ST_OMP_DEPOBJ, ST_OMP_TASKLOOP_SIMD, ST_OMP_END_TASKLOOP_SIMD, ST_OMP_ORDERED_DEPEND, ST_OMP_REQUIRES, ST_PROCEDURE, ST_GENERIC, ST_CRITICAL, ST_END_CRITICAL, + ST_OMP_GROUPPRIVATE, ST_GET_FCN_CHARACTERISTICS, ST_LOCK, ST_UNLOCK, ST_EVENT_POST, ST_EVENT_WAIT, ST_FAIL_IMAGE, ST_FORM_TEAM, ST_CHANGE_TEAM, ST_END_TEAM, ST_SYNC_TEAM, ST_OMP_PARALLEL_MASTER, @@ -721,6 +733,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 +1034,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. */ @@ -1021,8 +1043,10 @@ typedef struct /* Mentioned in OMP DECLARE TARGET. */ unsigned omp_declare_target:1; unsigned omp_declare_target_link:1; + unsigned omp_declare_target_local:1; unsigned omp_declare_target_indirect:1; ENUM_BITFIELD (gfc_omp_device_type) omp_device_type:2; + unsigned omp_groupprivate:1; unsigned omp_allocate:1; /* Mentioned in OACC DECLARE. */ @@ -1467,6 +1491,7 @@ enum OMP_LIST_TASK_REDUCTION, OMP_LIST_DEVICE_RESIDENT, OMP_LIST_LINK, + OMP_LIST_LOCAL, OMP_LIST_USE_DEVICE, OMP_LIST_CACHE, OMP_LIST_IS_DEVICE_PTR, @@ -1593,6 +1618,14 @@ enum gfc_omp_bind_type OMP_BIND_THREAD }; +enum gfc_omp_fallback +{ + OMP_FALLBACK_NONE, + OMP_FALLBACK_ABORT, + OMP_FALLBACK_DEFAULT_MEM, + OMP_FALLBACK_NULL +}; + typedef struct gfc_omp_assumptions { int n_absent, n_contains; @@ -1628,6 +1661,7 @@ typedef struct gfc_omp_clauses struct gfc_expr *detach; struct gfc_expr *depobj; struct gfc_expr *dist_chunk_size; + struct gfc_expr *dyn_groupprivate; struct gfc_expr *message; struct gfc_expr *novariants; struct gfc_expr *nocontext; @@ -1660,6 +1694,7 @@ typedef struct gfc_omp_clauses ENUM_BITFIELD (gfc_omp_at_type) at:2; ENUM_BITFIELD (gfc_omp_severity_type) severity:2; ENUM_BITFIELD (gfc_omp_sched_kind) dist_sched_kind:3; + ENUM_BITFIELD (gfc_omp_fallback) fallback:2; /* OpenACC. */ struct gfc_expr *async_expr; @@ -1906,6 +1941,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 @@ -1936,6 +1972,7 @@ typedef struct gfc_symbol /* List of PDT parameter expressions */ struct gfc_actual_arglist *param_list; + struct gfc_symbol *template_sym; struct gfc_expr *value; /* Parameter/Initializer value */ gfc_array_spec *as; @@ -2020,14 +2057,13 @@ 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. */ unsigned ext_dummy_arglist_mismatch:1; + /* Set if the formal arglist has already been resolved, to avoid + trying to generate it again from actual arguments. */ + unsigned formal_resolved:1; /* Reference counter, used for memory management. @@ -2096,6 +2132,8 @@ typedef struct gfc_common_head char use_assoc, saved, threadprivate; unsigned char omp_declare_target : 1; unsigned char omp_declare_target_link : 1; + unsigned char omp_declare_target_local : 1; + unsigned char omp_groupprivate : 1; ENUM_BITFIELD (gfc_omp_device_type) omp_device_type:2; /* Provide sufficient space to hold "symbol.symbol.eq.1234567890". */ char name[2*GFC_MAX_SYMBOL_LEN + 1 + 14 + 1]; @@ -2177,6 +2215,7 @@ typedef struct gfc_symtree gfc_omp_udr *omp_udr; } n; + unsigned import_only:1; } gfc_symtree; @@ -2204,6 +2243,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? */ @@ -2317,6 +2367,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; @@ -2783,8 +2837,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; @@ -2919,7 +2979,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 @@ -3058,6 +3118,8 @@ typedef struct gfc_forall_iterator { gfc_expr *var, *start, *end, *stride; gfc_loop_annot annot; + /* index-name shadows a variable from outer scope. */ + bool shadow; struct gfc_forall_iterator *next; } gfc_forall_iterator; @@ -3118,7 +3180,8 @@ enum gfc_exec_op EXEC_OACC_DATA, EXEC_OACC_HOST_DATA, EXEC_OACC_LOOP, EXEC_OACC_UPDATE, EXEC_OACC_WAIT, EXEC_OACC_CACHE, EXEC_OACC_ENTER_DATA, EXEC_OACC_EXIT_DATA, EXEC_OACC_ATOMIC, EXEC_OACC_DECLARE, - EXEC_OMP_CRITICAL, EXEC_OMP_DO, EXEC_OMP_FLUSH, EXEC_OMP_MASTER, + EXEC_OMP_CRITICAL, EXEC_OMP_FIRST_OPENMP_EXEC = EXEC_OMP_CRITICAL, + EXEC_OMP_DO, EXEC_OMP_FLUSH, EXEC_OMP_MASTER, EXEC_OMP_ORDERED, EXEC_OMP_PARALLEL, EXEC_OMP_PARALLEL_DO, EXEC_OMP_PARALLEL_SECTIONS, EXEC_OMP_PARALLEL_WORKSHARE, EXEC_OMP_SECTIONS, EXEC_OMP_SINGLE, EXEC_OMP_WORKSHARE, @@ -3149,7 +3212,8 @@ enum gfc_exec_op EXEC_OMP_PARALLEL_MASKED_TASKLOOP, EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD, EXEC_OMP_MASKED_TASKLOOP, EXEC_OMP_MASKED_TASKLOOP_SIMD, EXEC_OMP_SCOPE, EXEC_OMP_UNROLL, EXEC_OMP_TILE, EXEC_OMP_INTEROP, EXEC_OMP_METADIRECTIVE, - EXEC_OMP_ERROR, EXEC_OMP_ALLOCATE, EXEC_OMP_ALLOCATORS, EXEC_OMP_DISPATCH + EXEC_OMP_ERROR, EXEC_OMP_ALLOCATE, EXEC_OMP_ALLOCATORS, EXEC_OMP_DISPATCH, + EXEC_OMP_LAST_OPENMP_EXEC = EXEC_OMP_DISPATCH }; /* Enum Definition for locality types. */ @@ -3291,8 +3355,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; @@ -3417,6 +3483,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 **); @@ -3494,6 +3561,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) @@ -3567,11 +3636,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(); }; @@ -3625,6 +3694,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); @@ -3662,6 +3733,9 @@ bool gfc_add_threadprivate (symbol_attribute *, const char *, locus *); bool gfc_add_omp_declare_target (symbol_attribute *, const char *, locus *); bool gfc_add_omp_declare_target_link (symbol_attribute *, const char *, locus *); +bool gfc_add_omp_declare_target_local (symbol_attribute *, const char *, + locus *); +bool gfc_add_omp_groupprivate (symbol_attribute *, const char *, locus *); bool gfc_add_target (symbol_attribute *, locus *); bool gfc_add_dummy (symbol_attribute *, const char *, locus *); bool gfc_add_generic (symbol_attribute *, const char *, locus *); @@ -3708,6 +3782,7 @@ gfc_st_label *gfc_get_st_label (int); void gfc_free_st_label (gfc_st_label *); void gfc_define_st_label (gfc_st_label *, gfc_sl_type, locus *); bool gfc_reference_st_label (gfc_st_label *, gfc_sl_type); +gfc_st_label *gfc_rebind_label (gfc_st_label *, int); gfc_namespace *gfc_get_namespace (gfc_namespace *, int); gfc_symtree *gfc_new_symtree (gfc_symtree **, const char *); @@ -3895,7 +3970,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/gfortran.texi b/gcc/fortran/gfortran.texi index 841f613..0f7572b 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -1186,7 +1186,6 @@ extensions. @menu * Extensions implemented in GNU Fortran:: * Extensions not implemented in GNU Fortran:: -* Experimental features for future Fortran versions:: @end menu @@ -1242,6 +1241,7 @@ additional compatibility extensions along with those enabled by * Extended I/O specifiers:: * Legacy PARAMETER statements:: * Default exponents:: +* Unsigned integers:: @end menu @node Old-style kind specifications @@ -1839,7 +1839,7 @@ in free form; and the @code{c$}, @code{*$} and @code{!$} sentinels in fixed form, @command{gfortran} needs to be invoked with the @option{-fopenmp} option. This option also arranges for automatic linking of the OpenMP runtime library. -@xref{,,,libgomp,GNU Offloading and Multi Processing Runtime Library}. +@xref{Top,,,libgomp,GNU Offloading and Multi Processing Runtime Library}. The OpenMP Fortran runtime library routines are provided both in a form of a Fortran 90 module named @code{omp_lib} and in a form of @@ -1900,7 +1900,7 @@ sentinels in free form; and the @code{c$}, @code{*$} and @code{!$} sentinels in fixed form, @command{gfortran} needs to be invoked with the @option{-fopenacc} option. This option also arranges for automatic linking of the OpenACC runtime library. -@xref{,,,libgomp,GNU Offloading and Multi Processing Runtime Library}. +@xref{Top,,,libgomp,GNU Offloading and Multi Processing Runtime Library}. The OpenACC Fortran runtime library routines are provided both in a form of a Fortran 90 module named @code{openacc} and in a form of a @@ -2535,6 +2535,141 @@ For compatibility, GNU Fortran supports a default exponent of zero in real constants with @option{-fdec}. For example, @code{9e} would be interpreted as @code{9e0}, rather than an error. +@node Unsigned integers +@subsection Unsigned integers +@cindex Unsigned integers +If the @option{-funsigned} option is given, GNU Fortran supports +unsigned integers according to +@uref{https://j3-fortran.org/doc/year/24/24-116.txt, J3/24-116}. The +data type is called @code{UNSIGNED}. For an unsigned type with @code{n} +bits, it implements integer arithmetic modulo @code{2**n}, comparable +to the @code{unsigned} data type in C. + +The data type has @code{KIND} numbers comparable to other Fortran data +types, which can be selected via the @code{SELECTED_UNSIGNED_KIND} +function. + +Mixed arithmetic, comparisons and assignment between @code{UNSIGNED} +and other types are only possible via explicit conversion. Conversion +from @code{UNSIGNED} to other types is done via type conversion +functions like @code{INT} or @code{REAL}. Conversion from other types +to @code{UNSIGNED} is done via @code{UINT}. Unsigned variables cannot be +used as index variables in @code{DO} loops or as array indices. + +Unsigned numbers have a trailing @code{u} as suffix, optionally followed +by a @code{KIND} number separated by an underscore. + +Input and output can be done using the @samp{I}, @samp{B}, @samp{O} +and @samp{Z} descriptors, plus unformatted I/O. + +Unsigned integers as implemented in gfortran are compatible with flang. + +Here is a small, somewhat contrived example of their use: +@smallexample +program main + use iso_fortran_env, only : uint64 + unsigned(kind=uint64) :: v + v = huge(v) - 32u_uint64 + print *,v +end program main +@end smallexample +@noindent +which outputs the number 18446744073709551583. + +Arithmetic operations work on unsigned integers, also for +exponentiation. As an extension to J3/24-116.txt, unary minus +and exponentiation of unsigned integers are permitted unless +@code{-pedantic} is in force. + +In intrinsic procedures, unsigned arguments are typically permitted +for arguments for the data to be processed, analogous to the +use of @code{REAL} arguments. Unsigned values are prohibited +as index variables in @code{DO} loops and as array indices. + +Unsigned numbers can be read and written using list-directed, +formatted and unformatted I/O. For formatted I/O, the @samp{B}, +@samp{I}, @samp{O} and @samp{Z} descriptors are valid. Negative +values and values that would overflow are rejected with +@code{-pedantic}. + +@code{SELECT CASE} is supported for unsigned integers. + +The following intrinsics take unsigned arguments: +@itemize @bullet +@item @code{BGE}, @pxref{BGE} +@item @code{BGT}, @pxref{BGT} +@item @code{BIT_SIZE}, @pxref{BIT_SIZE} +@item @code{BLE}, @pxref{BLE} +@item @code{BLT}, @pxref{BLT} +@item @code{CMPLX}, @pxref{CMPLX} +@item @code{CSHIFT}, @pxref{CSHIFT} +@item @code{DIGITS}, @pxref{DIGITS} +@item @code{DOT_PRODUCT}, @pxref{DOT_PRODUCT} +@item @code{DSHIFTL}, @pxref{DSHIFTL} +@item @code{DSHIFTR}, @pxref{DSHIFTR} +@item @code{EOSHIFT}, @pxref{EOSHIFT} +@item @code{FINDLOC}, @pxref{FINDLOC} +@item @code{HUGE}, @pxref{HUGE} +@item @code{IALL}, @pxref{IALL} +@item @code{IAND}, @pxref{IAND} +@item @code{IANY}, @pxref{IANY} +@item @code{IBCLR}, @pxref{IBCLR} +@item @code{IBITS}, @pxref{IBITS} +@item @code{IBSET}, @pxref{IBSET} +@item @code{IEOR}, @pxref{IEOR} +@item @code{INT}, @pxref{INT} +@item @code{IOR}, @pxref{IOR} +@item @code{IPARITY}, @pxref{IPARITY} +@item @code{ISHFT}, @pxref{ISHFT} +@item @code{ISHFTC}, @pxref{ISHFTC} +@item @code{MATMUL}, @pxref{MATMUL} +@item @code{MAX}, @pxref{MAX} +@item @code{MAXLOC}, @pxref{MAXLOC} +@item @code{MAXVAL}, @pxref{MAXVAL} +@item @code{MERGE}, @pxref{MERGE} +@item @code{MERGE_BITS}, @pxref{MERGE_BITS} +@item @code{MIN}, @pxref{MIN} +@item @code{MINLOC}, @pxref{MINLOC} +@item @code{MINVAL}, @pxref{MINVAL} +@item @code{MOD}, @pxref{MOD} +@item @code{MODULO}, @pxref{MODULO} +@item @code{MVBITS}, @pxref{MVBITS} +@item @code{NOT}, @pxref{NOT} +@item @code{OUT_OF_RANGE}, @pxref{OUT_OF_RANGE} +@item @code{PRODUCT}, @pxref{PRODUCT} +@item @code{RANDOM_NUMBER}, @pxref{RANDOM_NUMBER} +@item @code{RANGE}, @pxref{RANGE} +@item @code{REAL}, @pxref{REAL} +@item @code{SHIFTA}, @pxref{SHIFTA} +@item @code{SHIFTL}, @pxref{SHIFTL} +@item @code{SHIFTR}, @pxref{SHIFTR} +@item @code{SUM}, @pxref{SUM} +@item @code{TRANSPOSE}, @pxref{TRANSPOSE} +@item @code{TRANSFER}, @pxref{TRANSFER} +@end itemize + +The following intrinsics are enabled with @option{-funsigned}: +@itemize @bullet +@item @code{UINT}, @pxref{UINT} +@item @code{UMASKL}, @pxref{UMASKL} +@item @code{UMASKR}, @pxref{UMASKR} +@item @code{SELECTED_UNSIGNED_KIND}, @pxref{SELECTED_UNSIGNED_KIND} +@end itemize + +The following constants have been added to the intrinsic +@code{ISO_C_BINDING} module: @code{c_unsigned}, +@code{c_unsigned_short}, @code{c_unsigned_char}, +@code{c_unsigned_long}, @code{c_unsigned_long_long}, +@code{c_uintmax_t}, @code{c_uint8_t}, @code{c_uint16_t}, +@code{c_uint32_t}, @code{c_uint64_t}, @code{c_uint128_t}, +@code{c_uint_fast8_t}, @code{c_uint_fast16_t}, @code{c_uint_fast32_t}, +@code{c_uint_fast64_t}, @code{c_uint_fast128_t}, +@code{c_uint_least8_t}, @code{c_uint_least16_t}, @code{c_uint_least32_t}, +@code{c_uint_least64_t} and @code{c_uint_least128_t}. + +The following constants have been added to the intrinsic +@code{ISO_FORTRAN_ENV} module: @code{uint8}, @code{uint16}, +@code{uint32} and @code{uint64}. @node Extensions not implemented in GNU Fortran @section Extensions not implemented in GNU Fortran @@ -2715,157 +2850,6 @@ descriptor occurred, use @code{INQUIRE} to get the file position, count the characters up to the next @code{NEW_LINE} and then start reading from the position marked previously. -@node Experimental features for future Fortran versions -@section Experimental features future Fortran versions -@cindex Future Fortran versions - -GNU Fortran supports some experimental features that have been -proposed and accepted by the J3 standards committee. These -exist to give users a chance to try them out, and to provide -a reference implementation. - -As these features have not been included in the worklist for Fortran -202Y by WG5, there is a chance that a version in any upcoming standard -will differ from what GNU Fortran currently implements. These -features are therefore currently classified as an extension. - -@menu -* Unsigned integers:: -@end menu - -@node Unsigned integers -@subsection Unsigned integers -@cindex Unsigned integers -If the @option{-funsigned} option is given, GNU Fortran supports -unsigned integers according to -@uref{https://j3-fortran.org/doc/year/24/24-116.txt, J3/24-116}. The -data type is called @code{UNSIGNED}. For an unsigned type with @code{n} -bits, it implements integer arithmetic modulo @code{2**n}, comparable -to the @code{unsigned} data type in C. - -The data type has @code{KIND} numbers comparable to other Fortran data -types, which can be selected via the @code{SELECTED_UNSIGNED_KIND} -function. - -Mixed arithmetic, comparisons and assignment between @code{UNSIGNED} -and other types are only possible via explicit conversion. Conversion -from @code{UNSIGNED} to other types is done via type conversion -functions like @code{INT} or @code{REAL}. Conversion from other types -to @code{UNSIGNED} is done via @code{UINT}. Unsigned variables cannot be -used as index variables in @code{DO} loops or as array indices. - -Unsigned numbers have a trailing @code{u} as suffix, optionally followed -by a @code{KIND} number separated by an underscore. - -Input and output can be done using the @samp{I}, @samp{B}, @samp{O} -and @samp{Z} descriptors, plus unformatted I/O. - -Here is a small, somewhat contrived example of their use: -@smallexample -program main - use iso_fortran_env, only : uint64 - unsigned(kind=uint64) :: v - v = huge(v) - 32u_uint64 - print *,v -end program main -@end smallexample -@noindent -which outputs the number 18446744073709551583. - -Arithmetic operations work on unsigned integers, also for -exponentiation. As an extension to J3/24-116.txt, unary minus -and exponentiation of unsigned integers are permitted unless -@code{-pedantic} is in force. - -In intrinsic procedures, unsigned arguments are typically permitted -for arguments for the data to be processed, analogous to the -use of @code{REAL} arguments. Unsigned values are prohibited -as index variables in @code{DO} loops and as array indices. - -Unsigned numbers can be read and written using list-directed, -formatted and unformatted I/O. For formatted I/O, the @samp{B}, -@samp{I}, @samp{O} and @samp{Z} descriptors are valid. Negative -values and values that would overflow are rejected with -@code{-pedantic}. - -@code{SELECT CASE} is supported for unsigned integers. - -The following intrinsics take unsigned arguments: -@itemize @bullet -@item @code{BGE}, @pxref{BGE} -@item @code{BGT}, @pxref{BGT} -@item @code{BIT_SIZE}, @pxref{BIT_SIZE} -@item @code{BLE}, @pxref{BLE} -@item @code{BLT}, @pxref{BLT} -@item @code{CMPLX}, @pxref{CMPLX} -@item @code{CSHIFT}, @pxref{CSHIFT} -@item @code{DIGITS}, @pxref{DIGITS} -@item @code{DOT_PRODUCT}, @pxref{DOT_PRODUCT} -@item @code{DSHIFTL}, @pxref{DSHIFTL} -@item @code{DSHIFTR}, @pxref{DSHIFTR} -@item @code{EOSHIFT}, @pxref{EOSHIFT} -@item @code{FINDLOC}, @pxref{FINDLOC} -@item @code{HUGE}, @pxref{HUGE} -@item @code{IALL}, @pxref{IALL} -@item @code{IAND}, @pxref{IAND} -@item @code{IANY}, @pxref{IANY} -@item @code{IBCLR}, @pxref{IBCLR} -@item @code{IBITS}, @pxref{IBITS} -@item @code{IBSET}, @pxref{IBSET} -@item @code{IEOR}, @pxref{IEOR} -@item @code{INT}, @pxref{INT} -@item @code{IOR}, @pxref{IOR} -@item @code{IPARITY}, @pxref{IPARITY} -@item @code{ISHFT}, @pxref{ISHFT} -@item @code{ISHFTC}, @pxref{ISHFTC} -@item @code{MATMUL}, @pxref{MATMUL} -@item @code{MAX}, @pxref{MAX} -@item @code{MAXLOC}, @pxref{MAXLOC} -@item @code{MAXVAL}, @pxref{MAXVAL} -@item @code{MERGE}, @pxref{MERGE} -@item @code{MERGE_BITS}, @pxref{MERGE_BITS} -@item @code{MIN}, @pxref{MIN} -@item @code{MINLOC}, @pxref{MINLOC} -@item @code{MINVAL}, @pxref{MINVAL} -@item @code{MOD}, @pxref{MOD} -@item @code{MODULO}, @pxref{MODULO} -@item @code{MVBITS}, @pxref{MVBITS} -@item @code{NOT}, @pxref{NOT} -@item @code{OUT_OF_RANGE}, @pxref{OUT_OF_RANGE} -@item @code{PRODUCT}, @pxref{PRODUCT} -@item @code{RANDOM_NUMBER}, @pxref{RANDOM_NUMBER} -@item @code{RANGE}, @pxref{RANGE} -@item @code{REAL}, @pxref{REAL} -@item @code{SHIFTA}, @pxref{SHIFTA} -@item @code{SHIFTL}, @pxref{SHIFTL} -@item @code{SHIFTR}, @pxref{SHIFTR} -@item @code{SUM}, @pxref{SUM} -@item @code{TRANSPOSE}, @pxref{TRANSPOSE} -@item @code{TRANSFER}, @pxref{TRANSFER} -@end itemize - -The following intrinsics are enabled with @option{-funsigned}: -@itemize @bullet -@item @code{UINT}, @pxref{UINT} -@item @code{UMASKL}, @pxref{UMASKL} -@item @code{UMASKR}, @pxref{UMASKR} -@item @code{SELECTED_UNSIGNED_KIND}, @pxref{SELECTED_UNSIGNED_KIND} -@end itemize - -The following constants have been added to the intrinsic -@code{ISO_C_BINDING} module: @code{c_unsigned}, -@code{c_unsigned_short}, @code{c_unsigned_char}, -@code{c_unsigned_long}, @code{c_unsigned_long_long}, -@code{c_uintmax_t}, @code{c_uint8_t}, @code{c_uint16_t}, -@code{c_uint32_t}, @code{c_uint64_t}, @code{c_uint128_t}, -@code{c_uint_fast8_t}, @code{c_uint_fast16_t}, @code{c_uint_fast32_t}, -@code{c_uint_fast64_t}, @code{c_uint_fast128_t}, -@code{c_uint_least8_t}, @code{c_uint_least16_t}, @code{c_uint_least32_t}, -@code{c_uint_least64_t} and @code{c_uint_least128_t}. - -The following constants have been added to the intrinsic -@code{ISO_FORTRAN_ENV} module: @code{uint8}, @code{uint16}, -@code{uint32} and @code{uint64}. @c --------------------------------------------------------------------- @c --------------------------------------------------------------------- diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc index 1e552a3..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; } @@ -1403,77 +1412,82 @@ gfc_check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2, } } - /* Check INTENT. */ - if (s1->attr.intent != s2->attr.intent && !s1->attr.artificial - && !s2->attr.artificial) - { - snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'", - s1->name); - return false; - } + /* A lot of information is missing for artificially generated + formal arguments, let's not look into that. */ - /* Check OPTIONAL attribute. */ - if (s1->attr.optional != s2->attr.optional) + if (!s1->attr.artificial && !s2->attr.artificial) { - snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'", - s1->name); - return false; - } + /* Check INTENT. */ + if (s1->attr.intent != s2->attr.intent) + { + snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'", + s1->name); + return false; + } - /* Check ALLOCATABLE attribute. */ - if (s1->attr.allocatable != s2->attr.allocatable) - { - snprintf (errmsg, err_len, "ALLOCATABLE mismatch in argument '%s'", - s1->name); - return false; - } + /* Check OPTIONAL attribute. */ + if (s1->attr.optional != s2->attr.optional) + { + snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'", + s1->name); + return false; + } - /* Check POINTER attribute. */ - if (s1->attr.pointer != s2->attr.pointer) - { - snprintf (errmsg, err_len, "POINTER mismatch in argument '%s'", - s1->name); - return false; - } + /* Check ALLOCATABLE attribute. */ + if (s1->attr.allocatable != s2->attr.allocatable) + { + snprintf (errmsg, err_len, "ALLOCATABLE mismatch in argument '%s'", + s1->name); + return false; + } - /* Check TARGET attribute. */ - if (s1->attr.target != s2->attr.target) - { - snprintf (errmsg, err_len, "TARGET mismatch in argument '%s'", - s1->name); - return false; - } + /* Check POINTER attribute. */ + if (s1->attr.pointer != s2->attr.pointer) + { + snprintf (errmsg, err_len, "POINTER mismatch in argument '%s'", + s1->name); + return false; + } - /* Check ASYNCHRONOUS attribute. */ - if (s1->attr.asynchronous != s2->attr.asynchronous) - { - snprintf (errmsg, err_len, "ASYNCHRONOUS mismatch in argument '%s'", - s1->name); - return false; - } + /* Check TARGET attribute. */ + if (s1->attr.target != s2->attr.target) + { + snprintf (errmsg, err_len, "TARGET mismatch in argument '%s'", + s1->name); + return false; + } - /* Check CONTIGUOUS attribute. */ - if (s1->attr.contiguous != s2->attr.contiguous) - { - snprintf (errmsg, err_len, "CONTIGUOUS mismatch in argument '%s'", - s1->name); - return false; - } + /* Check ASYNCHRONOUS attribute. */ + if (s1->attr.asynchronous != s2->attr.asynchronous) + { + snprintf (errmsg, err_len, "ASYNCHRONOUS mismatch in argument '%s'", + s1->name); + return false; + } - /* Check VALUE attribute. */ - if (s1->attr.value != s2->attr.value) - { - snprintf (errmsg, err_len, "VALUE mismatch in argument '%s'", - s1->name); - return false; - } + /* Check CONTIGUOUS attribute. */ + if (s1->attr.contiguous != s2->attr.contiguous) + { + snprintf (errmsg, err_len, "CONTIGUOUS mismatch in argument '%s'", + s1->name); + return false; + } - /* Check VOLATILE attribute. */ - if (s1->attr.volatile_ != s2->attr.volatile_) - { - snprintf (errmsg, err_len, "VOLATILE mismatch in argument '%s'", - s1->name); - return false; + /* Check VALUE attribute. */ + if (s1->attr.value != s2->attr.value) + { + snprintf (errmsg, err_len, "VALUE mismatch in argument '%s'", + s1->name); + return false; + } + + /* Check VOLATILE attribute. */ + if (s1->attr.volatile_ != s2->attr.volatile_) + { + snprintf (errmsg, err_len, "VOLATILE mismatch in argument '%s'", + s1->name); + return false; + } } /* Check interface of dummy procedures. */ @@ -2542,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 " @@ -2986,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 @@ -3008,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) @@ -3025,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; @@ -3043,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; @@ -3062,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) @@ -3071,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) @@ -3210,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; @@ -3310,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; @@ -3563,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; } @@ -3601,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; + } + + 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; } - else if (where) + } + + 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) @@ -4760,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; @@ -5849,6 +5967,12 @@ gfc_get_formal_from_actual_arglist (gfc_symbol *sym, char name[GFC_MAX_SYMBOL_LEN + 1]; static int var_num; + /* Do not infer the formal from actual arguments if we are dealing with + classes. */ + + if (sym->ts.type == BT_CLASS) + return; + f = &sym->formal; for (a = actual_args; a != NULL; a = a->next) { 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..c4c000b 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 @@ -1996,7 +2239,7 @@ is different, the value is converted to the kind of @var{ATOM}. program atomic use iso_fortran_env logical(atomic_logical_kind) :: atom[*], prev - call atomic_cas (atom[1], prev, .false., .true.)) + call atomic_cas (atom[1], prev, .false., .true.) end program atomic @end smallexample @@ -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 @@ -15077,7 +15546,7 @@ Fortran 2008 and later @node UINT @section @code{UINT} -- Convert to @code{UNSIGNED} type @fnindex UINT -@cindex, conversion, to unsigned +@cindex conversion, to unsigned @table @asis @item @emph{Synopsis}: @@ -15781,6 +16250,7 @@ The following scalar default-integer named constants: @table @asis @item @code{omp_initial_device} @item @code{omp_invalid_device} +@item @code{omp_default_device} @end table 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..cdb0ba8 100644 --- a/gcc/fortran/lang.opt.urls +++ b/gcc/fortran/lang.opt.urls @@ -1,8 +1,5 @@ ; Autogenerated by regenerate-opt-urls.py from gcc/fortran/lang.opt and generated HTML -A -UrlSuffix(gcc/Preprocessor-Options.html#index-A) - C UrlSuffix(gcc/Preprocessor-Options.html#index-C) LangUrlSuffix_Fortran(gfortran/Preprocessing-Options.html#index-C) @@ -20,7 +17,7 @@ H UrlSuffix(gcc/Preprocessor-Options.html#index-H) LangUrlSuffix_D(gdc/Code-Generation.html#index-H) LangUrlSuffix_Fortran(gfortran/Preprocessing-Options.html#index-H) I -UrlSuffix(gcc/Directory-Options.html#index-I) LangUrlSuffix_D(gdc/Directory-Options.html#index-I) +UrlSuffix(gcc/Directory-Options.html#index-I) LangUrlSuffix_D(gdc/Directory-Options.html#index-I) LangUrlSuffix_Algol68(ga68/Directory-options.html#index-I) J LangUrlSuffix_D(gdc/Directory-Options.html#index-J) @@ -295,6 +292,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) @@ -425,7 +425,7 @@ fcoarray= LangUrlSuffix_Fortran(gfortran/Code-Gen-Options.html#index-fcoarray) fcheck= -LangUrlSuffix_Fortran(gfortran/Code-Gen-Options.html#index-fcheck) +LangUrlSuffix_Fortran(gfortran/Code-Gen-Options.html#index-fcheck) LangUrlSuffix_Algol68(ga68/Runtime-options.html#index-fcheck) fsecond-underscore LangUrlSuffix_Fortran(gfortran/Code-Gen-Options.html#index-fsecond-underscore) diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc index 474ba81..e009c82 100644 --- a/gcc/fortran/match.cc +++ b/gcc/fortran/match.cc @@ -2608,7 +2608,66 @@ cleanup: } -/* Match the header of a FORALL statement. */ +/* Apply type-spec to iterator and create shadow variable if needed. */ + +static void +apply_typespec_to_iterator (gfc_forall_iterator *iter, gfc_typespec *ts, + locus *loc) +{ + char *name; + gfc_expr *v; + gfc_symtree *st; + + /* When a type-spec is provided in DO CONCURRENT/FORALL, F2018 19.4(6) + requires the index-name to have scope limited to the construct, + shadowing any variable with the same name from outer scope. + If the index-name was not previously declared, we can simply set its + type. Otherwise, create a shadow variable with "_" prefix. */ + iter->shadow = false; + v = iter->var; + if (v->ts.type == BT_UNKNOWN) + { + /* Variable not declared in outer scope - just set the type. */ + v->ts.type = v->symtree->n.sym->ts.type = BT_INTEGER; + v->ts.kind = v->symtree->n.sym->ts.kind = ts->kind; + gfc_set_sym_referenced (v->symtree->n.sym); + } + else + { + /* Variable exists in outer scope - must create shadow to comply + with F2018 19.4(6) scoping rules. */ + name = (char *) alloca (strlen (v->symtree->name) + 2); + strcpy (name, "_"); + strcat (name, v->symtree->name); + if (gfc_get_sym_tree (name, NULL, &st, false) != 0) + gfc_internal_error ("Failed to create shadow variable symtree for " + "DO CONCURRENT type-spec at %L", loc); + + v = gfc_get_expr (); + v->where = gfc_current_locus; + v->expr_type = EXPR_VARIABLE; + v->ts.type = st->n.sym->ts.type = ts->type; + v->ts.kind = st->n.sym->ts.kind = ts->kind; + st->n.sym->forall_index = true; + v->symtree = st; + gfc_replace_expr (iter->var, v); + iter->shadow = true; + gfc_set_sym_referenced (st->n.sym); + } + + /* Convert iterator bounds to the specified type. */ + gfc_convert_type (iter->start, ts, 1); + gfc_convert_type (iter->end, ts, 1); + gfc_convert_type (iter->stride, ts, 1); +} + + +/* Match the header of a FORALL statement. In F2008 and F2018, the form of + the header is: + + ([ type-spec :: ] concurrent-control-list [, scalar-mask-expr ] ) + + where type-spec is INTEGER. */ static match match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask) @@ -2616,6 +2675,9 @@ match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask) gfc_forall_iterator *head, *tail, *new_iter; gfc_expr *msk; match m; + gfc_typespec ts; + bool seen_ts = false; + locus loc; gfc_gobble_whitespace (); @@ -2625,12 +2687,40 @@ match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask) if (gfc_match_char ('(') != MATCH_YES) return MATCH_NO; + /* Check for an optional type-spec. */ + gfc_clear_ts (&ts); + loc = gfc_current_locus; + m = gfc_match_type_spec (&ts); + if (m == MATCH_YES) + { + seen_ts = (gfc_match (" ::") == MATCH_YES); + + if (seen_ts) + { + if (!gfc_notify_std (GFC_STD_F2008, "FORALL or DO CONCURRENT " + "construct includes type specification " + "at %L", &loc)) + goto cleanup; + + if (ts.type != BT_INTEGER) + { + gfc_error ("Type-spec at %L must be an INTEGER type", &loc); + goto cleanup; + } + } + } + else if (m == MATCH_ERROR) + goto syntax; + m = match_forall_iterator (&new_iter); if (m == MATCH_ERROR) goto cleanup; if (m == MATCH_NO) goto syntax; + if (seen_ts) + apply_typespec_to_iterator (new_iter, &ts, &loc); + head = tail = new_iter; for (;;) @@ -2644,6 +2734,9 @@ match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask) if (m == MATCH_YES) { + if (seen_ts) + apply_typespec_to_iterator (new_iter, &ts, &loc); + tail->next = new_iter; tail = new_iter; continue; @@ -2892,7 +2985,7 @@ gfc_match_do (void) locus where = gfc_current_locus; if (gfc_match_eos () == MATCH_YES) - break; + goto concurr_ok; else if (gfc_match ("local ( ") == MATCH_YES) { @@ -3141,6 +3234,7 @@ gfc_match_do (void) if (gfc_match_eos () != MATCH_YES) goto concurr_cleanup; +concurr_ok: if (label != NULL && !gfc_reference_st_label (label, ST_LABEL_DO_TARGET)) goto concurr_cleanup; @@ -5292,7 +5386,7 @@ match gfc_match_nullify (void) { gfc_code *tail; - gfc_expr *e, *p; + gfc_expr *e, *p = NULL; match m; tail = NULL; @@ -7170,9 +7264,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; @@ -7191,12 +7287,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; @@ -7238,7 +7334,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) { @@ -7246,9 +7344,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/match.h b/gcc/fortran/match.h index 410361c..314be6b 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -174,6 +174,7 @@ match gfc_match_omp_do_simd (void); match gfc_match_omp_loop (void); match gfc_match_omp_error (void); match gfc_match_omp_flush (void); +match gfc_match_omp_groupprivate (void); match gfc_match_omp_interop (void); match gfc_match_omp_masked (void); match gfc_match_omp_masked_taskloop (void); 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..9b845b5 100644 --- a/gcc/fortran/module.cc +++ b/gcc/fortran/module.cc @@ -2092,8 +2092,9 @@ enum ab_attribute AB_ARRAY_OUTER_DEPENDENCY, AB_MODULE_PROCEDURE, AB_OACC_DECLARE_CREATE, 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_OMP_DECLARE_TARGET_LINK, AB_OMP_DECLARE_TARGET_LOCAL, + AB_PDT_KIND, AB_PDT_LEN, AB_PDT_TYPE, + 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, @@ -2102,7 +2103,7 @@ enum ab_attribute AB_OMP_REQ_MEM_ORDER_SEQ_CST, AB_OMP_REQ_MEM_ORDER_ACQ_REL, AB_OMP_REQ_MEM_ORDER_ACQUIRE, AB_OMP_REQ_MEM_ORDER_RELEASE, AB_OMP_REQ_MEM_ORDER_RELAXED, AB_OMP_DEVICE_TYPE_NOHOST, - AB_OMP_DEVICE_TYPE_HOST, AB_OMP_DEVICE_TYPE_ANY + AB_OMP_DEVICE_TYPE_HOST, AB_OMP_DEVICE_TYPE_ANY, AB_OMP_GROUPPRIVATE }; static const mstring attr_bits[] = @@ -2166,12 +2167,15 @@ static const mstring attr_bits[] = minit ("OACC_DECLARE_DEVICE_RESIDENT", AB_OACC_DECLARE_DEVICE_RESIDENT), minit ("OACC_DECLARE_LINK", AB_OACC_DECLARE_LINK), minit ("OMP_DECLARE_TARGET_LINK", AB_OMP_DECLARE_TARGET_LINK), + minit ("OMP_DECLARE_TARGET_LOCAL", AB_OMP_DECLARE_TARGET_LOCAL), + minit ("OMP_GROUPPRIVATE", AB_OMP_GROUPPRIVATE), minit ("PDT_KIND", AB_PDT_KIND), minit ("PDT_LEN", AB_PDT_LEN), minit ("PDT_TYPE", AB_PDT_TYPE), 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), @@ -2398,12 +2402,18 @@ mio_symbol_attribute (symbol_attribute *attr) MIO_NAME (ab_attribute) (AB_OACC_DECLARE_LINK, attr_bits); if (attr->omp_declare_target_link) MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET_LINK, attr_bits); + if (attr->omp_declare_target_local) + MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET_LOCAL, attr_bits); + if (attr->omp_groupprivate) + MIO_NAME (ab_attribute) (AB_OMP_GROUPPRIVATE, attr_bits); if (attr->pdt_kind) MIO_NAME (ab_attribute) (AB_PDT_KIND, attr_bits); if (attr->pdt_len) 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) @@ -2651,6 +2661,12 @@ mio_symbol_attribute (symbol_attribute *attr) case AB_OMP_DECLARE_TARGET_LINK: attr->omp_declare_target_link = 1; break; + case AB_OMP_DECLARE_TARGET_LOCAL: + attr->omp_declare_target_local = 1; + break; + case AB_OMP_GROUPPRIVATE: + attr->omp_groupprivate = 1; + break; case AB_ARRAY_OUTER_DEPENDENCY: attr->array_outer_dependency =1; break; @@ -2681,6 +2697,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 +3641,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 +3864,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); @@ -5254,6 +5281,8 @@ load_commons (void) if (flags & 2) p->threadprivate = 1; p->omp_device_type = (gfc_omp_device_type) ((flags >> 2) & 3); + if ((flags >> 4) & 1) + p->omp_groupprivate = 1; p->use_assoc = 1; /* Get whether this was a bind(c) common or not. */ @@ -5813,6 +5842,20 @@ read_module (void) || startswith (name, "__vtype_"))) p = name; + /* Include pdt_types if their associated pdt_template is in a + USE, ONLY list. */ + if (p == NULL && name[0] == 'P' + && startswith (name, "Pdt") + && module_list) + { + gfc_use_list *ml = module_list; + for (; ml; ml = ml->next) + if (ml->rename + && !strncmp (&name[3], ml->rename->use_name, + strlen (ml->rename->use_name))) + p = name; + } + /* Skip symtree nodes not in an ONLY clause, unless there is an existing symtree loaded from another USE statement. */ if (p == NULL) @@ -6177,6 +6220,7 @@ write_common_0 (gfc_symtree *st, bool this_module) if (p->threadprivate) flags |= 2; flags |= p->omp_device_type << 2; + flags |= p->omp_groupprivate << 4; mio_integer (&flags); /* Write out whether the common block is bind(c) or not. */ @@ -7277,10 +7321,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..abc27d5 100644 --- a/gcc/fortran/openmp.cc +++ b/gcc/fortran/openmp.cc @@ -59,6 +59,7 @@ struct gfc_omp_directive { and "nothing". */ static const struct gfc_omp_directive gfc_omp_directives[] = { + /* allocate as alias for allocators is also executive. */ {"allocate", GFC_OMP_DIR_DECLARATIVE, ST_OMP_ALLOCATE}, {"allocators", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ALLOCATORS}, {"assumes", GFC_OMP_DIR_INFORMATIONAL, ST_OMP_ASSUMES}, @@ -68,6 +69,7 @@ static const struct gfc_omp_directive gfc_omp_directives[] = { {"cancellation point", GFC_OMP_DIR_EXECUTABLE, ST_OMP_CANCELLATION_POINT}, {"cancel", GFC_OMP_DIR_EXECUTABLE, ST_OMP_CANCEL}, {"critical", GFC_OMP_DIR_EXECUTABLE, ST_OMP_CRITICAL}, + /* {"declare induction", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_INDUCTION}, */ /* {"declare mapper", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_MAPPER}, */ {"declare reduction", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_REDUCTION}, {"declare simd", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_SIMD}, @@ -79,7 +81,11 @@ static const struct gfc_omp_directive gfc_omp_directives[] = { {"do", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DO}, /* "error" becomes GFC_OMP_DIR_EXECUTABLE with at(execution) */ {"error", GFC_OMP_DIR_UTILITY, ST_OMP_ERROR}, + /* {"flatten", GFC_OMP_DIR_EXECUTABLE, ST_OMP_FLATTEN}, */ {"flush", GFC_OMP_DIR_EXECUTABLE, ST_OMP_FLUSH}, + /* {"fuse", GFC_OMP_DIR_EXECUTABLE, ST_OMP_FLUSE}, */ + {"groupprivate", GFC_OMP_DIR_DECLARATIVE, ST_OMP_GROUPPRIVATE}, + /* {"interchange", GFC_OMP_DIR_EXECUTABLE, ST_OMP_INTERCHANGE}, */ {"interop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_INTEROP}, {"loop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_LOOP}, {"masked", GFC_OMP_DIR_EXECUTABLE, ST_OMP_MASKED}, @@ -98,11 +104,15 @@ static const struct gfc_omp_directive gfc_omp_directives[] = { {"section", GFC_OMP_DIR_SUBSIDIARY, ST_OMP_SECTION}, {"simd", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SIMD}, {"single", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SINGLE}, + /* {"split", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SPLIT}, */ + /* {"strip", GFC_OMP_DIR_EXECUTABLE, ST_OMP_STRIP}, */ {"target data", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_DATA}, {"target enter data", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_ENTER_DATA}, {"target exit data", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_EXIT_DATA}, {"target update", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_UPDATE}, {"target", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET}, + /* {"taskgraph", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKGRAPH}, */ + /* {"task iteration", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASK_ITERATION}, */ {"taskloop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKLOOP}, {"taskwait", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKWAIT}, {"taskyield", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKYIELD}, @@ -111,6 +121,7 @@ static const struct gfc_omp_directive gfc_omp_directives[] = { {"threadprivate", GFC_OMP_DIR_DECLARATIVE, ST_OMP_THREADPRIVATE}, {"tile", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TILE}, {"unroll", GFC_OMP_DIR_EXECUTABLE, ST_OMP_UNROLL}, + /* {"workdistribute", GFC_OMP_DIR_EXECUTABLE, ST_OMP_WORKDISTRIBUTE}, */ {"workshare", GFC_OMP_DIR_EXECUTABLE, ST_OMP_WORKSHARE}, }; @@ -185,6 +196,7 @@ gfc_free_omp_clauses (gfc_omp_clauses *c) gfc_free_expr (c->num_teams_lower); gfc_free_expr (c->num_teams_upper); gfc_free_expr (c->device); + gfc_free_expr (c->dyn_groupprivate); gfc_free_expr (c->thread_limit); gfc_free_expr (c->dist_chunk_size); gfc_free_expr (c->grainsize); @@ -1162,6 +1174,8 @@ enum omp_mask2 OMP_CLAUSE_NOVARIANTS, /* OpenMP 5.1 */ OMP_CLAUSE_NOCONTEXT, /* OpenMP 5.1 */ OMP_CLAUSE_INTEROP, /* OpenMP 5.1 */ + OMP_CLAUSE_LOCAL, /* OpenMP 6.0 */ + OMP_CLAUSE_DYN_GROUPPRIVATE, /* OpenMP 6.1 */ /* This must come last. */ OMP_MASK2_LAST }; @@ -3086,6 +3100,22 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, else continue; } + if ((mask & OMP_CLAUSE_DYN_GROUPPRIVATE) + && gfc_match_dupl_check (!c->dyn_groupprivate, + "dyn_groupprivate", true) == MATCH_YES) + { + if (gfc_match ("fallback ( abort ) : ") == MATCH_YES) + c->fallback = OMP_FALLBACK_ABORT; + else if (gfc_match ("fallback ( default_mem ) : ") == MATCH_YES) + c->fallback = OMP_FALLBACK_DEFAULT_MEM; + else if (gfc_match ("fallback ( null ) : ") == MATCH_YES) + c->fallback = OMP_FALLBACK_NULL; + if (gfc_match_expr (&c->dyn_groupprivate) != MATCH_YES) + return MATCH_ERROR; + if (gfc_match (" )") != MATCH_YES) + goto error; + continue; + } break; case 'e': if ((mask & OMP_CLAUSE_ENTER)) @@ -3557,6 +3587,10 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, &c->lists[OMP_LIST_LINK]) == MATCH_YES)) continue; + if ((mask & OMP_CLAUSE_LOCAL) + && (gfc_match_omp_to_link ("local (", &c->lists[OMP_LIST_LOCAL]) + == MATCH_YES)) + continue; break; case 'm': if ((mask & OMP_CLAUSE_MAP) @@ -4474,7 +4508,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 \ @@ -5054,7 +5088,8 @@ cleanup: | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULTMAP \ | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_IN_REDUCTION \ | OMP_CLAUSE_THREAD_LIMIT | OMP_CLAUSE_ALLOCATE \ - | OMP_CLAUSE_HAS_DEVICE_ADDR | OMP_CLAUSE_USES_ALLOCATORS) + | OMP_CLAUSE_HAS_DEVICE_ADDR | OMP_CLAUSE_USES_ALLOCATORS \ + | OMP_CLAUSE_DYN_GROUPPRIVATE) #define OMP_TARGET_DATA_CLAUSES \ (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \ | OMP_CLAUSE_USE_DEVICE_PTR | OMP_CLAUSE_USE_DEVICE_ADDR) @@ -5082,7 +5117,7 @@ cleanup: (omp_mask (OMP_CLAUSE_THREADS) | OMP_CLAUSE_SIMD) #define OMP_DECLARE_TARGET_CLAUSES \ (omp_mask (OMP_CLAUSE_ENTER) | OMP_CLAUSE_LINK | OMP_CLAUSE_DEVICE_TYPE \ - | OMP_CLAUSE_TO | OMP_CLAUSE_INDIRECT) + | OMP_CLAUSE_TO | OMP_CLAUSE_INDIRECT | OMP_CLAUSE_LOCAL) #define OMP_ATOMIC_CLAUSES \ (omp_mask (OMP_CLAUSE_ATOMIC) | OMP_CLAUSE_CAPTURE | OMP_CLAUSE_HINT \ | OMP_CLAUSE_MEMORDER | OMP_CLAUSE_COMPARE | OMP_CLAUSE_FAIL \ @@ -6103,7 +6138,7 @@ gfc_match_omp_declare_target (void) gfc_buffer_error (false); static const int to_enter_link_lists[] - = { OMP_LIST_TO, OMP_LIST_ENTER, OMP_LIST_LINK }; + = { OMP_LIST_TO, OMP_LIST_ENTER, OMP_LIST_LINK, OMP_LIST_LOCAL }; for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists) && (list = to_enter_link_lists[listn], true); ++listn) for (n = c->lists[list]; n; n = n->next) @@ -6112,6 +6147,8 @@ gfc_match_omp_declare_target (void) else if (n->u.common->head) n->u.common->head->mark = 0; + if (c->device_type == OMP_DEVICE_TYPE_UNSET) + c->device_type = OMP_DEVICE_TYPE_ANY; for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists) && (list = to_enter_link_lists[listn], true); ++listn) for (n = c->lists[list]; n; n = n->next) @@ -6120,105 +6157,161 @@ gfc_match_omp_declare_target (void) if (n->sym->attr.in_common) gfc_error_now ("OMP DECLARE TARGET variable at %L is an " "element of a COMMON block", &n->where); + else if (n->sym->attr.omp_groupprivate && list != OMP_LIST_LOCAL) + gfc_error_now ("List item %qs at %L not appear in the %qs clause " + "as it was previously specified in a GROUPPRIVATE " + "directive", n->sym->name, &n->where, + list == OMP_LIST_LINK + ? "link" : list == OMP_LIST_TO ? "to" : "enter"); else if (n->sym->mark) gfc_error_now ("Variable at %L mentioned multiple times in " "clauses of the same OMP DECLARE TARGET directive", &n->where); - else if (n->sym->attr.omp_declare_target - && n->sym->attr.omp_declare_target_link - && list != OMP_LIST_LINK) + else if ((n->sym->attr.omp_declare_target_link + || n->sym->attr.omp_declare_target_local) + && list != OMP_LIST_LINK + && list != OMP_LIST_LOCAL) gfc_error_now ("OMP DECLARE TARGET variable at %L previously " - "mentioned in LINK clause and later in %s clause", - &n->where, list == OMP_LIST_TO ? "TO" : "ENTER"); + "mentioned in %s clause and later in %s clause", + &n->where, + n->sym->attr.omp_declare_target_link ? "LINK" + : "LOCAL", + list == OMP_LIST_TO ? "TO" : "ENTER"); else if (n->sym->attr.omp_declare_target - && !n->sym->attr.omp_declare_target_link - && list == OMP_LIST_LINK) + && (list == OMP_LIST_LINK || list == OMP_LIST_LOCAL)) gfc_error_now ("OMP DECLARE TARGET variable at %L previously " "mentioned in TO or ENTER clause and later in " - "LINK clause", &n->where); - else if (gfc_add_omp_declare_target (&n->sym->attr, n->sym->name, - &n->sym->declared_at)) + "%s clause", &n->where, + list == OMP_LIST_LINK ? "LINK" : "LOCAL"); + else { + if (list == OMP_LIST_TO || list == OMP_LIST_ENTER) + gfc_add_omp_declare_target (&n->sym->attr, n->sym->name, + &n->sym->declared_at); if (list == OMP_LIST_LINK) gfc_add_omp_declare_target_link (&n->sym->attr, n->sym->name, &n->sym->declared_at); + if (list == OMP_LIST_LOCAL) + gfc_add_omp_declare_target_local (&n->sym->attr, n->sym->name, + &n->sym->declared_at); + } + if (n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET + && n->sym->attr.omp_device_type != c->device_type) + { + const char *dt = "any"; + if (n->sym->attr.omp_device_type == OMP_DEVICE_TYPE_NOHOST) + dt = "nohost"; + else if (n->sym->attr.omp_device_type == OMP_DEVICE_TYPE_HOST) + dt = "host"; + if (n->sym->attr.omp_groupprivate) + gfc_error_now ("List item %qs at %L set in previous OMP " + "GROUPPRIVATE directive to the different " + "DEVICE_TYPE %qs", n->sym->name, &n->where, dt); + else + gfc_error_now ("List item %qs at %L set in previous OMP " + "DECLARE TARGET directive to the different " + "DEVICE_TYPE %qs", n->sym->name, &n->where, dt); } - if (c->device_type != OMP_DEVICE_TYPE_UNSET) - { - if (n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET - && n->sym->attr.omp_device_type != c->device_type) - gfc_error_now ("List item %qs at %L set in previous OMP DECLARE " - "TARGET directive to a different DEVICE_TYPE", - n->sym->name, &n->where); - n->sym->attr.omp_device_type = c->device_type; - } - if (c->indirect) + n->sym->attr.omp_device_type = c->device_type; + if (c->indirect && c->device_type != OMP_DEVICE_TYPE_ANY) { - if (n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET - && n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_ANY) - gfc_error_now ("DEVICE_TYPE must be ANY when used with " - "INDIRECT at %L", &n->where); - n->sym->attr.omp_declare_target_indirect = c->indirect; + gfc_error_now ("DEVICE_TYPE must be ANY when used with INDIRECT " + "at %L", &n->where); + c->indirect = 0; } - + n->sym->attr.omp_declare_target_indirect = c->indirect; + if (list == OMP_LIST_LINK && c->device_type == OMP_DEVICE_TYPE_NOHOST) + gfc_error_now ("List item %qs at %L set with NOHOST specified may " + "not appear in a LINK clause", n->sym->name, + &n->where); n->sym->mark = 1; } - else if (n->u.common->omp_declare_target - && n->u.common->omp_declare_target_link - && list != OMP_LIST_LINK) - gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously " - "mentioned in LINK clause and later in %s clause", - &n->where, list == OMP_LIST_TO ? "TO" : "ENTER"); - else if (n->u.common->omp_declare_target - && !n->u.common->omp_declare_target_link - && list == OMP_LIST_LINK) - gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously " - "mentioned in TO or ENTER clause and later in " - "LINK clause", &n->where); - else if (n->u.common->head && n->u.common->head->mark) - gfc_error_now ("COMMON at %L mentioned multiple times in " - "clauses of the same OMP DECLARE TARGET directive", - &n->where); - else - { - n->u.common->omp_declare_target = 1; - n->u.common->omp_declare_target_link = (list == OMP_LIST_LINK); + else /* common block */ + { + if (n->u.common->omp_groupprivate && list != OMP_LIST_LOCAL) + gfc_error_now ("Common block %</%s/%> at %L not appear in the %qs " + "clause as it was previously specified in a " + "GROUPPRIVATE directive", + n->u.common->name, &n->where, + list == OMP_LIST_LINK + ? "link" : list == OMP_LIST_TO ? "to" : "enter"); + else if (n->u.common->head && n->u.common->head->mark) + gfc_error_now ("Common block %</%s/%> at %L mentioned multiple " + "times in clauses of the same OMP DECLARE TARGET " + "directive", n->u.common->name, &n->where); + else if ((n->u.common->omp_declare_target_link + || n->u.common->omp_declare_target_local) + && list != OMP_LIST_LINK + && list != OMP_LIST_LOCAL) + gfc_error_now ("Common block %</%s/%> at %L previously mentioned " + "in %s clause and later in %s clause", + n->u.common->name, &n->where, + n->u.common->omp_declare_target_link ? "LINK" + : "LOCAL", + list == OMP_LIST_TO ? "TO" : "ENTER"); + else if (n->u.common->omp_declare_target + && (list == OMP_LIST_LINK || list == OMP_LIST_LOCAL)) + gfc_error_now ("Common block %</%s/%> at %L previously mentioned " + "in TO or ENTER clause and later in %s clause", + n->u.common->name, &n->where, + list == OMP_LIST_LINK ? "LINK" : "LOCAL"); if (n->u.common->omp_device_type != OMP_DEVICE_TYPE_UNSET && n->u.common->omp_device_type != c->device_type) - gfc_error_now ("COMMON at %L set in previous OMP DECLARE " - "TARGET directive to a different DEVICE_TYPE", - &n->where); + { + const char *dt = "any"; + if (n->u.common->omp_device_type == OMP_DEVICE_TYPE_NOHOST) + dt = "nohost"; + else if (n->u.common->omp_device_type == OMP_DEVICE_TYPE_HOST) + dt = "host"; + if (n->u.common->omp_groupprivate) + gfc_error_now ("Common block %</%s/%> at %L set in previous OMP " + "GROUPPRIVATE directive to the different " + "DEVICE_TYPE %qs", n->u.common->name, &n->where, + dt); + else + gfc_error_now ("Common block %</%s/%> at %L set in previous OMP " + "DECLARE TARGET directive to the different " + "DEVICE_TYPE %qs", n->u.common->name, &n->where, + dt); + } n->u.common->omp_device_type = c->device_type; + if (c->indirect && c->device_type != OMP_DEVICE_TYPE_ANY) + { + gfc_error_now ("DEVICE_TYPE must be ANY when used with INDIRECT " + "at %L", &n->where); + c->indirect = 0; + } + if (list == OMP_LIST_LINK && c->device_type == OMP_DEVICE_TYPE_NOHOST) + gfc_error_now ("Common block %</%s/%> at %L set with NOHOST " + "specified may not appear in a LINK clause", + n->u.common->name, &n->where); + + if (list == OMP_LIST_TO || list == OMP_LIST_ENTER) + n->u.common->omp_declare_target = 1; + if (list == OMP_LIST_LINK) + n->u.common->omp_declare_target_link = 1; + if (list == OMP_LIST_LOCAL) + n->u.common->omp_declare_target_local = 1; + for (s = n->u.common->head; s; s = s->common_next) { s->mark = 1; - if (gfc_add_omp_declare_target (&s->attr, s->name, - &s->declared_at)) - { - if (list == OMP_LIST_LINK) - gfc_add_omp_declare_target_link (&s->attr, s->name, - &s->declared_at); - } - if (s->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET - && s->attr.omp_device_type != c->device_type) - gfc_error_now ("List item %qs at %L set in previous OMP DECLARE" - " TARGET directive to a different DEVICE_TYPE", - s->name, &n->where); + if (list == OMP_LIST_TO || list == OMP_LIST_ENTER) + gfc_add_omp_declare_target (&s->attr, s->name, &n->where); + if (list == OMP_LIST_LINK) + gfc_add_omp_declare_target_link (&s->attr, s->name, &n->where); + if (list == OMP_LIST_LOCAL) + gfc_add_omp_declare_target_local (&s->attr, s->name, &n->where); s->attr.omp_device_type = c->device_type; - - if (c->indirect - && s->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET - && s->attr.omp_device_type != OMP_DEVICE_TYPE_ANY) - gfc_error_now ("DEVICE_TYPE must be ANY when used with " - "INDIRECT at %L", &n->where); s->attr.omp_declare_target_indirect = c->indirect; } } if ((c->device_type || c->indirect) && !c->lists[OMP_LIST_ENTER] && !c->lists[OMP_LIST_TO] - && !c->lists[OMP_LIST_LINK]) + && !c->lists[OMP_LIST_LINK] + && !c->lists[OMP_LIST_LOCAL]) gfc_warning_now (OPT_Wopenmp, "OMP DECLARE TARGET directive at %L with only " "DEVICE_TYPE or INDIRECT clauses is ignored", @@ -6306,9 +6399,8 @@ gfc_match_omp_interop (void) trait-score: score(score-expression) */ -match -gfc_match_omp_context_selector (gfc_omp_set_selector *oss, - bool metadirective_p) +static match +gfc_match_omp_context_selector (gfc_omp_set_selector *oss) { do { @@ -6372,22 +6464,8 @@ gfc_match_omp_context_selector (gfc_omp_set_selector *oss, gfc_error ("expected %<(%> at %C"); return MATCH_ERROR; } - if (gfc_match_expr (&os->score) != MATCH_YES - || !gfc_resolve_expr (os->score) - || os->score->ts.type != BT_INTEGER - || os->score->rank != 0) - { - gfc_error ("%<score%> argument must be constant integer " - "expression at %C"); - return MATCH_ERROR; - } - - if (os->score->expr_type == EXPR_CONSTANT - && mpz_sgn (os->score->value.integer) < 0) - { - gfc_error ("%<score%> argument must be non-negative at %C"); - return MATCH_ERROR; - } + if (gfc_match_expr (&os->score) != MATCH_YES) + return MATCH_ERROR; if (gfc_match (" )") != MATCH_YES) { @@ -6420,6 +6498,8 @@ gfc_match_omp_context_selector (gfc_omp_set_selector *oss, else { gfc_error ("expected identifier at %C"); + free (otp); + os->properties = nullptr; return MATCH_ERROR; } } @@ -6440,6 +6520,8 @@ gfc_match_omp_context_selector (gfc_omp_set_selector *oss, { gfc_error ("expected identifier or string literal " "at %C"); + free (otp); + os->properties = nullptr; return MATCH_ERROR; } @@ -6460,51 +6542,8 @@ gfc_match_omp_context_selector (gfc_omp_set_selector *oss, if (gfc_match_expr (&otp->expr) != MATCH_YES) { gfc_error ("expected expression at %C"); - return MATCH_ERROR; - } - if (!gfc_resolve_expr (otp->expr) - || (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR - && otp->expr->ts.type != BT_LOGICAL) - || (property_kind == OMP_TRAIT_PROPERTY_DEV_NUM_EXPR - && otp->expr->ts.type != BT_INTEGER) - || otp->expr->rank != 0 - || (!metadirective_p - && otp->expr->expr_type != EXPR_CONSTANT)) - { - if (metadirective_p) - { - if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR) - gfc_error ("property must be a " - "logical expression at %L", - &otp->expr->where); - else - gfc_error ("property must be an " - "integer expression at %L", - &otp->expr->where); - } - else - { - if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR) - gfc_error ("property must be a constant " - "logical expression at %L", - &otp->expr->where); - else - gfc_error ("property must be a constant " - "integer expression at %L", - &otp->expr->where); - } - return MATCH_ERROR; - } - /* Device number must be conforming, which includes - omp_initial_device (-1) and omp_invalid_device (-4). */ - if (property_kind == OMP_TRAIT_PROPERTY_DEV_NUM_EXPR - && otp->expr->expr_type == EXPR_CONSTANT - && mpz_sgn (otp->expr->value.integer) < 0 - && mpz_cmp_si (otp->expr->value.integer, -1) != 0 - && mpz_cmp_si (otp->expr->value.integer, -4) != 0) - { - gfc_error ("property must be a conforming device number " - "at %C"); + free (otp); + os->properties = nullptr; return MATCH_ERROR; } break; @@ -6580,9 +6619,8 @@ gfc_match_omp_context_selector (gfc_omp_set_selector *oss, implementation user */ -match -gfc_match_omp_context_selector_specification (gfc_omp_set_selector **oss_head, - bool metadirective_p) +static match +gfc_match_omp_context_selector_specification (gfc_omp_set_selector **oss_head) { do { @@ -6619,7 +6657,7 @@ gfc_match_omp_context_selector_specification (gfc_omp_set_selector **oss_head, oss->code = set; *oss_head = oss; - if (gfc_match_omp_context_selector (oss, metadirective_p) != MATCH_YES) + if (gfc_match_omp_context_selector (oss) != MATCH_YES) return MATCH_ERROR; m = gfc_match (" }"); @@ -6750,8 +6788,7 @@ gfc_match_omp_declare_variant (void) return MATCH_ERROR; } has_match = true; - if (gfc_match_omp_context_selector_specification (&odv->set_selectors, - false) + if (gfc_match_omp_context_selector_specification (&odv->set_selectors) != MATCH_YES) return MATCH_ERROR; if (gfc_match (" )") != MATCH_YES) @@ -6982,13 +7019,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; } @@ -7046,7 +7079,7 @@ match_omp_metadirective (bool begin_p) if (!default_p) { - if (gfc_match_omp_context_selector_specification (&selectors, true) + if (gfc_match_omp_context_selector_specification (&selectors) != MATCH_YES) return MATCH_ERROR; @@ -7158,32 +7191,44 @@ gfc_match_omp_metadirective (void) return match_omp_metadirective (false); } -match -gfc_match_omp_threadprivate (void) +/* Match 'omp threadprivate' or 'omp groupprivate'. */ +static match +gfc_match_omp_thread_group_private (bool is_groupprivate) { locus old_loc; char n[GFC_MAX_SYMBOL_LEN+1]; gfc_symbol *sym; match m; gfc_symtree *st; + struct sym_loc_t { gfc_symbol *sym; gfc_common_head *com; locus loc; }; + auto_vec<sym_loc_t> syms; old_loc = gfc_current_locus; - m = gfc_match (" ("); + m = gfc_match (" ( "); if (m != MATCH_YES) return m; for (;;) { + locus sym_loc = gfc_current_locus; m = gfc_match_symbol (&sym, 0); switch (m) { case MATCH_YES: if (sym->attr.in_common) - gfc_error_now ("Threadprivate variable at %C is an element of " - "a COMMON block"); - else if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at)) + gfc_error_now ("%qs variable at %L is an element of a COMMON block", + is_groupprivate ? "groupprivate" : "threadprivate", + &sym_loc); + else if (!is_groupprivate + && !gfc_add_threadprivate (&sym->attr, sym->name, &sym_loc)) goto cleanup; + else if (is_groupprivate) + { + if (!gfc_add_omp_groupprivate (&sym->attr, sym->name, &sym_loc)) + goto cleanup; + syms.safe_push ({sym, nullptr, sym_loc}); + } goto next_item; case MATCH_NO: break; @@ -7200,12 +7245,20 @@ gfc_match_omp_threadprivate (void) st = gfc_find_symtree (gfc_current_ns->common_root, n); if (st == NULL) { - gfc_error ("COMMON block /%s/ not found at %C", n); + gfc_error ("COMMON block /%s/ not found at %L", n, &sym_loc); goto cleanup; } - st->n.common->threadprivate = 1; + syms.safe_push ({nullptr, st->n.common, sym_loc}); + if (is_groupprivate) + st->n.common->omp_groupprivate = 1; + else + st->n.common->threadprivate = 1; for (sym = st->n.common->head; sym; sym = sym->common_next) - if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at)) + if (!is_groupprivate + && !gfc_add_threadprivate (&sym->attr, sym->name, &sym_loc)) + goto cleanup; + else if (is_groupprivate + && !gfc_add_omp_groupprivate (&sym->attr, sym->name, &sym_loc)) goto cleanup; next_item: @@ -7215,16 +7268,89 @@ gfc_match_omp_threadprivate (void) goto syntax; } + if (is_groupprivate) + { + gfc_omp_clauses *c; + m = gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_DEVICE_TYPE)); + if (m == MATCH_ERROR) + return MATCH_ERROR; + + if (c->device_type == OMP_DEVICE_TYPE_UNSET) + c->device_type = OMP_DEVICE_TYPE_ANY; + + for (size_t i = 0; i < syms.length (); i++) + if (syms[i].sym) + { + sym_loc_t &n = syms[i]; + if (n.sym->attr.in_common) + gfc_error_now ("Variable %qs at %L is an element of a COMMON " + "block", n.sym->name, &n.loc); + else if (n.sym->attr.omp_declare_target + || n.sym->attr.omp_declare_target_link) + gfc_error_now ("List item %qs at %L implies OMP DECLARE TARGET " + "with the LOCAL clause, but it has been specified" + " with a different clause before", + n.sym->name, &n.loc); + if (n.sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET + && n.sym->attr.omp_device_type != c->device_type) + { + const char *dt = "any"; + if (n.sym->attr.omp_device_type == OMP_DEVICE_TYPE_HOST) + dt = "host"; + else if (n.sym->attr.omp_device_type == OMP_DEVICE_TYPE_NOHOST) + dt = "nohost"; + gfc_error_now ("List item %qs at %L set in previous OMP DECLARE " + "TARGET directive to the different DEVICE_TYPE %qs", + n.sym->name, &n.loc, dt); + } + gfc_add_omp_declare_target_local (&n.sym->attr, n.sym->name, + &n.loc); + n.sym->attr.omp_device_type = c->device_type; + } + else /* Common block. */ + { + sym_loc_t &n = syms[i]; + if (n.com->omp_declare_target + || n.com->omp_declare_target_link) + gfc_error_now ("List item %</%s/%> at %L implies OMP DECLARE " + "TARGET with the LOCAL clause, but it has been " + "specified with a different clause before", + n.com->name, &n.loc); + if (n.com->omp_device_type != OMP_DEVICE_TYPE_UNSET + && n.com->omp_device_type != c->device_type) + { + const char *dt = "any"; + if (n.com->omp_device_type == OMP_DEVICE_TYPE_HOST) + dt = "host"; + else if (n.com->omp_device_type == OMP_DEVICE_TYPE_NOHOST) + dt = "nohost"; + gfc_error_now ("List item %qs at %L set in previous OMP DECLARE" + " TARGET directive to the different DEVICE_TYPE " + "%qs", n.com->name, &n.loc, dt); + } + n.com->omp_declare_target_local = 1; + n.com->omp_device_type = c->device_type; + for (gfc_symbol *s = n.com->head; s; s = s->common_next) + { + gfc_add_omp_declare_target_local (&s->attr, s->name, &n.loc); + s->attr.omp_device_type = c->device_type; + } + } + free (c); + } + if (gfc_match_omp_eos () != MATCH_YES) { - gfc_error ("Unexpected junk after OMP THREADPRIVATE at %C"); + gfc_error ("Unexpected junk after OMP %s at %C", + is_groupprivate ? "GROUPPRIVATE" : "THREADPRIVATE"); goto cleanup; } return MATCH_YES; syntax: - gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C"); + gfc_error ("Syntax error in !$OMP %s list at %C", + is_groupprivate ? "GROUPPRIVATE" : "THREADPRIVATE"); cleanup: gfc_current_locus = old_loc; @@ -7233,6 +7359,20 @@ cleanup: match +gfc_match_omp_groupprivate (void) +{ + return gfc_match_omp_thread_group_private (true); +} + + +match +gfc_match_omp_threadprivate (void) +{ + return gfc_match_omp_thread_group_private (false); +} + + +match gfc_match_omp_parallel (void) { return match_omp (EXEC_OMP_PARALLEL, OMP_PARALLEL_CLAUSES); @@ -8409,9 +8549,9 @@ resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns, } /* Assume that a constant expression in the range 1 (omp_default_mem_alloc) - to 8 (omp_thread_mem_alloc) range, or 200 (ompx_gnu_pinned_mem_alloc) is - fine. The original symbol name is already lost during matching via - gfc_match_expr. */ + to GOMP_OMP_PREDEF_ALLOC_MAX, or GOMP_OMPX_PREDEF_ALLOC_MIN to + GOMP_OMPX_PREDEF_ALLOC_MAX is fine. The original symbol name is already + lost during matching via gfc_match_expr. */ static bool is_predefined_allocator (gfc_expr *expr) { @@ -8542,7 +8682,8 @@ gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list) if (n->sym->attr.in_common || n->sym->attr.save || n->sym->ns->save_all || (n->sym->ns->proc_name && (n->sym->ns->proc_name->attr.flavor == FL_PROGRAM - || n->sym->ns->proc_name->attr.flavor == FL_MODULE))) + || n->sym->ns->proc_name->attr.flavor == FL_MODULE + || n->sym->ns->proc_name->attr.flavor == FL_BLOCK_DATA))) { bool com = n->sym->attr.in_common; if (!n->u2.allocator) @@ -8556,6 +8697,30 @@ gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list) &n->u2.allocator->where, com ? "/" : "", com ? n->sym->common_head->name : n->sym->name, com ? "/" : "", &n->where); + /* Only local static variables might use omp_cgroup_mem_alloc (6), + omp_pteam_mem_alloc (7), or omp_thread_mem_alloc (8). */ + else if ((!ns->proc_name + || ns->proc_name->attr.flavor == FL_PROGRAM + || ns->proc_name->attr.flavor == FL_BLOCK_DATA + || ns->proc_name->attr.flavor == FL_MODULE + || com) + && mpz_cmp_si (n->u2.allocator->value.integer, + 6 /* cgroup */) >= 0 + && mpz_cmp_si (n->u2.allocator->value.integer, + 8 /* thread */) <= 0) + { + const char *alloc_name[] = {"omp_cgroup_mem_alloc", + "omp_pteam_mem_alloc", + "omp_thread_mem_alloc" }; + gfc_error ("Predefined allocator %qs in ALLOCATOR clause at %L, " + "used for list item %<%s%s%s%> at %L, may only be used" + " for local static variables", + alloc_name[mpz_get_ui (n->u2.allocator->value.integer) + - 6 /* cgroup */], &n->u2.allocator->where, + com ? "/" : "", + com ? n->sym->common_head->name : n->sym->name, + com ? "/" : "", &n->where); + } while (n->sym->attr.in_common && n->next && n->next->sym && n->sym->common_head == n->next->sym->common_head) n = n->next; @@ -8604,7 +8769,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, "TO", "FROM", "INCLUSIVE", "EXCLUSIVE", "REDUCTION", "REDUCTION" /*inscan*/, "REDUCTION" /*task*/, "IN_REDUCTION", "TASK_REDUCTION", - "DEVICE_RESIDENT", "LINK", "USE_DEVICE", + "DEVICE_RESIDENT", "LINK", "LOCAL", "USE_DEVICE", "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR", "NONTEMPORAL", "ALLOCATE", "HAS_DEVICE_ADDR", "ENTER", "USES_ALLOCATORS", "INIT", "USE", "DESTROY", "INTEROP", "ADJUST_ARGS" }; @@ -8811,6 +8976,9 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, } if (omp_clauses->num_threads) resolve_positive_int_expr (omp_clauses->num_threads, "NUM_THREADS"); + if (omp_clauses->dyn_groupprivate) + resolve_nonnegative_int_expr (omp_clauses->dyn_groupprivate, + "DYN_GROUPPRIVATE"); if (omp_clauses->chunk_size) { gfc_expr *expr = omp_clauses->chunk_size; @@ -8895,15 +9063,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); @@ -11416,82 +11590,10 @@ icode_code_error_callback (gfc_code **codep, /* Errors have already been diagnosed in match_exit_cycle. */ state->errorp = true; break; - case EXEC_OMP_CRITICAL: - case EXEC_OMP_DO: - case EXEC_OMP_FLUSH: - case EXEC_OMP_MASTER: - case EXEC_OMP_ORDERED: - case EXEC_OMP_PARALLEL: - case EXEC_OMP_PARALLEL_DO: - case EXEC_OMP_PARALLEL_SECTIONS: - case EXEC_OMP_PARALLEL_WORKSHARE: - case EXEC_OMP_SECTIONS: - case EXEC_OMP_SINGLE: - case EXEC_OMP_WORKSHARE: - case EXEC_OMP_ATOMIC: - case EXEC_OMP_BARRIER: - case EXEC_OMP_END_NOWAIT: - case EXEC_OMP_END_SINGLE: - case EXEC_OMP_TASK: - case EXEC_OMP_TASKWAIT: - case EXEC_OMP_TASKYIELD: - case EXEC_OMP_CANCEL: - case EXEC_OMP_CANCELLATION_POINT: - case EXEC_OMP_TASKGROUP: - case EXEC_OMP_SIMD: - case EXEC_OMP_DO_SIMD: - case EXEC_OMP_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET: - case EXEC_OMP_TARGET_DATA: - case EXEC_OMP_TEAMS: - case EXEC_OMP_DISTRIBUTE: - case EXEC_OMP_DISTRIBUTE_SIMD: - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET_TEAMS: - case EXEC_OMP_TEAMS_DISTRIBUTE: - case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET_UPDATE: - case EXEC_OMP_END_CRITICAL: - case EXEC_OMP_TARGET_ENTER_DATA: - case EXEC_OMP_TARGET_EXIT_DATA: - case EXEC_OMP_TARGET_PARALLEL: - case EXEC_OMP_TARGET_PARALLEL_DO: - case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: - case EXEC_OMP_TARGET_SIMD: - case EXEC_OMP_TASKLOOP: - case EXEC_OMP_TASKLOOP_SIMD: - case EXEC_OMP_SCAN: - case EXEC_OMP_DEPOBJ: - case EXEC_OMP_PARALLEL_MASTER: - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP: - case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: - case EXEC_OMP_MASTER_TASKLOOP: - case EXEC_OMP_MASTER_TASKLOOP_SIMD: - case EXEC_OMP_LOOP: - case EXEC_OMP_PARALLEL_LOOP: - case EXEC_OMP_TEAMS_LOOP: - case EXEC_OMP_TARGET_PARALLEL_LOOP: - case EXEC_OMP_TARGET_TEAMS_LOOP: - case EXEC_OMP_MASKED: - case EXEC_OMP_PARALLEL_MASKED: - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP: - case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: - case EXEC_OMP_MASKED_TASKLOOP: - case EXEC_OMP_MASKED_TASKLOOP_SIMD: - case EXEC_OMP_SCOPE: - case EXEC_OMP_ERROR: - case EXEC_OMP_DISPATCH: - gfc_error ("%s cannot contain OpenMP directive in intervening code " - "at %L", - state->name, &code->loc); - state->errorp = true; + case EXEC_OMP_ASSUME: + case EXEC_OMP_METADIRECTIVE: + /* Per OpenMP 6.0, some non-executable directives are allowed in + intervening code. */ break; case EXEC_CALL: /* Per OpenMP 5.2, the "omp_" prefix is reserved, so we don't have to @@ -11507,7 +11609,14 @@ icode_code_error_callback (gfc_code **codep, } break; default: - break; + if (code->op >= EXEC_OMP_FIRST_OPENMP_EXEC + && code->op <= EXEC_OMP_LAST_OPENMP_EXEC) + { + gfc_error ("%s cannot contain OpenMP directive in intervening code " + "at %L", + state->name, &code->loc); + state->errorp = true; + } } return 0; } @@ -12259,7 +12368,8 @@ resolve_omp_do (gfc_code *code) name, i, &code->loc); goto fail; } - else if (next != do_code->block->next || next->next) + else if (next != do_code->block->next + || (next->next && next->next->op != EXEC_CONTINUE)) /* Imperfectly nested loop found. */ { /* Only diagnose violation of imperfect nesting constraints once. */ @@ -12310,16 +12420,166 @@ resolve_omp_do (gfc_code *code) non_generated_count); } +/* Resolve the context selector. In particular, SKIP_P is set to true, + the context can never be matched. */ + +static void +gfc_resolve_omp_context_selector (gfc_omp_set_selector *oss, + bool is_metadirective, bool *skip_p) +{ + if (skip_p) + *skip_p = false; + for (gfc_omp_set_selector *set_selector = oss; set_selector; + set_selector = set_selector->next) + for (gfc_omp_selector *os = set_selector->trait_selectors; os; os = os->next) + { + if (os->score) + { + if (!gfc_resolve_expr (os->score) + || os->score->ts.type != BT_INTEGER + || os->score->rank != 0) + { + gfc_error ("%<score%> argument must be constant integer " + "expression at %L", &os->score->where); + gfc_free_expr (os->score); + os->score = nullptr; + } + else if (os->score->expr_type == EXPR_CONSTANT + && mpz_sgn (os->score->value.integer) < 0) + { + gfc_error ("%<score%> argument must be non-negative at %L", + &os->score->where); + gfc_free_expr (os->score); + os->score = nullptr; + } + } + + if (os->code == OMP_TRAIT_INVALID) + break; + enum omp_tp_type property_kind = omp_ts_map[os->code].tp_type; + gfc_omp_trait_property *otp = os->properties; + + if (!otp) + continue; + switch (property_kind) + { + case OMP_TRAIT_PROPERTY_DEV_NUM_EXPR: + case OMP_TRAIT_PROPERTY_BOOL_EXPR: + if (!gfc_resolve_expr (otp->expr) + || (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR + && otp->expr->ts.type != BT_LOGICAL) + || (property_kind == OMP_TRAIT_PROPERTY_DEV_NUM_EXPR + && otp->expr->ts.type != BT_INTEGER) + || otp->expr->rank != 0 + || (!is_metadirective && otp->expr->expr_type != EXPR_CONSTANT)) + { + if (is_metadirective) + { + if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR) + gfc_error ("property must be a " + "logical expression at %L", + &otp->expr->where); + else + gfc_error ("property must be an " + "integer expression at %L", + &otp->expr->where); + } + else + { + if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR) + gfc_error ("property must be a constant " + "logical expression at %L", + &otp->expr->where); + else + gfc_error ("property must be a constant " + "integer expression at %L", + &otp->expr->where); + } + /* Prevent later ICEs. */ + gfc_expr *e; + if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR) + e = gfc_get_logical_expr (gfc_default_logical_kind, + &otp->expr->where, true); + else + e = gfc_get_int_expr (gfc_default_integer_kind, + &otp->expr->where, 0); + gfc_free_expr (otp->expr); + otp->expr = e; + continue; + } + /* Device number must be conforming, which includes + omp_initial_device (-1), omp_invalid_device (-4), + and omp_default_device (-5). */ + if (property_kind == OMP_TRAIT_PROPERTY_DEV_NUM_EXPR + && otp->expr->expr_type == EXPR_CONSTANT + && mpz_sgn (otp->expr->value.integer) < 0 + && mpz_cmp_si (otp->expr->value.integer, -1) != 0 + && mpz_cmp_si (otp->expr->value.integer, -4) != 0 + && mpz_cmp_si (otp->expr->value.integer, -5) != 0) + gfc_error ("property must be a conforming device number at %L", + &otp->expr->where); + break; + default: + break; + } + /* This only handles one specific case: User condition. + FIXME: Handle more cases by calling omp_context_selector_matches; + unfortunately, we cannot generate the tree here as, e.g., PARM_DECL + backend decl are not available at this stage - but might be used in, + e.g. user conditions. See PR122361. */ + if (skip_p && otp + && os->code == OMP_TRAIT_USER_CONDITION + && otp->expr->expr_type == EXPR_CONSTANT + && otp->expr->value.logical == false) + *skip_p = true; + } +} + + static void resolve_omp_metadirective (gfc_code *code, gfc_namespace *ns) { gfc_omp_variant *variant = code->ext.omp_variants; + gfc_omp_variant *prev_variant = variant; while (variant) { + bool skip; + gfc_resolve_omp_context_selector (variant->selectors, true, &skip); gfc_code *variant_code = variant->code; gfc_resolve_code (variant_code, ns); - variant = variant->next; + if (skip) + { + /* The following should only be true if an error occurred + as the 'otherwise' clause should always match. */ + if (variant == code->ext.omp_variants && !variant->next) + break; + gfc_omp_variant *tmp = variant; + if (variant == code->ext.omp_variants) + variant = prev_variant = code->ext.omp_variants = variant->next; + else + variant = prev_variant->next = variant->next; + gfc_free_omp_set_selector_list (tmp->selectors); + free (tmp); + } + else + { + prev_variant = variant; + variant = variant->next; + } + } + /* Replace metadirective by its body if only 'nothing' remains. */ + if (!code->ext.omp_variants->next && code->ext.omp_variants->stmt == ST_NONE) + { + gfc_code *next = code->next; + gfc_code *inner = code->ext.omp_variants->code; + gfc_free_omp_set_selector_list (code->ext.omp_variants->selectors); + free (code->ext.omp_variants); + *code = *inner; + free (inner); + while (code->next) + code = code->next; + code->next = next; } } @@ -12756,9 +13016,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) @@ -13084,6 +13356,9 @@ gfc_resolve_omp_declare (gfc_namespace *ns) gfc_omp_declare_variant *odv; gfc_omp_namelist *range_begin = NULL; + + for (odv = ns->omp_declare_variant; odv; odv = odv->next) + gfc_resolve_omp_context_selector (odv->set_selectors, false, nullptr); for (odv = ns->omp_declare_variant; odv; odv = odv->next) for (gfc_omp_namelist *n = odv->adjust_args_list; n != NULL; n = n->next) { diff --git a/gcc/fortran/options.cc b/gcc/fortran/options.cc index ddddc1c..59c6462 100644 --- a/gcc/fortran/options.cc +++ b/gcc/fortran/options.cc @@ -133,6 +133,7 @@ gfc_init_options_struct (struct gcc_options *opts) opts->frontend_set_flag_errno_math = true; opts->x_flag_associative_math = -1; opts->frontend_set_flag_associative_math = true; + opts->x_flag_complex_method = 1; } /* Get ready for options handling. Keep in sync with @@ -406,7 +407,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 +505,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 +893,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..df8570b 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 @@ -57,6 +60,7 @@ bool gfc_in_omp_metadirective_body; /* Each metadirective body in the translation unit is given a unique number, used to ensure that labels in the body have unique names. */ int gfc_omp_metadirective_region_count; +vec<int> gfc_omp_metadirective_region_stack; /* TODO: Re-order functions to kill these forward decls. */ static void check_statement_label (gfc_statement); @@ -239,6 +243,7 @@ decode_specification_statement (void) break; case 'g': + match ("generic", gfc_match_generic, ST_GENERIC); break; case 'i': @@ -1190,6 +1195,9 @@ decode_omp_directive (void) case 'f': matcho ("flush", gfc_match_omp_flush, ST_OMP_FLUSH); break; + case 'g': + matchdo ("groupprivate", gfc_match_omp_groupprivate, ST_OMP_GROUPPRIVATE); + break; case 'i': matcho ("interop", gfc_match_omp_interop, ST_OMP_INTEROP); break; @@ -1985,7 +1993,8 @@ next_statement (void) #define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \ case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION: \ case ST_OMP_DECLARE_VARIANT: case ST_OMP_ALLOCATE: case ST_OMP_ASSUMES: \ - case ST_OMP_REQUIRES: case ST_OACC_ROUTINE: case ST_OACC_DECLARE + case ST_OMP_REQUIRES: case ST_OMP_GROUPPRIVATE: \ + case ST_OACC_ROUTINE: case ST_OACC_DECLARE /* OpenMP statements that are followed by a structured block. */ @@ -2904,6 +2913,9 @@ gfc_ascii_statement (gfc_statement st, bool strip_sentinel) case ST_OMP_FLUSH: p = "!$OMP FLUSH"; break; + case ST_OMP_GROUPPRIVATE: + p = "!$OMP GROUPPRIVATE"; + break; case ST_OMP_INTEROP: p = "!$OMP INTEROP"; break; @@ -3934,6 +3946,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 +3955,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 +3972,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 +4022,7 @@ endType: break; } - if (seen_component) + if (seen_component && !pdt_parameters) { gfc_error ("PRIVATE statement at %C must precede " "structure components"); @@ -3992,7 +4032,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; @@ -4401,6 +4444,8 @@ loop: case ST_EQUIVALENCE: case ST_IMPLICIT: case ST_IMPLICIT_NONE: + case ST_OMP_ALLOCATE: + case ST_OMP_GROUPPRIVATE: case ST_OMP_THREADPRIVATE: case ST_PARAMETER: case ST_STRUCTURE_DECL: @@ -4531,6 +4576,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(); @@ -6502,6 +6552,9 @@ parse_omp_metadirective_body (gfc_statement omp_st) gfc_in_omp_metadirective_body = true; gfc_omp_metadirective_region_count++; + gfc_omp_metadirective_region_stack.safe_push ( + gfc_omp_metadirective_region_count); + switch (variant->stmt) { case_omp_structured_block: @@ -6563,6 +6616,28 @@ parse_omp_metadirective_body (gfc_statement omp_st) *variant->code = *gfc_state_stack->head; pop_state (); + gfc_omp_metadirective_region_stack.pop (); + int outer_omp_metadirective_region + = gfc_omp_metadirective_region_stack.last (); + + /* Rebind labels in the last statement -- which is the first statement + past the end of the metadirective body -- to the outer region. */ + if (gfc_statement_label) + gfc_statement_label = gfc_rebind_label (gfc_statement_label, + outer_omp_metadirective_region); + if ((new_st.op == EXEC_READ || new_st.op == EXEC_WRITE) + && new_st.ext.dt->format_label + && new_st.ext.dt->format_label != &format_asterisk) + new_st.ext.dt->format_label + = gfc_rebind_label (new_st.ext.dt->format_label, + outer_omp_metadirective_region); + if (new_st.label1) + new_st.label1 + = gfc_rebind_label (new_st.label1, outer_omp_metadirective_region); + if (new_st.here) + new_st.here + = gfc_rebind_label (new_st.here, outer_omp_metadirective_region); + gfc_commit_symbols (); gfc_warning_check (); if (variant->next) @@ -6790,6 +6865,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 +6881,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 +6908,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); } @@ -7063,6 +7141,15 @@ loop: accept_statement (st); goto done; + /* Specification statements cannot appear after executable statements. */ + case_decl: + case_omp_decl: + gfc_error ("%s statement at %C cannot appear after executable statements", + gfc_ascii_statement (st)); + reject_statement (); + st = next_statement (); + continue; + default: break; } @@ -7535,6 +7622,8 @@ gfc_parse_file (void) gfc_statement_label = NULL; gfc_omp_metadirective_region_count = 0; + gfc_omp_metadirective_region_stack.truncate (0); + gfc_omp_metadirective_region_stack.safe_push (0); gfc_in_omp_metadirective_body = false; gfc_matching_omp_context_selector = false; @@ -7722,45 +7811,53 @@ done: { case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST: omp_requires_mask - = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_SEQ_CST); + = (enum omp_requires) (omp_requires_mask + | int (OMP_MEMORY_ORDER_SEQ_CST)); break; case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL: omp_requires_mask - = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_ACQ_REL); + = (enum omp_requires) (omp_requires_mask + | int (OMP_MEMORY_ORDER_ACQ_REL)); break; case OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE: omp_requires_mask - = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_ACQUIRE); + = (enum omp_requires) (omp_requires_mask + | int (OMP_MEMORY_ORDER_ACQUIRE)); break; case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED: omp_requires_mask - = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_RELAXED); + = (enum omp_requires) (omp_requires_mask + | int (OMP_MEMORY_ORDER_RELAXED)); break; case OMP_REQ_ATOMIC_MEM_ORDER_RELEASE: omp_requires_mask - = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_RELEASE); + = (enum omp_requires) (omp_requires_mask + | int (OMP_MEMORY_ORDER_RELEASE)); break; } if (omp_target_seen) omp_requires_mask = (enum omp_requires) (omp_requires_mask - | OMP_REQUIRES_TARGET_USED); + | int (OMP_REQUIRES_TARGET_USED)); if (omp_requires & OMP_REQ_REVERSE_OFFLOAD) - omp_requires_mask = (enum omp_requires) (omp_requires_mask - | OMP_REQUIRES_REVERSE_OFFLOAD); + omp_requires_mask + = (enum omp_requires) (omp_requires_mask + | int (OMP_REQUIRES_REVERSE_OFFLOAD)); if (omp_requires & OMP_REQ_UNIFIED_ADDRESS) - omp_requires_mask = (enum omp_requires) (omp_requires_mask - | OMP_REQUIRES_UNIFIED_ADDRESS); + omp_requires_mask + = (enum omp_requires) (omp_requires_mask + | int (OMP_REQUIRES_UNIFIED_ADDRESS)); if (omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY) omp_requires_mask - = (enum omp_requires) (omp_requires_mask - | OMP_REQUIRES_UNIFIED_SHARED_MEMORY); + = (enum omp_requires) (omp_requires_mask + | int (OMP_REQUIRES_UNIFIED_SHARED_MEMORY)); if (omp_requires & OMP_REQ_SELF_MAPS) omp_requires_mask - = (enum omp_requires) (omp_requires_mask | OMP_REQUIRES_SELF_MAPS); + = (enum omp_requires) (omp_requires_mask | int (OMP_REQUIRES_SELF_MAPS)); if (omp_requires & OMP_REQ_DYNAMIC_ALLOCATORS) - omp_requires_mask = (enum omp_requires) (omp_requires_mask - | OMP_REQUIRES_DYNAMIC_ALLOCATORS); + omp_requires_mask + = (enum omp_requires) (omp_requires_mask + | int (OMP_REQUIRES_DYNAMIC_ALLOCATORS)); /* Do the parse tree dump. */ gfc_current_ns = flag_dump_fortran_original ? gfc_global_ns_list : NULL; diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h index 7bf0fa4..70ffcbd 100644 --- a/gcc/fortran/parse.h +++ b/gcc/fortran/parse.h @@ -22,6 +22,8 @@ along with GCC; see the file COPYING3. If not see #ifndef GFC_PARSE_H #define GFC_PARSE_H +#include "vec.h" + /* Enum for what the compiler is currently doing. */ enum gfc_compile_state { @@ -76,6 +78,7 @@ extern bool gfc_matching_function; extern bool gfc_matching_omp_context_selector; extern bool gfc_in_omp_metadirective_body; extern int gfc_omp_metadirective_region_count; +extern vec<int> gfc_omp_metadirective_region_stack; match gfc_match_prefix (gfc_typespec *); bool is_oacc (gfc_state_data *); diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc index 161d4c2..e5e84e8 100644 --- a/gcc/fortran/primary.cc +++ b/gcc/fortran/primary.cc @@ -2071,6 +2071,23 @@ gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp, bool pdt) } } + /* PDT kind expressions are acceptable as initialization expressions. + However, intrinsics with a KIND argument reject them. Convert the + expression now by use of the component initializer. */ + if (tail->expr + && tail->expr->expr_type == EXPR_VARIABLE + && gfc_expr_attr (tail->expr).pdt_kind) + { + gfc_ref *ref; + gfc_expr *tmp = NULL; + for (ref = tail->expr->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); + if (tmp) + gfc_replace_expr (tail->expr, tmp); + } next: if (gfc_match_char (')') == MATCH_YES) @@ -2102,10 +2119,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; } @@ -2236,6 +2261,32 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, && !sym->attr.select_rank_temporary) inferred_type = true; + /* Try to resolve a typebound generic procedure so that the associate name + has a chance to get a type before being used in a second, nested associate + statement. Note that a copy is used for resolution so that failure does + not result in a mutilated selector expression further down the line. */ + if (tgt_expr && !sym->assoc->dangling + && tgt_expr->ts.type == BT_UNKNOWN + && tgt_expr->symtree + && tgt_expr->symtree->n.sym + && gfc_expr_attr (tgt_expr).generic + && ((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_template) + || (sym->ts.type == BT_CLASS + && CLASS_DATA (sym)->ts.u.derived->attr.pdt_template))) + { + gfc_expr *cpy = gfc_copy_expr (tgt_expr); + if (gfc_resolve_expr (cpy) + && cpy->ts.type != BT_UNKNOWN) + { + gfc_replace_expr (tgt_expr, cpy); + sym->ts = tgt_expr->ts; + } + else + gfc_free_expr (cpy); + if (gfc_expr_attr (tgt_expr).generic) + inferred_type = true; + } + /* For associate names, we may not yet know whether they are arrays or not. If the selector expression is unambiguously an array; eg. a full array or an array section, then the associate name must be an array and we can @@ -2302,9 +2353,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 +2381,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; @@ -2454,6 +2519,20 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, && !gfc_find_derived_types (sym, gfc_current_ns, name)) primary->ts.type = BT_UNKNOWN; + /* Otherwise try resolving a copy of a component call. If it succeeds, + use that for the selector expression. */ + else if (tgt_expr && tgt_expr->expr_type == EXPR_COMPCALL) + { + gfc_expr *cpy = gfc_copy_expr (tgt_expr); + if (gfc_resolve_expr (cpy)) + { + gfc_replace_expr (tgt_expr, cpy); + sym->ts = tgt_expr->ts; + } + else + gfc_free_expr (cpy); + } + /* An inquiry reference might determine the type, otherwise we have an error. */ if (sym->ts.type == BT_UNKNOWN && !inquiry) @@ -2483,6 +2562,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 +2570,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 +2654,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"); @@ -2640,6 +2730,14 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, else component = NULL; + if (previous && inquiry + && (previous->attr.pdt_kind || previous->attr.pdt_len)) + { + gfc_error_now ("R901: A type parameter ref is not a designtor and " + "cannot be followed by the type inquiry ref at %C"); + return MATCH_ERROR; + } + if (intrinsic && !inquiry) { if (previous) @@ -2659,6 +2757,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 +2781,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 +2934,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"); @@ -2893,6 +3000,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) gfc_symbol *sym; gfc_component *comp; bool has_inquiry_part; + bool has_substring_ref = false; if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION @@ -2955,7 +3063,12 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) has_inquiry_part = false; for (ref = expr->ref; ref; ref = ref->next) - if (ref->type == REF_INQUIRY) + if (ref->type == REF_SUBSTRING) + { + has_substring_ref = true; + optional = false; + } + else if (ref->type == REF_INQUIRY) { has_inquiry_part = true; optional = false; @@ -3003,19 +3116,20 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) *ts = comp->ts; /* Don't set the string length if a substring reference follows. */ - if (ts->type == BT_CHARACTER - && ref->next && ref->next->type == REF_SUBSTRING) - ts->u.cl = NULL; + if (ts->type == BT_CHARACTER && has_substring_ref) + ts->u.cl = NULL; } 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; @@ -3469,7 +3583,7 @@ gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **c } /* Find the current component in the structure definition and check - its access is not private. */ + its access is not private. */ if (comp) this_comp = gfc_find_component (sym, comp->name, false, false, NULL); else @@ -3761,6 +3875,7 @@ gfc_match_rvalue (gfc_expr **result) gfc_typespec *ts; bool implicit_char; gfc_ref *ref; + gfc_symtree *pdt_st; m = gfc_match ("%%loc"); if (m == MATCH_YES) @@ -4008,6 +4123,114 @@ 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. + + Even if 'name' is that of a PDT template, priority has to be given to + specific procedures, other than the constructor, in the generic + interface. */ + + gfc_gobble_whitespace (); + gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &pdt_st); + if (sym->attr.generic && pdt_st != NULL + && !(sym->generic->next && gfc_peek_ascii_char() != '(')) + { + gfc_symbol *pdt_sym; + gfc_actual_arglist *ctr_arglist = NULL, *tmp; + gfc_component *c; + + /* Use the template. */ + if (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; + } + + if (type_spec_list) + { + /* 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; + tmp = actual_arglist; + /* Can now add all the component names. */ + for (c = pdt_sym->components; c && tmp; c = c->next) + { + tmp->name = c->name; + tmp = tmp->next; + } + } + } + } + gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */ sym = symtree->n.sym; @@ -4266,6 +4489,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; @@ -4391,7 +4624,7 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag) case FL_PROCEDURE: /* Check for a nonrecursive function result variable. */ if (sym->attr.function - && !sym->attr.external + && (!sym->attr.external || sym->abr_modproc_decl) && sym->result == sym && (gfc_is_function_return_value (sym, gfc_current_ns) || (sym->attr.entry diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index e51f83b..db6b52f 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -533,7 +533,8 @@ gfc_resolve_formal_arglist (gfc_symbol *proc) } } } - + if (sym) + sym->formal_resolved = 1; gfc_current_ns = orig_current_ns; } @@ -1629,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; @@ -2029,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; @@ -2294,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; } @@ -3472,7 +3497,7 @@ resolve_function (gfc_expr *expr) &expr->where, &sym->formal_at); } } - else + else if (!sym->formal_resolved) { gfc_get_formal_from_actual_arglist (sym, expr->value.function.actual); sym->formal_at = expr->where; @@ -3918,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) { @@ -4033,7 +4201,7 @@ resolve_call (gfc_code *c) &c->loc, &csym->formal_at); } } - else + else if (!csym->formal_resolved) { gfc_get_formal_from_actual_arglist (csym, c->ext.actual); csym->formal_at = c->loc; @@ -4079,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; } @@ -4806,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: @@ -4868,6 +5013,76 @@ 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 + && true_expr->ts.type != BT_CHARACTER) + { + gfc_error ( + "Sorry, only integer, logical, real, complex and character types are " + "currently supported for conditional expressions at %L", + &expr->where); + return false; + } + + /* TODO: support arrays in conditional expressions */ + 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 **************/ @@ -5751,14 +5966,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) @@ -5806,6 +6056,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) @@ -5863,6 +6118,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; @@ -5875,27 +6170,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; } @@ -6069,8 +6344,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. */ @@ -7819,6 +8094,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. */ @@ -7858,6 +8134,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: @@ -7946,6 +8226,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; } @@ -8178,7 +8461,20 @@ check_default_none_expr (gfc_expr **e, int *, void *data) break; ns2 = ns2->parent; } - if (ns2 != NULL) + + /* A DO CONCURRENT iterator cannot appear in a locality spec. */ + if (sym->ns->code->ext.concur.forall_iterator) + { + gfc_forall_iterator *iter + = sym->ns->code->ext.concur.forall_iterator; + for (; iter; iter = iter->next) + if (iter->var->symtree + && strcmp(sym->name, iter->var->symtree->name) == 0) + return 0; + } + + /* A named constant is not a variable, so skip test. */ + if (ns2 != NULL && sym->attr.flavor != FL_PARAMETER) { gfc_error ("Variable %qs at %L not specified in a locality spec " "of DO CONCURRENT at %L but required due to " @@ -8458,6 +8754,8 @@ resolve_locality_spec (gfc_code *code, gfc_namespace *ns) plist = &((*plist)->next); } } + + delete data.sym_hash; } /* Resolve a list of FORALL iterators. The FORALL index-name is constrained @@ -8739,8 +9037,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)) @@ -9484,8 +9799,10 @@ done_errmsg: /* Resolving the expr3 in the loop over all objects to allocate would execute loop invariant code for each loop item. Therefore do it just once here. */ + mpz_t nelem; if (code->expr3 && code->expr3->mold - && code->expr3->ts.type == BT_DERIVED) + && code->expr3->ts.type == BT_DERIVED + && !(code->expr3->ref && gfc_array_size (code->expr3, &nelem))) { /* Default initialization via MOLD (non-polymorphic). */ gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts); @@ -10475,6 +10792,10 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) /* If the target is a good class object, so is the associate variable. */ if (sym->ts.type == BT_CLASS && gfc_expr_attr (target).class_ok) sym->attr.class_ok = 1; + + /* If the target is a contiguous pointer, so is the associate variable. */ + if (gfc_expr_attr (target).pointer && gfc_expr_attr (target).contiguous) + sym->attr.contiguous = 1; } @@ -10582,6 +10903,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) @@ -10801,6 +11123,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; @@ -10828,7 +11152,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 @@ -10836,6 +11159,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); @@ -10869,10 +11193,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; @@ -10880,12 +11218,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); @@ -11918,11 +12257,10 @@ static void gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr) { int n; + gfc_symbol *forall_index; for (n = 0; n < nvar; n++) { - gfc_symbol *forall_index; - forall_index = var_expr[n]->symtree->n.sym; /* Check whether the assignment target is one of the FORALL index @@ -11936,8 +12274,12 @@ gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr) /* If one of the FORALL index variables doesn't appear in the assignment variable, then there could be a many-to-one assignment. Emit a warning rather than an error because the - mask could be resolving this problem. */ - if (!find_forall_index (code->expr1, forall_index, 0)) + mask could be resolving this problem. + DO NOT emit this warning for DO CONCURRENT - reduction-like + many-to-one assignments are semantically valid (formalized with + the REDUCE locality-spec in Fortran 2023). */ + if (!find_forall_index (code->expr1, forall_index, 0) + && !gfc_do_concurrent_flag) gfc_warning (0, "The FORALL with index %qs is not used on the " "left side of the assignment at %L and so might " "cause multiple assignment to this object", @@ -12057,7 +12399,7 @@ gfc_count_forall_iterators (gfc_code *code) int max_iters, sub_iters, current_iters; gfc_forall_iterator *fa; - gcc_assert(code->op == EXEC_FORALL); + gcc_assert (code->op == EXEC_FORALL || code->op == EXEC_DO_CONCURRENT); max_iters = 0; current_iters = 0; @@ -12068,7 +12410,7 @@ gfc_count_forall_iterators (gfc_code *code) while (code) { - if (code->op == EXEC_FORALL) + if (code->op == EXEC_FORALL || code->op == EXEC_DO_CONCURRENT) { sub_iters = gfc_count_forall_iterators (code); if (sub_iters > max_iters) @@ -12081,8 +12423,160 @@ gfc_count_forall_iterators (gfc_code *code) } -/* Given a FORALL construct, first resolve the FORALL iterator, then call - gfc_resolve_forall_body to resolve the FORALL body. */ +/* Given a FORALL construct. + 1) Resolve the FORALL iterator. + 2) Check for shadow index-name(s) and update code block. + 3) call gfc_resolve_forall_body to resolve the FORALL body. */ + +/* Custom recursive expression walker that replaces symbols. + This ensures we visit ALL expressions including those in array subscripts. */ + +static void +replace_in_expr_recursive (gfc_expr *expr, gfc_symbol *old_sym, gfc_symtree *new_st) +{ + if (!expr) + return; + + /* Check if this is a variable reference to replace */ + if (expr->expr_type == EXPR_VARIABLE && expr->symtree->n.sym == old_sym) + { + expr->symtree = new_st; + expr->ts = new_st->n.sym->ts; + } + + /* Walk through reference chain (array subscripts, substrings, etc.) */ + for (gfc_ref *ref = expr->ref; ref; ref = ref->next) + { + if (ref->type == REF_ARRAY) + { + gfc_array_ref *ar = &ref->u.ar; + for (int i = 0; i < ar->dimen; i++) + { + replace_in_expr_recursive (ar->start[i], old_sym, new_st); + replace_in_expr_recursive (ar->end[i], old_sym, new_st); + replace_in_expr_recursive (ar->stride[i], old_sym, new_st); + } + } + else if (ref->type == REF_SUBSTRING) + { + replace_in_expr_recursive (ref->u.ss.start, old_sym, new_st); + replace_in_expr_recursive (ref->u.ss.end, old_sym, new_st); + } + } + + /* Walk through sub-expressions based on expression type */ + switch (expr->expr_type) + { + case EXPR_OP: + replace_in_expr_recursive (expr->value.op.op1, old_sym, new_st); + replace_in_expr_recursive (expr->value.op.op2, old_sym, new_st); + break; + + case EXPR_FUNCTION: + for (gfc_actual_arglist *a = expr->value.function.actual; a; a = a->next) + replace_in_expr_recursive (a->expr, old_sym, new_st); + break; + + case EXPR_ARRAY: + case EXPR_STRUCTURE: + for (gfc_constructor *c = gfc_constructor_first (expr->value.constructor); + c; c = gfc_constructor_next (c)) + { + replace_in_expr_recursive (c->expr, old_sym, new_st); + if (c->iterator) + { + replace_in_expr_recursive (c->iterator->start, old_sym, new_st); + replace_in_expr_recursive (c->iterator->end, old_sym, new_st); + replace_in_expr_recursive (c->iterator->step, old_sym, new_st); + } + } + break; + + default: + break; + } +} + + +/* Walk code tree and replace all variable references */ + +static void +replace_in_code_recursive (gfc_code *code, gfc_symbol *old_sym, gfc_symtree *new_st) +{ + if (!code) + return; + + for (gfc_code *c = code; c; c = c->next) + { + /* Replace in expressions associated with this code node */ + replace_in_expr_recursive (c->expr1, old_sym, new_st); + replace_in_expr_recursive (c->expr2, old_sym, new_st); + replace_in_expr_recursive (c->expr3, old_sym, new_st); + replace_in_expr_recursive (c->expr4, old_sym, new_st); + + /* Handle special code types with additional expressions */ + switch (c->op) + { + case EXEC_DO: + if (c->ext.iterator) + { + replace_in_expr_recursive (c->ext.iterator->start, old_sym, new_st); + replace_in_expr_recursive (c->ext.iterator->end, old_sym, new_st); + replace_in_expr_recursive (c->ext.iterator->step, old_sym, new_st); + } + break; + + case EXEC_CALL: + case EXEC_ASSIGN_CALL: + for (gfc_actual_arglist *a = c->ext.actual; a; a = a->next) + replace_in_expr_recursive (a->expr, old_sym, new_st); + break; + + case EXEC_SELECT: + for (gfc_code *b = c->block; b; b = b->block) + { + for (gfc_case *cp = b->ext.block.case_list; cp; cp = cp->next) + { + replace_in_expr_recursive (cp->low, old_sym, new_st); + replace_in_expr_recursive (cp->high, old_sym, new_st); + } + replace_in_code_recursive (b->next, old_sym, new_st); + } + break; + + case EXEC_FORALL: + case EXEC_DO_CONCURRENT: + for (gfc_forall_iterator *fa = c->ext.concur.forall_iterator; fa; fa = fa->next) + { + replace_in_expr_recursive (fa->start, old_sym, new_st); + replace_in_expr_recursive (fa->end, old_sym, new_st); + replace_in_expr_recursive (fa->stride, old_sym, new_st); + } + /* Don't recurse into nested FORALL/DO CONCURRENT bodies here, + they'll be handled separately */ + break; + + default: + break; + } + + /* Recurse into blocks */ + if (c->block) + replace_in_code_recursive (c->block->next, old_sym, new_st); + } +} + + +/* Replace all references to outer_sym with shadow_st in the given code. */ + +static void +gfc_replace_forall_variable (gfc_code **code_ptr, gfc_symbol *outer_sym, + gfc_symtree *shadow_st) +{ + /* Use custom recursive walker to ensure we visit ALL expressions */ + replace_in_code_recursive (*code_ptr, outer_sym, shadow_st); +} + static void gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) @@ -12092,14 +12586,21 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) static int nvar = 0; int i, old_nvar, tmp; gfc_forall_iterator *fa; + bool shadow = false; old_nvar = nvar; - if (!gfc_notify_std (GFC_STD_F2018_OBS, "FORALL construct at %L", &code->loc)) + /* Only warn about obsolescent FORALL, not DO CONCURRENT */ + if (code->op == EXEC_FORALL + && !gfc_notify_std (GFC_STD_F2018_OBS, "FORALL construct at %L", &code->loc)) return; /* Start to resolve a FORALL construct */ - if (forall_save == 0) + /* Allocate var_expr only at the truly outermost FORALL/DO CONCURRENT level. + forall_save==0 means we're not nested in a FORALL in the current scope, + but nvar==0 ensures we're not nested in a parent scope either (prevents + double allocation when FORALL is nested inside DO CONCURRENT). */ + if (forall_save == 0 && nvar == 0) { /* Count the total number of FORALL indices in the nested FORALL construct in order to allocate the VAR_EXPR with proper size. */ @@ -12109,11 +12610,12 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) var_expr = XCNEWVEC (gfc_expr *, total_var); } - /* The information about FORALL iterator, including FORALL indices start, end - and stride. An outer FORALL indice cannot appear in start, end or stride. */ + /* The information about FORALL iterator, including FORALL indices start, + end and stride. An outer FORALL indice cannot appear in start, end or + stride. Check for a shadow index-name. */ for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next) { - /* Fortran 20008: C738 (R753). */ + /* Fortran 2008: C738 (R753). */ if (fa->var->ref && fa->var->ref->type == REF_ARRAY) { gfc_error ("FORALL index-name at %L must be a scalar variable " @@ -12122,14 +12624,19 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) } /* Check if any outer FORALL index name is the same as the current - one. */ + one. Skip this check if the iterator is a shadow variable (from + DO CONCURRENT type spec) which may not have a symtree yet. */ for (i = 0; i < nvar; i++) { - if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym) + if (fa->var && fa->var->symtree && var_expr[i] && var_expr[i]->symtree + && fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym) gfc_error ("An outer FORALL construct already has an index " "with this name %L", &fa->var->where); } + if (fa->shadow) + shadow = true; + /* Record the current FORALL index. */ var_expr[nvar] = gfc_copy_expr (fa->var); @@ -12139,6 +12646,47 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) gcc_assert (nvar <= total_var); } + /* Need to walk the code and replace references to the index-name with + references to the shadow index-name. This must be done BEFORE resolving + the body so that resolution uses the correct shadow variables. */ + if (shadow) + { + /* Walk the FORALL/DO CONCURRENT body and replace references to shadowed variables. */ + for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next) + { + if (fa->shadow) + { + gfc_symtree *shadow_st; + const char *shadow_name_str; + char *outer_name; + + /* fa->var now points to the shadow variable "_name". */ + shadow_name_str = fa->var->symtree->name; + shadow_st = fa->var->symtree; + + if (shadow_name_str[0] != '_') + gfc_internal_error ("Expected shadow variable name to start with _"); + + outer_name = (char *) alloca (strlen (shadow_name_str)); + strcpy (outer_name, shadow_name_str + 1); + + /* Find the ITERATOR symbol in the current namespace. + This is the local DO CONCURRENT variable that body expressions reference. */ + gfc_symtree *iter_st = gfc_find_symtree (ns->sym_root, outer_name); + + if (!iter_st) + /* No iterator variable found - this shouldn't happen */ + continue; + + gfc_symbol *iter_sym = iter_st->n.sym; + + /* Walk the FORALL/DO CONCURRENT body and replace all references. */ + if (code->block && code->block->next) + gfc_replace_forall_variable (&code->block->next, iter_sym, shadow_st); + } + } + } + /* Resolve the FORALL body. */ gfc_resolve_forall_body (code, nvar, var_expr); @@ -13408,11 +13956,17 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns) forall_save = forall_flag; do_concurrent_save = gfc_do_concurrent_flag; - if (code->op == EXEC_FORALL) + if (code->op == EXEC_FORALL || code->op == EXEC_DO_CONCURRENT) { - forall_flag = 1; + if (code->op == EXEC_FORALL) + forall_flag = 1; + else if (code->op == EXEC_DO_CONCURRENT) + gfc_do_concurrent_flag = 1; gfc_resolve_forall (code, ns, forall_save); - forall_flag = 2; + if (code->op == EXEC_FORALL) + forall_flag = 2; + else if (code->op == EXEC_DO_CONCURRENT) + gfc_do_concurrent_flag = 2; } else if (code->op == EXEC_OMP_METADIRECTIVE) for (gfc_omp_variant *variant @@ -14322,6 +14876,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 @@ -15060,6 +15621,39 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) return false; } + /* F2018:C1585: "The function result of a pure function shall not be both + polymorphic and allocatable, or have a polymorphic allocatable ultimate + component." */ + if (sym->attr.pure && sym->result && sym->ts.u.derived) + { + if (sym->ts.type == BT_CLASS + && sym->attr.class_ok + && CLASS_DATA (sym->result) + && CLASS_DATA (sym->result)->attr.allocatable) + { + gfc_error ("Result variable %qs of pure function at %L is " + "polymorphic allocatable", + sym->result->name, &sym->result->declared_at); + return false; + } + + if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components) + { + gfc_component *c = sym->ts.u.derived->components; + for (; c; c = c->next) + if (c->ts.type == BT_CLASS + && CLASS_DATA (c) + && CLASS_DATA (c)->attr.allocatable) + { + gfc_error ("Result variable %qs of pure function at %L has " + "polymorphic allocatable component %qs", + sym->result->name, &sym->result->declared_at, + c->name); + return false; + } + } + } + if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1) { gfc_formal_arglist *curr_arg; @@ -15244,7 +15838,7 @@ check_formal: static bool gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable) { - gfc_finalizer* list; + gfc_finalizer *list, *pdt_finalizers = NULL; gfc_finalizer** prev_link; /* For removing wrong entries from the list. */ bool result = true; bool seen_scalar = false; @@ -15274,6 +15868,41 @@ gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable) return true; } + /* If a PDT has finalizers, the pdt_type's f2k_derived is a copy of that of + the template. If the finalizers field has the same value, it needs to be + supplied with finalizers of the same pdt_type. */ + if (derived->attr.pdt_type + && derived->template_sym + && derived->template_sym->f2k_derived + && (pdt_finalizers = derived->template_sym->f2k_derived->finalizers) + && derived->f2k_derived->finalizers == pdt_finalizers) + { + gfc_finalizer *tmp = NULL; + derived->f2k_derived->finalizers = NULL; + prev_link = &derived->f2k_derived->finalizers; + for (list = pdt_finalizers; list; list = list->next) + { + gfc_formal_arglist *args = gfc_sym_get_dummy_args (list->proc_sym); + if (args->sym + && args->sym->ts.type == BT_DERIVED + && args->sym->ts.u.derived + && !strcmp (args->sym->ts.u.derived->name, derived->name)) + { + tmp = gfc_get_finalizer (); + *tmp = *list; + tmp->next = NULL; + if (*prev_link) + { + (*prev_link)->next = tmp; + prev_link = &tmp; + } + else + *prev_link = tmp; + list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym); + } + } + } + /* Walk over the list of finalizer-procedures, check them, and if any one does not fit in with the standard's definition, print an error and remove it from the list. */ @@ -15330,7 +15959,8 @@ gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable) } /* This argument must be of our type. */ - if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived) + if (!derived->attr.pdt_template + && (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)) { gfc_error ("Argument of FINAL procedure at %L must be of type %qs", &arg->declared_at, derived->name); @@ -15385,7 +16015,7 @@ gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable) /* Argument list might be empty; that is an error signalled earlier, but we nevertheless continued resolving. */ dummy_args = gfc_sym_get_dummy_args (i->proc_sym); - if (dummy_args) + if (dummy_args && !derived->attr.pdt_template) { gfc_symbol* i_arg = dummy_args->sym; const int i_rank = (i_arg->as ? i_arg->as->rank : 0); @@ -15433,9 +16063,13 @@ error: " rank finalizer has been declared", derived->name, &derived->declared_at); - vtab = gfc_find_derived_vtab (derived); - c = vtab->ts.u.derived->components->next->next->next->next->next; - gfc_set_sym_referenced (c->initializer->symtree->n.sym); + if (!derived->attr.pdt_template) + { + vtab = gfc_find_derived_vtab (derived); + c = vtab->ts.u.derived->components->next->next->next->next->next; + if (c && c->initializer && c->initializer->symtree && c->initializer->symtree->n.sym) + gfc_set_sym_referenced (c->initializer->symtree->n.sym); + } if (finalizable) *finalizable = true; @@ -15444,6 +16078,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 @@ -15501,6 +16160,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)) @@ -15716,10 +16386,14 @@ resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op, /* Preempt 'gfc_check_new_interface' for submodules, where the mechanism for handling module procedures winds up resolving - operator interfaces twice and would otherwise cause an error. */ + operator interfaces twice and would otherwise cause an error. + Likewise, new instances of PDTs can cause the operator inter- + faces to be resolved multiple times. */ for (intr = derived->ns->op[op]; intr; intr = intr->next) if (intr->sym == target_proc - && target_proc->attr.used_in_submodule) + && (target_proc->attr.used_in_submodule + || derived->attr.pdt_type + || derived->attr.pdt_template)) return true; if (!gfc_check_new_interface (derived->ns->op[op], @@ -15948,8 +16622,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 " @@ -16096,6 +16772,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); @@ -16103,6 +16780,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) { @@ -16325,6 +17003,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; @@ -16519,27 +17217,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 " @@ -16556,8 +17257,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; } @@ -16572,14 +17273,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 @@ -16589,27 +17290,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) @@ -16617,7 +17318,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 @@ -16630,10 +17331,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 @@ -16641,8 +17342,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 @@ -16818,8 +17519,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 @@ -17444,6 +18145,7 @@ skip_interfaces: /* F2008, C530. */ if (sym->attr.contiguous + && !sym->attr.associate_var && (!class_attr.dimension || (as->type != AS_ASSUMED_SHAPE && as->type != AS_ASSUMED_RANK && !class_attr.pointer))) @@ -18015,17 +18717,30 @@ skip_interfaces: } /* Check threadprivate restrictions. */ - if (sym->attr.threadprivate + if ((sym->attr.threadprivate || sym->attr.omp_groupprivate) && !(sym->attr.save || sym->attr.data || sym->attr.in_common) && !(sym->ns->save_all && !sym->attr.automatic) && sym->module == NULL && (sym->ns->proc_name == NULL || (sym->ns->proc_name->attr.flavor != FL_MODULE && !sym->ns->proc_name->attr.is_main_program))) - gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at); + { + if (sym->attr.threadprivate) + gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at); + else + gfc_error ("OpenMP groupprivate variable %qs at %L must have the SAVE " + "attribute", sym->name, &sym->declared_at); + } + + if (sym->attr.omp_groupprivate && sym->value) + gfc_error ("!$OMP GROUPPRIVATE variable %qs at %L must not have an " + "initializer", sym->name, &sym->declared_at); /* Check omp declare target restrictions. */ - if (sym->attr.omp_declare_target + if ((sym->attr.omp_declare_target + || sym->attr.omp_declare_target_link + || sym->attr.omp_declare_target_local) + && !sym->attr.omp_groupprivate /* already warned. */ && sym->attr.flavor == FL_VARIABLE && !sym->attr.save && !(sym->ns->save_all && !sym->attr.automatic) @@ -18058,16 +18773,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 @@ -18549,12 +19264,23 @@ gfc_impure_variable (gfc_symbol *sym) if (sym->attr.use_assoc || sym->attr.in_common) return 1; + /* The namespace of a module procedure interface holds the arguments and + symbols, and so the symbol namespace can be different to that of the + procedure. */ + if (sym->ns != gfc_current_ns + && gfc_current_ns->proc_name->abr_modproc_decl + && sym->ns->proc_name->attr.function + && sym->attr.result + && !strcmp (sym->ns->proc_name->name, gfc_current_ns->proc_name->name)) + return 0; + /* Check if the symbol's ns is inside the pure procedure. */ for (ns = gfc_current_ns; ns; ns = ns->parent) { if (ns == sym->ns) break; - if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function) + if (ns->proc_name->attr.flavor == FL_PROCEDURE + && !(sym->attr.function || sym->attr.result)) return 1; } diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc index 208251b..b25cd2c 100644 --- a/gcc/fortran/simplify.cc +++ b/gcc/fortran/simplify.cc @@ -885,7 +885,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 +1163,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 +1185,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 +1199,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 +1215,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 +1246,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 +1275,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 +1387,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 +1966,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 +2013,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 +2026,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 +2045,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 +2067,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 +2089,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 +2117,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 +2155,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..62925c0 100644 --- a/gcc/fortran/symbol.cc +++ b/gcc/fortran/symbol.cc @@ -458,8 +458,10 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) *contiguous = "CONTIGUOUS", *generic = "GENERIC", *automatic = "AUTOMATIC", *pdt_len = "LEN", *pdt_kind = "KIND"; static const char *threadprivate = "THREADPRIVATE"; + static const char *omp_groupprivate = "OpenMP GROUPPRIVATE"; static const char *omp_declare_target = "OMP DECLARE TARGET"; static const char *omp_declare_target_link = "OMP DECLARE TARGET LINK"; + static const char *omp_declare_target_local = "OMP DECLARE TARGET LOCAL"; static const char *oacc_declare_copyin = "OACC DECLARE COPYIN"; static const char *oacc_declare_create = "OACC DECLARE CREATE"; static const char *oacc_declare_deviceptr = "OACC DECLARE DEVICEPTR"; @@ -553,8 +555,10 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (dummy, entry); conf (dummy, intrinsic); conf (dummy, threadprivate); + conf (dummy, omp_groupprivate); conf (dummy, omp_declare_target); conf (dummy, omp_declare_target_link); + conf (dummy, omp_declare_target_local); conf (pointer, target); conf (pointer, intrinsic); conf (pointer, elemental); @@ -604,8 +608,10 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (in_equivalence, entry); conf (in_equivalence, allocatable); conf (in_equivalence, threadprivate); + conf (in_equivalence, omp_groupprivate); conf (in_equivalence, omp_declare_target); conf (in_equivalence, omp_declare_target_link); + conf (in_equivalence, omp_declare_target_local); conf (in_equivalence, oacc_declare_create); conf (in_equivalence, oacc_declare_copyin); conf (in_equivalence, oacc_declare_deviceptr); @@ -616,6 +622,7 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (entry, result); conf (generic, result); conf (generic, omp_declare_target); + conf (generic, omp_declare_target_local); conf (generic, omp_declare_target_link); conf (function, subroutine); @@ -661,8 +668,10 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (cray_pointee, in_common); conf (cray_pointee, in_equivalence); conf (cray_pointee, threadprivate); + conf (cray_pointee, omp_groupprivate); conf (cray_pointee, omp_declare_target); conf (cray_pointee, omp_declare_target_link); + conf (cray_pointee, omp_declare_target_local); conf (cray_pointee, oacc_declare_create); conf (cray_pointee, oacc_declare_copyin); conf (cray_pointee, oacc_declare_deviceptr); @@ -720,9 +729,11 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (proc_pointer, abstract) conf (proc_pointer, omp_declare_target) + conf (proc_pointer, omp_declare_target_local) conf (proc_pointer, omp_declare_target_link) conf (entry, omp_declare_target) + conf (entry, omp_declare_target_local) conf (entry, omp_declare_target_link) conf (entry, oacc_declare_create) conf (entry, oacc_declare_copyin) @@ -782,8 +793,10 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf2 (function); conf2 (subroutine); conf2 (threadprivate); + conf2 (omp_groupprivate); conf2 (omp_declare_target); conf2 (omp_declare_target_link); + conf2 (omp_declare_target_local); conf2 (oacc_declare_create); conf2 (oacc_declare_copyin); conf2 (oacc_declare_deviceptr); @@ -828,7 +841,10 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf2 (dimension); conf2 (function); if (!attr->proc_pointer) - conf2 (threadprivate); + { + conf2 (threadprivate); + conf2 (omp_groupprivate); + } } /* Procedure pointers in COMMON blocks are allowed in F03, @@ -836,6 +852,7 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) if (!attr->proc_pointer || (gfc_option.allow_std & GFC_STD_F2008)) conf2 (in_common); + conf2 (omp_declare_target_local); conf2 (omp_declare_target_link); switch (attr->proc) @@ -852,6 +869,7 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) case PROC_DUMMY: conf2 (result); conf2 (threadprivate); + conf2 (omp_groupprivate); break; default: @@ -872,8 +890,10 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf2 (function); conf2 (subroutine); conf2 (threadprivate); + conf2 (omp_groupprivate); conf2 (result); conf2 (omp_declare_target); + conf2 (omp_declare_target_local); conf2 (omp_declare_target_link); conf2 (oacc_declare_create); conf2 (oacc_declare_copyin); @@ -905,6 +925,7 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf2 (volatile_); conf2 (asynchronous); conf2 (threadprivate); + conf2 (omp_groupprivate); conf2 (value); conf2 (codimension); conf2 (result); @@ -1407,6 +1428,25 @@ gfc_add_asynchronous (symbol_attribute *attr, const char *name, locus *where) bool +gfc_add_omp_groupprivate (symbol_attribute *attr, const char *name, + locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + if (attr->omp_groupprivate) + { + duplicate_attr ("OpenMP GROUPPRIVATE", where); + return false; + } + + attr->omp_groupprivate = true; + return gfc_check_conflict (attr, name, where); +} + + +bool gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where) { @@ -1457,6 +1497,22 @@ gfc_add_omp_declare_target_link (symbol_attribute *attr, const char *name, bool +gfc_add_omp_declare_target_local (symbol_attribute *attr, const char *name, + locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + if (attr->omp_declare_target_local) + return true; + + attr->omp_declare_target_local = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool gfc_add_oacc_declare_create (symbol_attribute *attr, const char *name, locus *where) { @@ -2110,6 +2166,9 @@ gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where) goto fail; if (src->asynchronous && !gfc_add_asynchronous (dest, NULL, where)) goto fail; + if (src->omp_groupprivate + && !gfc_add_omp_groupprivate (dest, NULL, where)) + goto fail; if (src->threadprivate && !gfc_add_threadprivate (dest, NULL, where)) goto fail; @@ -2119,6 +2178,9 @@ gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where) if (src->omp_declare_target_link && !gfc_add_omp_declare_target_link (dest, NULL, where)) goto fail; + if (src->omp_declare_target_local + && !gfc_add_omp_declare_target_local (dest, NULL, where)) + goto fail; if (src->oacc_declare_create && !gfc_add_oacc_declare_create (dest, NULL, where)) goto fail; @@ -2753,8 +2815,7 @@ gfc_get_st_label (int labelno) { gfc_st_label *lp; gfc_namespace *ns; - int omp_region = (gfc_in_omp_metadirective_body - ? gfc_omp_metadirective_region_count : 0); + int omp_region = gfc_omp_metadirective_region_stack.last (); if (gfc_current_state () == COMP_DERIVED) ns = gfc_current_block ()->f2k_derived; @@ -2768,22 +2829,28 @@ gfc_get_st_label (int labelno) } /* First see if the label is already in this namespace. */ - lp = ns->st_labels; - while (lp) + gcc_checking_assert (gfc_omp_metadirective_region_stack.length () > 0); + for (int omp_region_idx = gfc_omp_metadirective_region_stack.length () - 1; + omp_region_idx >= 0; omp_region_idx--) { - if (lp->omp_region == omp_region) + int omp_region2 = gfc_omp_metadirective_region_stack[omp_region_idx]; + lp = ns->st_labels; + while (lp) { - if (lp->value == labelno) - return lp; - if (lp->value < labelno) + if (lp->omp_region == omp_region2) + { + if (lp->value == labelno) + return lp; + if (lp->value < labelno) + lp = lp->left; + else + lp = lp->right; + } + else if (lp->omp_region < omp_region2) lp = lp->left; else lp = lp->right; } - else if (lp->omp_region < omp_region) - lp = lp->left; - else - lp = lp->right; } lp = XCNEW (gfc_st_label); @@ -2799,6 +2866,53 @@ gfc_get_st_label (int labelno) return lp; } +/* Rebind a statement label to a new OpenMP region. If a label with the same + value already exists in the new region, update it and return it. Otherwise, + move the label to the new region. */ + +gfc_st_label * +gfc_rebind_label (gfc_st_label *label, int new_omp_region) +{ + gfc_st_label *lp = label->ns->st_labels; + int labelno = label->value; + + while (lp) + { + if (lp->omp_region == new_omp_region) + { + if (lp->value == labelno) + { + if (lp == label) + return label; + if (lp->defined == ST_LABEL_UNKNOWN + && label->defined != ST_LABEL_UNKNOWN) + lp->defined = label->defined; + if (lp->referenced == ST_LABEL_UNKNOWN + && label->referenced != ST_LABEL_UNKNOWN) + lp->referenced = label->referenced; + if (lp->format == NULL && label->format != NULL) + lp->format = label->format; + gfc_delete_bbt (&label->ns->st_labels, label, compare_st_labels); + return lp; + } + if (lp->value < labelno) + lp = lp->left; + else + lp = lp->right; + } + else if (lp->omp_region < new_omp_region) + lp = lp->left; + else + lp = lp->right; + } + + gfc_delete_bbt (&label->ns->st_labels, label, compare_st_labels); + label->left = nullptr; + label->right = nullptr; + label->omp_region = new_omp_region; + gfc_insert_bbt (&label->ns->st_labels, label, compare_st_labels); + return label; +} /* Called when a statement with a statement label is about to be accepted. We add the label to the list of the current namespace, @@ -2812,7 +2926,7 @@ gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus) labelno = lp->value; - if (lp->defined != ST_LABEL_UNKNOWN) + if (lp->defined != ST_LABEL_UNKNOWN && !gfc_in_omp_metadirective_body) gfc_error ("Duplicate statement label %d at %L and %L", labelno, &lp->where, label_locus); else @@ -2897,6 +3011,7 @@ gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type) } if (lp->referenced == ST_LABEL_DO_TARGET && type == ST_LABEL_DO_TARGET + && !gfc_in_omp_metadirective_body && !gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL, "Shared DO termination label %d at %C", labelno)) return false; @@ -3172,7 +3287,21 @@ gfc_free_symbol (gfc_symbol *&sym) gfc_free_formal_arglist (sym->formal); - gfc_free_namespace (sym->f2k_derived); + /* The pdt_type f2k_derived namespaces are copies of that of the pdt_template + and are only made if there are finalizers. The complete list of finalizers + is kept by the pdt_template and are freed with its f2k_derived. */ + if (!sym->attr.pdt_type) + gfc_free_namespace (sym->f2k_derived); + else if (sym->f2k_derived && sym->f2k_derived->finalizers) + { + gfc_finalizer *p, *q = NULL; + for (p = sym->f2k_derived->finalizers; p; p = q) + { + q = p->next; + free (p); + } + free (sym->f2k_derived); + } set_symbol_common_block (sym, NULL); @@ -5500,7 +5629,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 +5653,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..cd13721 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -92,6 +92,8 @@ along with GCC; see the file COPYING3. If not see #include "trans-array.h" #include "trans-const.h" #include "dependency.h" +#include "cgraph.h" /* For cgraph_node::add_new_function. */ +#include "function.h" /* For push_struct_function. */ static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base); @@ -268,13 +270,7 @@ gfc_conv_descriptor_data_get (tree desc) return fold_convert (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), field); } -/* This provides WRITE access to the data field. - - TUPLES_P is true if we are generating tuples. - - This function gets called through the following macros: - gfc_conv_descriptor_data_set - gfc_conv_descriptor_data_set. */ +/* This provides WRITE access to the data field. */ void gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value) @@ -284,16 +280,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 +1412,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 +1971,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 +3101,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 +3132,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 +3351,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 +3432,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 +3629,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 +3655,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 +4955,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 +4986,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 +5020,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 +5042,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 +5395,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 +6081,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 +6139,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 +6197,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 +6226,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 +6353,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 +6630,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 +6718,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 +6850,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 +7015,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 +8494,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 +8696,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 +8908,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 +9442,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 +9587,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++) { @@ -9775,6 +10024,142 @@ enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, BCAST_ALLOC_COMP}; static gfc_actual_arglist *pdt_param_list; +static bool generating_copy_helper; +static hash_set<gfc_symbol *> seen_derived_types; + +/* Forward declaration of structure_alloc_comps for wrapper generator. */ +static tree structure_alloc_comps (gfc_symbol *, tree, tree, int, int, int, + gfc_co_subroutines_args *, bool); + +/* Generate a wrapper function that performs element-wise deep copy for + recursive allocatable array components. This wrapper is passed as a + function pointer to the runtime helper _gfortran_cfi_deep_copy_array, + allowing recursion to happen at runtime instead of compile time. */ + +static tree +get_copy_helper_function_type (void) +{ + static tree fn_type = NULL_TREE; + if (fn_type == NULL_TREE) + fn_type = build_function_type_list (void_type_node, + pvoid_type_node, + pvoid_type_node, + NULL_TREE); + return fn_type; +} + +static tree +get_copy_helper_pointer_type (void) +{ + static tree ptr_type = NULL_TREE; + if (ptr_type == NULL_TREE) + ptr_type = build_pointer_type (get_copy_helper_function_type ()); + return ptr_type; +} + +static tree +generate_element_copy_wrapper (gfc_symbol *der_type, tree comp_type, + int purpose, int caf_mode) +{ + tree fndecl, fntype, result_decl; + tree dest_parm, src_parm, dest_typed, src_typed; + tree der_type_ptr; + stmtblock_t block; + tree decls; + tree body; + + fntype = get_copy_helper_function_type (); + + fndecl = build_decl (input_location, FUNCTION_DECL, + create_tmp_var_name ("copy_element"), + fntype); + + TREE_STATIC (fndecl) = 1; + TREE_USED (fndecl) = 1; + DECL_ARTIFICIAL (fndecl) = 1; + DECL_IGNORED_P (fndecl) = 0; + TREE_PUBLIC (fndecl) = 0; + DECL_UNINLINABLE (fndecl) = 1; + DECL_EXTERNAL (fndecl) = 0; + DECL_CONTEXT (fndecl) = NULL_TREE; + DECL_INITIAL (fndecl) = make_node (BLOCK); + BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl; + + result_decl = build_decl (input_location, RESULT_DECL, NULL_TREE, + void_type_node); + DECL_ARTIFICIAL (result_decl) = 1; + DECL_IGNORED_P (result_decl) = 1; + DECL_CONTEXT (result_decl) = fndecl; + DECL_RESULT (fndecl) = result_decl; + + dest_parm = build_decl (input_location, PARM_DECL, + get_identifier ("dest"), pvoid_type_node); + src_parm = build_decl (input_location, PARM_DECL, + get_identifier ("src"), pvoid_type_node); + + DECL_ARTIFICIAL (dest_parm) = 1; + DECL_ARTIFICIAL (src_parm) = 1; + DECL_ARG_TYPE (dest_parm) = pvoid_type_node; + DECL_ARG_TYPE (src_parm) = pvoid_type_node; + DECL_CONTEXT (dest_parm) = fndecl; + DECL_CONTEXT (src_parm) = fndecl; + + DECL_ARGUMENTS (fndecl) = dest_parm; + TREE_CHAIN (dest_parm) = src_parm; + + push_struct_function (fndecl); + cfun->function_end_locus = input_location; + + pushlevel (); + gfc_init_block (&block); + + bool saved_generating = generating_copy_helper; + generating_copy_helper = true; + + /* When generating a wrapper, we need a fresh type tracking state to + avoid inheriting the parent context's seen_derived_types, which would + cause infinite recursion when the wrapper tries to handle the same + recursive type. Save elements, clear the set, generate wrapper, then + restore elements. */ + vec<gfc_symbol *> saved_symbols = vNULL; + for (hash_set<gfc_symbol *>::iterator it = seen_derived_types.begin (); + it != seen_derived_types.end (); ++it) + saved_symbols.safe_push (*it); + seen_derived_types.empty (); + + der_type_ptr = build_pointer_type (comp_type); + dest_typed = fold_convert (der_type_ptr, dest_parm); + src_typed = fold_convert (der_type_ptr, src_parm); + + dest_typed = build_fold_indirect_ref (dest_typed); + src_typed = build_fold_indirect_ref (src_typed); + + body = structure_alloc_comps (der_type, src_typed, dest_typed, + 0, purpose, caf_mode, NULL, false); + gfc_add_expr_to_block (&block, body); + + /* Restore saved symbols. */ + seen_derived_types.empty (); + for (unsigned i = 0; i < saved_symbols.length (); i++) + seen_derived_types.add (saved_symbols[i]); + saved_symbols.release (); + generating_copy_helper = saved_generating; + + body = gfc_finish_block (&block); + decls = getdecls (); + + poplevel (1, 1); + + DECL_SAVED_TREE (fndecl) + = fold_build3_loc (DECL_SOURCE_LOCATION (fndecl), BIND_EXPR, + void_type_node, decls, body, DECL_INITIAL (fndecl)); + + pop_cfun (); + + cgraph_node::add_new_function (fndecl, false); + + return build1 (ADDR_EXPR, get_copy_helper_pointer_type (), fndecl); +} static tree structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, @@ -9805,7 +10190,6 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, int caf_dereg_mode; symbol_attribute *attr; bool deallocate_called; - static hash_set<gfc_symbol *> seen_derived_types; gfc_init_block (&fnblock); @@ -9939,6 +10323,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, && seen_derived_types.contains (c->ts.u.derived)) || (c->ts.type == BT_CLASS && seen_derived_types.contains (CLASS_DATA (c)->ts.u.derived)); + bool inside_wrapper = generating_copy_helper; bool is_pdt_type = c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pdt_type; @@ -10479,6 +10864,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,15 +10992,73 @@ 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, false, false, NULL_TREE, NULL_TREE); gfc_add_expr_to_block (&fnblock, tmp); } + /* Special case: recursive allocatable array components require + runtime helpers to avoid compile-time infinite recursion. Generate + a call to _gfortran_cfi_deep_copy_array with an element copy + wrapper. When inside a wrapper, reuse current_function_decl. */ + else if (c->attr.allocatable && c->as && cmp_has_alloc_comps && same_type + && purpose == COPY_ALLOC_COMP && !c->attr.proc_pointer + && !c->attr.codimension && !caf_in_coarray (caf_mode) + && c->ts.type == BT_DERIVED && c->ts.u.derived != NULL) + { + tree copy_wrapper, call, dest_addr, src_addr, elem_type; + tree helper_ptr_type; + tree alloc_expr; + int comp_rank; + + /* Get the element type from ctype (already the component + type). For arrays we need the element type, not the array + type. */ + elem_type = ctype; + if (GFC_DESCRIPTOR_TYPE_P (ctype)) + elem_type = gfc_get_element_type (ctype); + else if (TREE_CODE (ctype) == ARRAY_TYPE) + elem_type = TREE_TYPE (ctype); + + helper_ptr_type = get_copy_helper_pointer_type (); + + comp_rank = c->as ? c->as->rank : 0; + alloc_expr = gfc_duplicate_allocatable_nocopy (dcmp, comp, ctype, + comp_rank); + gfc_add_expr_to_block (&fnblock, alloc_expr); + + /* Generate or reuse the element copy helper. Inside an + existing helper we can reuse the current function to + prevent recursive generation. */ + if (inside_wrapper) + copy_wrapper + = gfc_build_addr_expr (NULL_TREE, current_function_decl); + else + copy_wrapper + = generate_element_copy_wrapper (c->ts.u.derived, elem_type, + purpose, caf_mode); + copy_wrapper = fold_convert (helper_ptr_type, copy_wrapper); + + /* Build addresses of descriptors. */ + dest_addr = gfc_build_addr_expr (pvoid_type_node, dcmp); + src_addr = gfc_build_addr_expr (pvoid_type_node, comp); + + /* Build call: _gfortran_cfi_deep_copy_array (&dcmp, &comp, + wrapper). */ + call = build_call_expr_loc (input_location, + gfor_fndecl_cfi_deep_copy_array, 3, + dest_addr, src_addr, + copy_wrapper); + gfc_add_expr_to_block (&fnblock, call); + } else if (c->attr.allocatable && !c->attr.proc_pointer - && (!(cmp_has_alloc_comps && c->as) || c->attr.codimension + && (add_when_allocated != NULL_TREE + || !cmp_has_alloc_comps + || !c->as + || c->attr.codimension || caf_in_coarray (caf_mode))) { rank = c->as ? c->as->rank : 0; @@ -10662,9 +11114,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 +11149,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 +11198,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 +11273,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 +11367,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 +11574,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 +11696,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 +11823,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 +11910,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 +11964,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 +12131,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 +12285,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 +12506,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 +12603,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 +12954,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 +13235,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..6439a15 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); @@ -491,6 +488,27 @@ build_common_decl (gfc_common_head *com, tree union_type, bool is_init) } omp_clauses = c; } + /* Also check trans-decl.cc when updating/removing the following; + also update f95.c's gfc_gnu_attributes. + For the warning, see also OpenMP spec issue 4663. */ + if (com->omp_groupprivate && com->threadprivate) + { + /* Unset this flag; implicit 'declare target local(...)' remains. */ + com->omp_groupprivate = 0; + gfc_warning (OPT_Wopenmp, + "Ignoring the %<groupprivate%> attribute for " + "%<threadprivate%> common block %</%s/%> declared at %L", + com->name, &com->where); + } + if (com->omp_groupprivate) + gfc_error ("Sorry, OMP GROUPPRIVATE not implemented, used by common " + "block %</%s/%> declared at %L", com->name, &com->where); + else if (com->omp_declare_target_local) + /* Use 'else if' as groupprivate implies 'local'. */ + gfc_error ("Sorry, OMP DECLARE TARGET with LOCAL clause not implemented" + ", used by common block %</%s/%> declared at %L", + com->name, &com->where); + if (com->omp_declare_target_link) DECL_ATTRIBUTES (decl) = tree_cons (get_identifier ("omp declare target link"), @@ -500,10 +518,12 @@ build_common_decl (gfc_common_head *com, tree union_type, bool is_init) = tree_cons (get_identifier ("omp declare target"), omp_clauses, DECL_ATTRIBUTES (decl)); - if (com->omp_declare_target_link || com->omp_declare_target) + if (com->omp_declare_target_link || com->omp_declare_target + /* FIXME: || com->omp_declare_target_local */) { - /* Add to offload_vars; get_create does so for omp_declare_target, - omp_declare_target_link requires manual work. */ + /* Add to offload_vars; get_create does so for omp_declare_target + and omp_declare_target_local, omp_declare_target_link requires + manual work. */ gcc_assert (symtab_node::get (decl) == 0); symtab_node *node = symtab_node::get_create (decl); if (node != NULL && com->omp_declare_target_link) @@ -536,6 +556,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; } @@ -1044,8 +1068,10 @@ accumulate_equivalence_attributes (symbol_attribute *dummy_symbol, gfc_equiv *e) dummy_symbol->generic |= attr.generic; dummy_symbol->automatic |= attr.automatic; dummy_symbol->threadprivate |= attr.threadprivate; + dummy_symbol->omp_groupprivate |= attr.omp_groupprivate; dummy_symbol->omp_declare_target |= attr.omp_declare_target; dummy_symbol->omp_declare_target_link |= attr.omp_declare_target_link; + dummy_symbol->omp_declare_target_local |= attr.omp_declare_target_local; dummy_symbol->oacc_declare_copyin |= attr.oacc_declare_copyin; dummy_symbol->oacc_declare_create |= attr.oacc_declare_create; dummy_symbol->oacc_declare_deviceptr |= attr.oacc_declare_deviceptr; diff --git a/gcc/fortran/trans-const.cc b/gcc/fortran/trans-const.cc index ea1501a..b1bf567 100644 --- a/gcc/fortran/trans-const.cc +++ b/gcc/fortran/trans-const.cc @@ -438,4 +438,14 @@ gfc_conv_constant (gfc_se * se, gfc_expr * expr) structure, too. */ if (expr->ts.type == BT_CHARACTER) se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr))); + + if (se->want_pointer) + { + if (expr->ts.type == BT_CHARACTER) + gfc_conv_string_parameter (se); + else + se->expr + = gfc_build_addr_expr (NULL_TREE, + gfc_trans_force_lval (&se->pre, se->expr)); + } } diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index 43bd7be..06edc99 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. */ @@ -240,6 +248,9 @@ tree gfor_fndecl_zgemm; /* RANDOM_INIT function. */ tree gfor_fndecl_random_init; /* libgfortran, 1 image only. */ +/* Deep copy helper for recursive allocatable array components. */ +tree gfor_fndecl_cfi_deep_copy_array; + static void gfc_add_decl_to_parent_function (tree decl) { @@ -821,11 +832,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 +850,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); } @@ -1549,7 +1560,11 @@ add_attributes_to_decl (tree *decl_p, const gfc_symbol *sym) clauses = c; } - if (sym_attr.omp_device_type != OMP_DEVICE_TYPE_UNSET) + /* FIXME: 'declare_target_link' permits both any and host, but + will fail if one sets OMP_CLAUSE_DEVICE_TYPE_KIND. */ + if (sym_attr.omp_device_type != OMP_DEVICE_TYPE_UNSET + && !sym_attr.omp_declare_target_link + && !sym_attr.omp_declare_target_indirect /* implies 'any' */) { tree c = build_omp_clause (UNKNOWN_LOCATION, OMP_CLAUSE_DEVICE_TYPE); switch (sym_attr.omp_device_type) @@ -1570,6 +1585,26 @@ add_attributes_to_decl (tree *decl_p, const gfc_symbol *sym) clauses = c; } + /* Also check trans-common.cc when updating/removing the following; + also update f95.c's gfc_gnu_attributes. + For the warning, see also OpenMP spec issue 4663. */ + if (sym_attr.omp_groupprivate && sym_attr.threadprivate) + { + /* Unset this flag; implicit 'declare target local(...)' remains. */ + sym_attr.omp_groupprivate = 0; + gfc_warning (OPT_Wopenmp, + "Ignoring the %<groupprivate%> attribute for " + "%<threadprivate%> variable %qs declared at %L", + sym->name, &sym->declared_at); + } + if (sym_attr.omp_groupprivate) + gfc_error ("Sorry, OMP GROUPPRIVATE not implemented, " + "used by %qs declared at %L", sym->name, &sym->declared_at); + else if (sym_attr.omp_declare_target_local) + /* Use 'else if' as groupprivate implies 'local'. */ + gfc_error ("Sorry, OMP DECLARE TARGET with LOCAL clause not implemented, " + "used by %qs declared at %L", sym->name, &sym->declared_at); + bool has_declare = true; if (sym_attr.omp_declare_target_link || sym_attr.oacc_declare_link) @@ -1680,6 +1715,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 +2256,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 +3609,29 @@ 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); + + { + tree copy_helper_ptr_type; + tree copy_helper_fn_type; + + copy_helper_fn_type = build_function_type_list (void_type_node, + pvoid_type_node, + pvoid_type_node, + NULL_TREE); + copy_helper_ptr_type = build_pointer_type (copy_helper_fn_type); + + gfor_fndecl_cfi_deep_copy_array + = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX ("cfi_deep_copy_array")), ". R R . ", + void_type_node, 3, pvoid_type_node, pvoid_type_node, + copy_helper_ptr_type); + } + 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 +3704,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 +3965,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); } @@ -4469,7 +4566,8 @@ gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body) and using trans_assignment to do the work. Set dealloc to false if no deallocation prior the assignment is needed. */ void -gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc) +gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc, + bool pdt_ok) { gfc_expr *e; tree tmp; @@ -4478,7 +4576,8 @@ gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc) gcc_assert (block); /* Initialization of PDTs is done elsewhere. */ - if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type) + if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type + && !pdt_ok) return; gcc_assert (!sym->attr.allocatable); @@ -4497,6 +4596,28 @@ gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc) } +/* Initialize a PDT, when all the components have an initializer. */ +static void +gfc_init_default_pdt (gfc_symbol *sym, stmtblock_t *block, bool dealloc) +{ + /* Allowed in the case where all the components have initializers and + there are no LEN components. */ + if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type) + { + gfc_component *c = sym->ts.u.derived->components; + if (!dealloc || !sym->value || sym->value->expr_type != EXPR_STRUCTURE) + return; + for (; c; c = c->next) + if (c->attr.pdt_len || !c->initializer) + return; + } + else + return; + gfc_init_default_dt (sym, block, dealloc, true); + return; +} + + /* Initialize INTENT(OUT) derived type dummies. As well as giving them their default initializer, if they have allocatable components, they have their allocatable components deallocated. */ @@ -4773,16 +4894,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 +4994,31 @@ 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 (is_pdt_type) + gfc_init_default_pdt (sym, &tmpblock, true); + + 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 +5066,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 +5264,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 +5469,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..ac85b76 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,63 @@ 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 (expr->ts.type == BT_CHARACTER) + se->string_length + = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node, + condition, true_se.string_length, + false_se.string_length); +} + /* If a string's length is one, we convert it to a single character. */ tree @@ -4625,6 +4713,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 +5374,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 +5548,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) @@ -5995,9 +6090,6 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym) se.want_pointer = 1; gfc_conv_expr (&se, e); gfc = se.expr; - /* gfc_conv_constant ignores se.want_poiner, e.g. for string_cst. */ - if (!POINTER_TYPE_P (TREE_TYPE (gfc))) - gfc = gfc_build_addr_expr (NULL, gfc); } else { @@ -6479,6 +6571,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 +6595,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 +6640,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. @@ -6556,11 +6696,14 @@ conv_dummy_value (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym, argse.want_pointer = 1; gfc_conv_expr (&argse, e); cond = fold_convert (TREE_TYPE (argse.expr), null_pointer_node); - cond = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, argse.expr, cond); - vec_safe_push (optionalargs, - fold_convert (boolean_type_node, cond)); + if (e->symtree->n.sym->attr.dummy) + cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + logical_type_node, + gfc_conv_expr_present (e->symtree->n.sym), + cond); + vec_safe_push (optionalargs, fold_convert (boolean_type_node, cond)); /* Create "conditional temporary". */ conv_cond_temp (parmse, e, cond); } @@ -7510,7 +7653,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 +8030,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 +8280,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 +8964,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 +9693,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 +10528,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 +10675,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 +11269,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 { @@ -11214,21 +11344,33 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) int dim; gcc_assert (remap->u.ar.dimen == expr1->rank); + /* Always set dtype. */ + tree dtype = gfc_conv_descriptor_dtype (desc); + tmp = gfc_get_dtype (TREE_TYPE (desc)); + gfc_add_modify (&block, dtype, tmp); + + /* For unlimited polymorphic LHS use elem_len from RHS. */ + if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS) + { + tree elem_len; + tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts)); + elem_len = fold_convert (gfc_array_index_type, tmp); + elem_len = gfc_evaluate_now (elem_len, &block); + tmp = gfc_conv_descriptor_elem_len (desc); + gfc_add_modify (&block, tmp, + fold_convert (TREE_TYPE (tmp), elem_len)); + } + if (rank_remap) { /* Do rank remapping. We already have the RHS's descriptor converted in rse and now have to build the correct LHS descriptor for it. */ - tree dtype, data, span; + tree data, span; tree offs, stride; tree lbound, ubound; - /* Set dtype. */ - dtype = gfc_conv_descriptor_dtype (desc); - tmp = gfc_get_dtype (TREE_TYPE (desc)); - gfc_add_modify (&block, dtype, tmp); - /* Copy data pointer. */ data = gfc_conv_descriptor_data_get (rse.expr); gfc_conv_descriptor_data_set (&block, desc, data); @@ -11421,6 +11563,29 @@ gfc_conv_string_parameter (gfc_se * se) return; } + if (TREE_CODE (se->expr) == COND_EXPR) + { + tree cond = TREE_OPERAND (se->expr, 0); + tree lhs = TREE_OPERAND (se->expr, 1); + tree rhs = TREE_OPERAND (se->expr, 2); + + gfc_se lse, rse; + gfc_init_se (&lse, NULL); + gfc_init_se (&rse, NULL); + + lse.expr = lhs; + lse.string_length = se->string_length; + gfc_conv_string_parameter (&lse); + + rse.expr = rhs; + rse.string_length = se->string_length; + gfc_conv_string_parameter (&rse); + + se->expr + = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (lse.expr), + cond, lse.expr, rse.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))) @@ -11535,7 +11700,17 @@ gfc_trans_scalar_assign (gfc_se *lse, gfc_se *rse, gfc_typespec ts, } gfc_add_block_to_block (&block, &rse->pre); - gfc_add_block_to_block (&block, &lse->finalblock); + + /* Skip finalization for self-assignment. */ + if (deep_copy && lse->finalblock.head) + { + tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location), + gfc_finish_block (&lse->finalblock)); + gfc_add_expr_to_block (&block, tmp); + } + else + gfc_add_block_to_block (&block, &lse->finalblock); + gfc_add_block_to_block (&block, &lse->pre); gfc_add_modify (&block, lse->expr, @@ -12521,12 +12696,30 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block, to make sure we do not check for reallocation unneccessarily. */ +/* Strip parentheses from an expression to get the underlying variable. + This is needed for self-assignment detection since (a) creates a + parentheses operator node. */ + +static gfc_expr * +strip_parentheses (gfc_expr *expr) +{ + while (expr->expr_type == EXPR_OP + && expr->value.op.op == INTRINSIC_PARENTHESES) + expr = expr->value.op.op1; + return expr; +} + + static bool is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2) { gfc_actual_arglist *a; gfc_expr *e1, *e2; + /* Strip parentheses to handle cases like a = (a). */ + expr1 = strip_parentheses (expr1); + expr2 = strip_parentheses (expr2); + switch (expr2->expr_type) { case EXPR_VARIABLE: @@ -12849,16 +13042,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 +13102,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 +13113,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 +13132,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 +13186,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 +13281,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); } } @@ -13203,10 +13421,15 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, } /* Comply with F2018 (7.5.6.3). Make sure that any finalization code is added - after evaluation of the rhs and before reallocation. */ + after evaluation of the rhs and before reallocation. + Skip finalization for self-assignment to avoid use-after-free. + Strip parentheses from both sides to handle cases like a = (a). */ final_expr = gfc_assignment_finalizer_call (&lse, expr1, init_flag); - if (final_expr && !(expr2->expr_type == EXPR_VARIABLE - && expr2->symtree->n.sym->attr.artificial)) + if (final_expr + && gfc_dep_compare_expr (strip_parentheses (expr1), + strip_parentheses (expr2)) != 0 + && !(strip_parentheses (expr2)->expr_type == EXPR_VARIABLE + && strip_parentheses (expr2)->symtree->n.sym->attr.artificial)) { if (lss == gfc_ss_terminator) { @@ -13229,13 +13452,18 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, /* If nothing else works, do it the old fashioned way! */ if (tmp == NULL_TREE) - tmp - = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, - gfc_expr_is_variable (expr2) || scalar_to_array - || expr2->expr_type == EXPR_ARRAY, - !(l_is_temp || init_flag) && dealloc, - expr1->symtree->n.sym->attr.codimension, - assoc_assign); + { + /* Strip parentheses to detect cases like a = (a) which need deep_copy. */ + gfc_expr *expr2_stripped = strip_parentheses (expr2); + tmp + = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, + gfc_expr_is_variable (expr2_stripped) + || scalar_to_array + || expr2->expr_type == EXPR_ARRAY, + !(l_is_temp || init_flag) && dealloc, + expr1->symtree->n.sym->attr.codimension, + assoc_assign); + } /* Add the lse pre block to the body */ gfc_add_block_to_block (&body, &lse.pre); @@ -13298,15 +13526,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 +13542,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 +13621,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 +13632,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..91c0301 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); @@ -2316,10 +2316,14 @@ gfc_conv_is_contiguous_expr (gfc_se *se, gfc_expr *arg) int i; tree fncall0; gfc_array_spec *as; + gfc_symbol *sym = NULL; if (arg->ts.type == BT_CLASS) gfc_add_class_array_ref (arg); + if (arg->expr_type == EXPR_VARIABLE) + sym = arg->symtree->n.sym; + ss = gfc_walk_expr (arg); gcc_assert (ss != gfc_ss_terminator); gfc_init_se (&argse, NULL); @@ -2342,7 +2346,7 @@ gfc_conv_is_contiguous_expr (gfc_se *se, gfc_expr *arg) fncall0 = build_call_expr_loc (input_location, gfor_fndecl_is_contiguous0, 1, desc); se->expr = fncall0; - se->expr = convert (logical_type_node, se->expr); + se->expr = convert (boolean_type_node, se->expr); } else { @@ -2374,6 +2378,22 @@ gfc_conv_is_contiguous_expr (gfc_se *se, gfc_expr *arg) } se->expr = cond; } + + /* A pointer that does not have the CONTIGUOUS attribute needs to be checked + if it points to an array whose span differs from the element size. */ + if (as && sym && IS_POINTER(sym) && !sym->attr.contiguous) + { + tree span = gfc_conv_descriptor_span_get (desc); + tmp = fold_convert (TREE_TYPE (span), + gfc_conv_descriptor_elem_len (desc)); + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + span, tmp); + se->expr = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + boolean_type_node, cond, + convert (boolean_type_node, se->expr)); + } + + gfc_free_ss_chain (ss); } @@ -3466,6 +3486,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 +4803,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 +4997,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 +5016,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 +5025,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 +5056,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 +5891,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. @@ -8561,13 +8748,18 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) } else { + bool simply_contiguous = gfc_is_simply_contiguous (arg->expr, + false, true); argse.want_pointer = 0; + /* A non-contiguous SOURCE needs packing. */ + if (!simply_contiguous) + argse.force_tmp = 1; gfc_conv_expr_descriptor (&argse, arg->expr); source = gfc_conv_descriptor_data_get (argse.expr); source_type = gfc_get_element_type (TREE_TYPE (argse.expr)); /* Repack the source if not simply contiguous. */ - if (!gfc_is_simply_contiguous (arg->expr, false, true)) + if (!simply_contiguous) { tmp = gfc_build_addr_expr (NULL_TREE, argse.expr); @@ -8604,7 +8796,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 +10068,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 +10111,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 +10128,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 +10165,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); @@ -12328,11 +12559,23 @@ conv_intrinsic_atomic_op (gfc_code *code) else image_index = integer_zero_node; + /* Ensure VALUE names addressable storage: taking the address of a + constant is invalid in C, and scalars need a temporary as well. */ if (!POINTER_TYPE_P (TREE_TYPE (value))) { - tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (atom)), "value"); - gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), value)); - value = gfc_build_addr_expr (NULL_TREE, tmp); + tree elem + = fold_convert (TREE_TYPE (TREE_TYPE (atom)), value); + elem = gfc_trans_force_lval (&block, elem); + value = gfc_build_addr_expr (NULL_TREE, elem); + } + else if (TREE_CODE (value) == ADDR_EXPR + && TREE_CONSTANT (TREE_OPERAND (value, 0))) + { + tree elem + = fold_convert (TREE_TYPE (TREE_TYPE (atom)), + build_fold_indirect_ref (value)); + elem = gfc_trans_force_lval (&block, elem); + value = gfc_build_addr_expr (NULL_TREE, elem); } gfc_init_se (&argse, NULL); @@ -12613,14 +12856,6 @@ conv_intrinsic_atomic_cas (gfc_code *code) new_val = gfc_build_addr_expr (NULL_TREE, tmp); } - /* Convert a constant to a pointer. */ - if (!POINTER_TYPE_P (TREE_TYPE (comp))) - { - tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (old)), "comp"); - gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), comp)); - comp = gfc_build_addr_expr (NULL_TREE, tmp); - } - gfc_init_se (&argse, NULL); gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom, atom_expr); @@ -13122,6 +13357,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 +13432,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 +13501,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 +13523,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..8eb4fc4 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); @@ -4154,7 +4180,9 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, tree type = TREE_TYPE (decl); if (n->sym->ts.type == BT_CHARACTER && n->sym->ts.deferred - && n->sym->attr.omp_declare_target + && (n->sym->attr.omp_declare_target + || n->sym->attr.omp_declare_target_link + || n->sym->attr.omp_declare_target_local) && (always_modifier || n->sym->attr.pointer) && op != EXEC_OMP_TARGET_EXIT_DATA && n->u.map.op != OMP_MAP_DELETE @@ -4966,7 +4994,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) @@ -5236,6 +5265,37 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, omp_clauses = gfc_trans_add_clause (c, omp_clauses); } + if (clauses->dyn_groupprivate) + { + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->dyn_groupprivate); + gfc_add_block_to_block (block, &se.pre); + tree expr = (CONSTANT_CLASS_P (se.expr) || DECL_P (se.expr) + ? se.expr : gfc_evaluate_now (se.expr, block)); + gfc_add_block_to_block (block, &se.post); + + enum omp_clause_fallback_kind kind = OMP_CLAUSE_FALLBACK_UNSPECIFIED; + switch (clauses->fallback) + { + case OMP_FALLBACK_ABORT: + kind = OMP_CLAUSE_FALLBACK_ABORT; + break; + case OMP_FALLBACK_DEFAULT_MEM: + kind = OMP_CLAUSE_FALLBACK_DEFAULT_MEM; + break; + case OMP_FALLBACK_NULL: + kind = OMP_CLAUSE_FALLBACK_NULL; + break; + case OMP_FALLBACK_NONE: + break; + } + c = build_omp_clause (gfc_get_location (&where), + OMP_CLAUSE_DYN_GROUPPRIVATE); + OMP_CLAUSE_DYN_GROUPPRIVATE_KIND (c) = kind; + OMP_CLAUSE_DYN_GROUPPRIVATE_EXPR (c) = expr; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + chunk_size = NULL_TREE; if (clauses->chunk_size) { @@ -6028,6 +6088,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 +9747,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 +9768,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..0e82d2a 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; @@ -2025,6 +2092,22 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) gfc_free_expr (expr1); gfc_free_expr (expr2); } + /* PDT array and string components are separately allocated for each element + of a PDT array. Therefore, there is no choice but to copy in and copy out + the target expression. */ + else if (e && is_subref_array (e) + && (gfc_expr_attr (e).pdt_array || gfc_expr_attr (e).pdt_string)) + { + gfc_se init; + gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl))); + gfc_init_se (&init, NULL); + gfc_conv_subref_array_arg (&init, e, false, INTENT_INOUT, + sym && sym->attr.pointer); + init.expr = build_fold_indirect_ref_loc (input_location, init.expr); + gfc_add_modify (&init.pre, sym->backend_decl, init.expr); + gfc_add_init_cleanup (block, gfc_finish_block (&init.pre), + gfc_finish_block (&init.post)); + } else if ((sym->attr.dimension || sym->attr.codimension) && !class_target && (sym->as->type == AS_DEFERRED || sym->assoc->variable)) { @@ -2046,7 +2129,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 +2195,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 +2305,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 +2481,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 +6698,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 +7229,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 +7299,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 +7938,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 +7955,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 3374778..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); @@ -1140,11 +1144,6 @@ gfc_init_types (void) } gfc_character1_type_node = gfc_character_types[0]; - /* The middle end only recognizes a single unsigned type. For - compatibility of existing test cases, let's just use the - character type. The reader of tree dumps is expected to be able - to deal with this. */ - if (flag_unsigned) { for (index = 0; gfc_unsigned_kinds[index].kind != 0;++index) @@ -1159,18 +1158,26 @@ gfc_init_types (void) break; } } - if (index_char > 0) + if (index_char > -1) { - gfc_unsigned_types[index] = gfc_character_types[index_char]; + type = gfc_character_types[index_char]; + if (TYPE_STRING_FLAG (type)) + { + type = build_distinct_type_copy (type); + TYPE_CANONICAL (type) + = TYPE_CANONICAL (gfc_character_types[index_char]); + } + else + type = build_variant_type_copy (type); + TYPE_NAME (type) = NULL_TREE; + TYPE_STRING_FLAG (type) = 0; } else - { - type = gfc_build_unsigned_type (&gfc_unsigned_kinds[index]); - gfc_unsigned_types[index] = type; - snprintf (name_buf, sizeof(name_buf), "unsigned(kind=%d)", - gfc_integer_kinds[index].kind); - PUSH_TYPE (name_buf, type); - } + type = gfc_build_unsigned_type (&gfc_unsigned_kinds[index]); + gfc_unsigned_types[index] = type; + snprintf (name_buf, sizeof(name_buf), "unsigned(kind=%d)", + gfc_integer_kinds[index].kind); + PUSH_TYPE (name_buf, type); } } @@ -3184,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) { @@ -3228,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; @@ -3433,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..52cebf5 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. */ @@ -670,7 +666,8 @@ tree gfc_get_symbol_decl (gfc_symbol *); tree gfc_conv_initializer (gfc_expr *, gfc_typespec *, tree, bool, bool, bool); /* Assign a default initializer to a derived type. */ -void gfc_init_default_dt (gfc_symbol *, stmtblock_t *, bool); +void gfc_init_default_dt (gfc_symbol *, stmtblock_t *, bool, + bool pdt_ok = false); /* Substitute a temporary variable in place of the real one. */ void gfc_shadow_sym (gfc_symbol *, tree, gfc_saved_var *); @@ -961,6 +958,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 +970,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 +984,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; @@ -1000,6 +1005,9 @@ extern GTY(()) tree gfor_fndecl_ieee_procedure_exit; extern GTY(()) tree gfor_fndecl_random_init; extern GTY(()) tree gfor_fndecl_caf_random_init; +/* Deep copy helper for recursive allocatable array components. */ +extern GTY(()) tree gfor_fndecl_cfi_deep_copy_array; + /* True if node is an integer constant. */ #define INTEGER_CST_P(node) (TREE_CODE(node) == INTEGER_CST) |