diff options
| author | Ian Lance Taylor <iant@golang.org> | 2023-06-21 11:04:04 -0700 |
|---|---|---|
| committer | Ian Lance Taylor <iant@golang.org> | 2023-06-21 11:04:04 -0700 |
| commit | 97e31a0a2a2d2273687fcdb4e5416aab1a2186e1 (patch) | |
| tree | d5c1cae4de436a0fe54a5f0a2a197d309f3d654c /gcc/fortran | |
| parent | 6612f4f8cb9b0d5af18ec69ad04e56debc3e6ced (diff) | |
| parent | 577223aebc7acdd31e62b33c1682fe54a622ae27 (diff) | |
| download | gcc-97e31a0a2a2d2273687fcdb4e5416aab1a2186e1.zip gcc-97e31a0a2a2d2273687fcdb4e5416aab1a2186e1.tar.gz gcc-97e31a0a2a2d2273687fcdb4e5416aab1a2186e1.tar.bz2 | |
Merge from trunk revision 577223aebc7acdd31e62b33c1682fe54a622ae27.
Diffstat (limited to 'gcc/fortran')
46 files changed, 2527 insertions, 607 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index ff39055..147fb1d 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,540 @@ +2023-06-20 Tobias Burnus <tobias@codesourcery.com> + + * dump-parse-tree.cc (show_omp_namelist): Fix dump of the allocator + modifier of OMP_LIST_ALLOCATE. + +2023-06-20 Tobias Burnus <tobias@codesourcery.com> + + * match.cc (gfc_match_char): Match with '%S' a symbol + with host_assoc = 1. + +2023-06-19 Tobias Burnus <tobias@codesourcery.com> + + * intrinsic.texi (OpenMP Modules OMP_LIB and OMP_LIB_KINDS): Also + add references to the OpenMP 5.1 and 5.2 spec; add omp_initial_device + and omp_invalid_device named constants. + +2023-06-13 Harald Anlauf <anlauf@gmx.de> + Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/86277 + * trans-array.cc (gfc_trans_allocate_array_storage): When passing a + zero-sized array with fixed (= non-dynamic) size, allocate temporary + by the caller, not by the callee. + +2023-06-10 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + * f95-lang.cc (gfc_init_builtin_functions): Add fmax() and + fmin() built-ins, and their variants. + * mathbuiltins.def: Add FMAX and FMIN built-ins. + * trans-intrinsic.cc (conv_intrinsic_ieee_minmax): New function. + (gfc_conv_ieee_arithmetic_function): Handle IEEE_MIN_NUM and + IEEE_MAX_NUM functions. + +2023-06-09 Jakub Jelinek <jakub@redhat.com> + + PR fortran/96024 + * primary.cc (gfc_convert_to_structure_constructor): Only do + constant string ctor length verification and truncation/padding + if constant length has INTEGER type. + +2023-06-08 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/87477 + PR fortran/99350 + PR fortran/107821 + PR fortran/109451 + * decl.cc (char_len_param_value): Simplify a copy of the expr + and replace the original if there is no error. + * gfortran.h : Remove the redundant field 'rankguessed' from + 'gfc_association_list'. + * resolve.cc (resolve_assoc_var): Remove refs to 'rankguessed'. + (resolve_variable): Associate names with constant or structure + constructor targets cannot have array refs. + * trans-array.cc (gfc_conv_expr_descriptor): Guard expression + character length backend decl before using it. Suppress the + assignment if lhs equals rhs. + * trans-io.cc (gfc_trans_transfer): Scalarize transfer of + associate variables pointing to a variable. Add comment. + * trans-stmt.cc (trans_associate_var): Remove requirement that + the character length be deferred before assigning the value + returned by gfc_conv_expr_descriptor. Also, guard the backend + decl before testing with VAR_P. + +2023-06-06 Kwok Cheung Yeung <kcy@codesourcery.com> + Tobias Burnus <tobias@codesourcery.com> + + * dump-parse-tree.cc (show_omp_namelist): Display 'present' map + modifier. + (show_omp_clauses): Display 'present' motion modifier for 'to' + and 'from' clauses. + * gfortran.h (enum gfc_omp_map_op): Add entries with 'present' + modifiers. + (struct gfc_omp_namelist): Add 'present_modifer'. + * openmp.cc (gfc_match_motion_var_list): New, handles optional + 'present' modifier for to/from clauses. + (gfc_match_omp_clauses): Call it for to/from clauses; parse 'present' + in defaultmap and map clauses. + (resolve_omp_clauses): Allow 'present' modifiers on 'target', + 'target data', 'target enter' and 'target exit' directives. + * trans-openmp.cc (gfc_trans_omp_clauses): Apply 'present' modifiers + to tree node for 'map', 'to' and 'from' clauses. Apply 'present' for + defaultmap. + +2023-06-02 Steve Kargl <kargl@gcc.gnu.org> + + PR fortran/100607 + * resolve.cc (resolve_select_rank): Remove duplicate error. + (resolve_fl_var_and_proc): Prevent NULL pointer dereference and + suppress error message for temporary. + +2023-06-02 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/87477 + * parse.cc (parse_associate): Replace the existing evaluation + of the target rank with calls to gfc_resolve_ref and + gfc_expression_rank. Identify untyped target function results + with structure constructors by finding the appropriate derived + type. + * resolve.cc (resolve_symbol): Allow associate variables to be + assumed shape. + +2023-06-01 Harald Anlauf <anlauf@gmx.de> + + PR fortran/88552 + * decl.cc (gfc_match_kind_spec): Use error path on missing right + parenthesis. + (gfc_match_decl_type_spec): Use error return when an error occurred + during matching a KIND specifier. + +2023-06-01 Tobias Burnus <tobias@codesourcery.com> + + * parse.cc (decode_omp_directive): Accept all pure directives + inside a PURE procedures; handle 'error at(execution). + +2023-05-26 Tobias Burnus <tobias@codesourcery.com> + + * dump-parse-tree.cc (show_omp_namelist): Update allocator, fix + align dump. + (show_omp_node, show_code_node): Handle EXEC_OMP_ALLOCATE. + * gfortran.h (enum gfc_statement): Add ST_OMP_ALLOCATE and ..._EXEC. + (enum gfc_exec_op): Add EXEC_OMP_ALLOCATE. + (struct gfc_omp_namelist): Add 'allocator' to 'u2' union. + (struct gfc_namespace): Add omp_allocate. + (gfc_resolve_omp_allocate): New. + * match.cc (gfc_free_omp_namelist): Free 'u2.allocator'. + * match.h (gfc_match_omp_allocate, gfc_match_omp_allocators): New. + * openmp.cc (gfc_omp_directives): Uncomment allocate/allocators. + (gfc_match_omp_variable_list): Add bool arg for + rejecting listening common-block vars separately. + (gfc_match_omp_clauses): Update for u2.allocators. + (OMP_ALLOCATORS_CLAUSES, gfc_match_omp_allocate, + gfc_match_omp_allocators, is_predefined_allocator, + gfc_resolve_omp_allocate): New. + (resolve_omp_clauses): Update 'allocate' clause checks. + (omp_code_to_statement, gfc_resolve_omp_directive): Handle + OMP ALLOCATE/ALLOCATORS. + * parse.cc (in_exec_part): New global var. + (check_omp_allocate_stmt, parse_openmp_allocate_block): New. + (decode_omp_directive, case_exec_markers, case_omp_decl, + gfc_ascii_statement, parse_omp_structured_block): Handle + OMP allocate/allocators. + (verify_st_order, parse_executable): Set in_exec_part. + * resolve.cc (gfc_resolve_blocks, resolve_codes): Handle + allocate/allocators. + * st.cc (gfc_free_statement): Likewise. + * trans.cc (trans_code): Likewise. + * trans-openmp.cc (gfc_trans_omp_directive): Likewise. + (gfc_trans_omp_clauses, gfc_split_omp_clauses): Update for + u2.allocator, fix for u.align. + +2023-05-24 Harald Anlauf <anlauf@gmx.de> + + PR fortran/104350 + * simplify.cc (simplify_size): Reject DIM argument of intrinsic SIZE + with error when out of valid range. + +2023-05-24 Harald Anlauf <anlauf@gmx.de> + + PR fortran/103794 + * check.cc (gfc_check_reshape): Expand constant arguments SHAPE and + ORDER before checking. + * gfortran.h (gfc_is_constant_array_expr): Add prototype. + * iresolve.cc (gfc_resolve_reshape): Expand constant argument SHAPE. + * simplify.cc (is_constant_array_expr): If array is determined to be + constant, expand small array constructors if needed. + (gfc_is_constant_array_expr): Wrapper for is_constant_array_expr. + (gfc_simplify_reshape): Fix check for insufficient elements in SOURCE + when no padding specified. + +2023-05-23 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/103716 + * resolve.cc (gfc_resolve_ref): Conversion of array_ref into an + element should be done for all characters without a len expr, + not just deferred lens, and for integer expressions. + * trans-expr.cc (conv_inquiry): For len and kind inquiry refs, + set the se string_length to NULL_TREE. + +2023-05-23 Paul Thomas <pault@gcc.gnu.org> + Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/97122 + * decl.cc (variable_decl): Clean up white space issues. + (gfc_match_final_decl): Declaration of finalizable derived type + is allowed in a submodule. + +2023-05-19 Bernhard Reutner-Fischer <aldot@gcc.gnu.org> + + * expr.cc (gfc_get_corank): Use CLASS_DATA from gfortran.h. + * resolve.cc (resolve_component): Same. + (resolve_fl_derived0): Same. + * simplify.cc (gfc_simplify_extends_type_of): Same. + (simplify_cobound): Same. + +2023-05-18 Bernhard Reutner-Fischer <aldot@gcc.gnu.org> + + * trans-array.cc (is_pointer_array): Use _P() defines from tree.h. + (gfc_conv_scalarized_array_ref): Ditto. + (gfc_conv_array_ref): Ditto. + * trans-decl.cc (gfc_finish_decl): Ditto. + (gfc_get_symbol_decl): Ditto. + * trans-expr.cc (gfc_trans_pointer_assignment): Ditto. + (gfc_trans_arrayfunc_assign): Ditto. + (gfc_trans_assignment_1): Ditto. + * trans-intrinsic.cc (gfc_conv_intrinsic_minmax): Ditto. + (conv_intrinsic_ieee_value): Ditto. + * trans-io.cc (gfc_convert_array_to_string): Ditto. + * trans-openmp.cc (gfc_omp_is_optional_argument): Ditto. + (gfc_trans_omp_clauses): Ditto. + * trans-stmt.cc (gfc_conv_label_variable): Ditto. + * trans.cc (gfc_build_addr_expr): Ditto. + (get_array_span): Ditto. + +2023-05-18 Bernhard Reutner-Fischer <aldot@gcc.gnu.org> + + PR fortran/78798 + * array.cc (compare_bounds): Use narrower return type. + (gfc_compare_array_spec): Likewise. + (is_constant_element): Likewise. + (gfc_constant_ac): Likewise. + * check.cc (dim_rank_check): Likewise. + * cpp.cc (gfc_cpp_init_options): Likewise. + (dump_macro): Likewise. + * cpp.h (gfc_cpp_handle_option): Likewise. + * dependency.cc (gfc_ref_needs_temporary_p): Likewise. + (gfc_check_argument_dependency): Likewise. + (gfc_check_fncall_dependency): Likewise. + (ref_same_as_full_array): Likewise. + * dependency.h (gfc_check_fncall_dependency): Likewise. + (gfc_dep_resolver): Likewise. + (gfc_are_equivalenced_arrays): Likewise. + * expr.cc (gfc_copy_ref): Likewise. + (gfc_kind_max): Likewise. + (numeric_type): Likewise. + * gfortran.h (gfc_at_end): Likewise. + (gfc_at_eof): Likewise. + (gfc_at_bol): Likewise. + (gfc_at_eol): Likewise. + (gfc_define_undef_line): Likewise. + (gfc_wide_is_printable): Likewise. + (gfc_wide_is_digit): Likewise. + (gfc_wide_fits_in_byte): Likewise. + (gfc_find_sym_tree): Likewise. + (gfc_generic_intrinsic): Likewise. + (gfc_specific_intrinsic): Likewise. + (gfc_intrinsic_actual_ok): Likewise. + (gfc_has_vector_index): Likewise. + (gfc_numeric_ts): Likewise. + (gfc_impure_variable): Likewise. + (gfc_pure): Likewise. + (gfc_implicit_pure): Likewise. + (gfc_elemental): Likewise. + (gfc_pure_function): Likewise. + (gfc_implicit_pure_function): Likewise. + (gfc_compare_array_spec): Likewise. + (gfc_constant_ac): Likewise. + (gfc_expanded_ac): Likewise. + (gfc_check_digit): Likewise. + * intrinsic.cc (gfc_find_subroutine): Likewise. + (gfc_generic_intrinsic): Likewise. + (gfc_specific_intrinsic): Likewise. + * io.cc (compare_to_allowed_values): Likewise. And remove + unneeded forward declaration. + * parse.cc: Likewise. + * parse.h (gfc_check_do_variable): Likewise. + * primary.cc (gfc_check_digit): Likewise. + * resolve.cc (resolve_structure_cons): Likewise. + (pure_stmt_function): Likewise. + (gfc_pure_function): Likewise. + (impure_stmt_fcn): Likewise. + (resolve_forall_iterators): Likewise. + (resolve_data): Likewise. + (gfc_impure_variable): Likewise. + (gfc_pure): Likewise. + (gfc_unset_implicit_pure): Likewise. + * scanner.cc (wide_is_ascii): Likewise. + (gfc_wide_toupper): Likewise. + (gfc_open_included_file): Likewise. + (gfc_at_end): Likewise. + (gfc_at_eof): Likewise. + (gfc_at_bol): Likewise. + (skip_comment_line): Likewise. + (gfc_gobble_whitespace): Likewise. + * symbol.cc (gfc_find_symtree_in_proc): Likewise. + * trans-array.cc: Likewise. + * trans-decl.cc (gfc_set_decl_assembler_name): Likewise. + * trans-types.cc (gfc_get_element_type): Likewise. + (gfc_add_field_to_struct): Likewise. + * trans-types.h (gfc_copy_dt_decls_ifequal): Likewise. + (gfc_return_by_reference): Likewise. + (gfc_is_nodesc_array): Likewise. + * trans.h (gfc_can_put_var_on_stack): Likewise. + +2023-05-17 Harald Anlauf <anlauf@gmx.de> + + PR fortran/95374 + PR fortran/104352 + * decl.cc (add_init_expr_to_sym): Set shape of initializer also for + zero-sized arrays, so that bounds violations can be detected later. + +2023-05-17 Tobias Burnus <tobias@codesourcery.com> + + * trans-decl.cc (gfc_get_symbol_decl): Add attributes + such as 'declare target' also to hidden artificial + variable for deferred-length character variables. + * trans-openmp.cc (gfc_trans_omp_array_section, + gfc_trans_omp_clauses, gfc_trans_omp_target_exit_data): + Improve mapping of array descriptors and deferred-length + string variables. + +2023-05-16 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/105152 + PR fortran/100193 + PR fortran/87496 + PR fortran/103389 + PR fortran/104429 + PR fortran/82774 + * interface.cc (gfc_compare_actual_formal): Emit an error if an + unlimited polymorphic actual is not matched either to an + unlimited or assumed type formal argument. + * resolve.cc (resolve_ordinary_assign): Emit an error if the + var expression of an ordinary assignment is a proc pointer + component. + * trans-array.cc (gfc_walk_array_ref): Provide assumed shape + arrays coming from interface mapping with a viable arrayspec. + * trans-expr.cc (gfc_conv_intrinsic_to_class): Tidy up flagging + of unlimited polymorphic 'class_ts'. + (gfc_conv_gfc_desc_to_cfi_desc): Assumed type is unlimited + polymorphic and should accept any actual type. + (gfc_conv_procedure_call): Replace dreadful kludge with a call + to gfc_finalize_tree_expr. Avoid dereferencing a void pointer + by giving it the pointer type of the actual argument. + (alloc_scalar_allocatable_subcomponent): Shorten the function + name and replace the symbol argument with the se string length. + If a deferred length character length is either not present or + is not a variable, give the typespec a variable and assign the + string length to that. Use gfc_deferred_strlen to find the + hidden string length component. + (gfc_trans_subcomponent_assign): Convert the expression before + the call to alloc_scalar_allocatable_subcomponent so that a + good string length is provided. + (gfc_trans_structure_assign): Remove the unneeded derived type + symbol from calls to gfc_trans_subcomponent_assign. + +2023-05-15 Harald Anlauf <anlauf@gmx.de> + + PR fortran/109846 + * expr.cc (gfc_check_vardef_context): Check appropriate pointer + attribute for CLASS vs. non-CLASS function result in variable + definition context. + +2023-05-11 Xi Ruoyao <xry111@xry111.site> + + * Make-lang.in: Use grep instead of fgrep. + +2023-05-10 Bernhard Reutner-Fischer <aldot@gcc.gnu.org> + + * dump-parse-tree.cc (gfc_debug_expr): Remove forward declaration. + (debug): Add DEBUG_FUNCTION. + (show_code_node): Remove erroneous whitespace. + +2023-05-10 Bernhard Reutner-Fischer <aldot@gcc.gnu.org> + + PR fortran/109624 + * dump-parse-tree.cc (debug): New function for gfc_namespace. + (gfc_debug_code): Delete forward declaration. + (show_attr): Make sure to print balanced braces. + +2023-05-08 Bernhard Reutner-Fischer <aldot@gcc.gnu.org> + + * resolve.cc (resolve_select_type): Fix coding style. + +2023-05-08 Bernhard Reutner-Fischer <aldot@gcc.gnu.org> + + * resolve.cc (resolve_select_type): Call free() unconditionally. + +2023-05-08 Bernhard Reutner-Fischer <aldot@gcc.gnu.org> + + PR fortran/68800 + * expr.cc (find_array_section): Fix mpz memory leak. + * simplify.cc (gfc_simplify_reshape): Fix mpz memory leaks in + error paths. + +2023-05-05 Harald Anlauf <anlauf@gmx.de> + + PR fortran/109641 + * arith.cc (eval_intrinsic): Check conformability of ranks of operands + for intrinsic binary operators before performing type conversions. + * gfortran.h (gfc_op_rank_conformable): Add prototype. + * resolve.cc (resolve_operator): Check conformability of ranks of + operands for intrinsic binary operators before performing type + conversions. + (gfc_op_rank_conformable): New helper function to compare ranks of + operands of binary operator. + +2023-05-04 Julian Brown <julian@codesourcery.com> + + PR fortran/109622 + * openmp.cc (resolve_omp_clauses): Add diagnostic for + non-pointer/non-allocatable attach/detach. + * trans-openmp.cc (gfc_trans_omp_clauses): Remove dereference for + pointer-to-scalar derived type component attach/detach. Fix + attach/detach handling for descriptors. + +2023-04-28 Julian Brown <julian@codesourcery.com> + + PR fortran/109622 + * trans-openmp.cc (gfc_trans_omp_clauses): Attach/detach clause fixes. + +2023-04-28 Tobias Burnus <tobias@codesourcery.com> + + * gfortran.texi: Fix typos. + * decl.cc: Fix typos in comments and in a variable name. + * arith.cc: Fix comment typos. + * check.cc: Likewise. + * class.cc: Likewise. + * dependency.cc: Likewise. + * expr.cc: Likewise. + * frontend-passes.cc: Likewise. + * gfortran.h: Likewise. + * intrinsic.cc: Likewise. + * iresolve.cc: Likewise. + * match.cc: Likewise. + * module.cc: Likewise. + * primary.cc: Likewise. + * resolve.cc: Likewise. + * simplify.cc: Likewise. + * trans-array.cc: Likewise. + * trans-decl.cc: Likewise. + * trans-expr.cc: Likewise. + * trans-intrinsic.cc: Likewise. + * trans-openmp.cc: Likewise. + * trans-stmt.cc: Likewise. + +2023-04-25 Tobias Burnus <tobias@codesourcery.com> + + * openmp.cc (gfc_resolve_omp_do_blocks): Handle zero + or more than one exec statements before/after 'omp scan'. + * trans-openmp.cc (gfc_trans_omp_do): Likewise. + +2023-04-22 Harald Anlauf <anlauf@gmx.de> + Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/109500 + * interface.cc (gfc_compare_actual_formal): Reject allocatable + functions being used as actual argument for allocable dummy. + +2023-04-14 Harald Anlauf <anlauf@gmx.de> + + PR fortran/109511 + * simplify.cc (gfc_simplify_set_exponent): Fix implementation of + compile-time simplification of intrinsic SET_EXPONENT for argument + X < 1 and for I < 0. + +2023-04-14 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/104272 + * gfortran.h : Add expr3_not_explicit bit field to gfc_code. + * resolve.cc (resolve_allocate_expr): Set bit field when the + default initializer is applied to expr3. + * trans-stmt.cc (gfc_trans_allocate): If expr3_not_explicit is + set, do not deallocate expr3. + +2023-04-13 Harald Anlauf <anlauf@gmx.de> + + PR fortran/109492 + * trans-expr.cc (gfc_conv_power_op): Use absu_hwi and + unsigned HOST_WIDE_INT for portability. + +2023-04-12 Harald Anlauf <anlauf@gmx.de> + + PR fortran/104312 + * resolve.cc (resolve_entries): Handle functions with ENTRY and + ALLOCATABLE results. + * trans-expr.cc (gfc_conv_procedure_call): Functions with a result + with the POINTER or ALLOCATABLE attribute shall not get any special + treatment with -ff2c, as they cannot be written in Fortran 77. + * trans-types.cc (gfc_return_by_reference): Likewise. + (gfc_get_function_type): Likewise. + +2023-04-12 Harald Anlauf <anlauf@gmx.de> + + PR fortran/61615 + PR fortran/99982 + * interface.cc (compare_parameter): Enable type and rank checks for + arguments of derived type from the intrinsic module ISO_C_BINDING. + +2023-04-08 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/87477 + * iresolve.cc (gfc_resolve_adjustl, gfc_resolve_adjustr): if + string length is deferred use the string typespec for result. + * resolve.cc (resolve_assoc_var): Handle parentheses around the + target expression. + (resolve_block_construct): Remove unnecessary static decls. + * trans-array.cc (gfc_conv_expr_descriptor): Guard string len + expression in condition. Improve handling of string length and + span, especially for substrings of the descriptor. + (duplicate_allocatable): Make element type more explicit with + 'eltype'. + * trans-decl.cc (gfc_get_symbol_decl): Emit a fatal error with + appropriate message instead of ICE if symbol type is unknown. + (gfc_generate_function_code): Set current locus to proc_sym + declared_at. + * trans-expr.cc (gfc_get_expr_charlen): Retain last charlen in + 'previous' and use if end expression in substring reference is + null. + (gfc_conv_string_length): Use gfc_conv_expr_descriptor if + 'expr_flat' is an array. Add post block to catch deallocation + of temporaries. + (gfc_conv_procedure_call): Assign the parmse string length to + the expression string length, if it is deferred. + (gfc_trans_alloc_subarray_assign): If this is a deferred string + length component, store the string length in the hidden comp. + Update the typespec length accordingly. Generate a new type + spec for the call to gfc_duplicate-allocatable in this case. + * trans-io.cc (gfc_trans_transfer): Scalarize transfer of + deferred character array components. + +2023-04-04 Harald Anlauf <anlauf@gmx.de> + + PR fortran/104349 + * expr.cc (check_restricted): Adjust check for valid variables in + restricted expressions: make no exception for module variables. + +2023-04-01 Thomas Koenig <tkoenig@gcc.gnu.org> + + * dump-parse-tree.cc (get_c_type_name): Fix "long_long" + type name to be "long long". + +2023-03-30 Andrew Pinski <apinski@marvell.com> + + * dump-parse-tree.cc (get_c_type_name): Fix "long_long" + type name to be "long long". Add a comment on why adding + 2 to the name too. + 2023-03-28 Jakub Jelinek <jakub@redhat.com> PR fortran/109314 diff --git a/gcc/fortran/Make-lang.in b/gcc/fortran/Make-lang.in index 1666fd8..6f9f231 100644 --- a/gcc/fortran/Make-lang.in +++ b/gcc/fortran/Make-lang.in @@ -278,7 +278,7 @@ $(DESTDIR)$(man1dir)/$(GFORTRAN_INSTALL_NAME)$(man1ext): doc/gfortran.1 \ -chmod a-x $@ fortran.uninstall: - if $(SHELL) -c 'install-info --version | sed 1q | fgrep -s -v -i debian' >/dev/null 2>&1; then \ + if $(SHELL) -c 'install-info --version | sed 1q | grep -s -v -i debian' >/dev/null 2>&1; then \ echo " install-info --delete --info-dir=$(DESTDIR)$(infodir) $(DESTDIR)$(infodir)/gfortran.info"; \ install-info --delete --info-dir=$(DESTDIR)$(infodir) $(DESTDIR)$(infodir)/gfortran.info || : ; \ else : ; fi; \ diff --git a/gcc/fortran/arith.cc b/gcc/fortran/arith.cc index ddf9874..86d56406 100644 --- a/gcc/fortran/arith.cc +++ b/gcc/fortran/arith.cc @@ -1034,7 +1034,7 @@ gfc_arith_concat (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp) size_t len; /* By cleverly playing around with constructors, it is possible - to get mismaching types here. */ + to get mismatching types here. */ if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER || op1->ts.kind != op2->ts.kind) return ARITH_WRONGCONCAT; @@ -1663,6 +1663,12 @@ eval_intrinsic (gfc_intrinsic_op op, if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts)) goto runtime; + /* Do not perform conversions if operands are not conformable as + required for the binary intrinsic operators (F2018:10.1.5). + Defer to a possibly overloading user-defined operator. */ + if (!gfc_op_rank_conformable (op1, op2)) + goto runtime; + /* Insert any necessary type conversions to make the operands compatible. */ diff --git a/gcc/fortran/array.cc b/gcc/fortran/array.cc index be5eb8b..4b7c1e7 100644 --- a/gcc/fortran/array.cc +++ b/gcc/fortran/array.cc @@ -994,7 +994,7 @@ compare_bounds (gfc_expr *bound1, gfc_expr *bound2) /* Compares two array specifications. They must be constant or deferred shape. */ -int +bool gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2) { int i; @@ -1039,7 +1039,7 @@ gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2) use the symbol as an implied-DO iterator. Returns nonzero if a duplicate was found. */ -static int +static bool check_duplicate_iterator (gfc_constructor_base base, gfc_symbol *master) { gfc_constructor *c; @@ -1982,7 +1982,7 @@ is_constant_element (gfc_expr *e) i=1,100000000) /) will take a while as* opposed to a more clever function that traverses the expression tree. FIXME. */ -int +bool gfc_constant_ac (gfc_expr *e) { expand_info expand_save; @@ -2005,7 +2005,7 @@ gfc_constant_ac (gfc_expr *e) /* Returns nonzero if an array constructor has been completely expanded (no iterators) and zero if iterators are present. */ -int +bool gfc_expanded_ac (gfc_expr *e) { gfc_constructor *c; diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc index 8c1ae8c..4086dc7 100644 --- a/gcc/fortran/check.cc +++ b/gcc/fortran/check.cc @@ -93,7 +93,7 @@ illegal_boz_arg (gfc_expr *x) return false; } -/* Some precedures take two arguments such that both cannot be BOZ. */ +/* Some procedures take two arguments such that both cannot be BOZ. */ static bool boz_args_check(gfc_expr *i, gfc_expr *j) @@ -1156,23 +1156,23 @@ dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed) dimension bi, returning 0 if they are known not to be identical, and 1 if they are identical, or if this cannot be determined. */ -static int +static bool identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi) { mpz_t a_size, b_size; - int ret; + bool ret; gcc_assert (a->rank > ai); gcc_assert (b->rank > bi); - ret = 1; + ret = true; if (gfc_array_dimen_size (a, ai, &a_size)) { if (gfc_array_dimen_size (b, bi, &b_size)) { if (mpz_cmp (a_size, b_size) != 0) - ret = 0; + ret = false; mpz_clear (b_size); } @@ -4723,7 +4723,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, } gfc_simplify_expr (shape, 0); - shape_is_const = gfc_is_constant_expr (shape); + shape_is_const = gfc_is_constant_array_expr (shape); if (shape->expr_type == EXPR_ARRAY && shape_is_const) { @@ -4732,6 +4732,8 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, for (i = 0; i < shape_size; ++i) { e = gfc_constructor_lookup_expr (shape->value.constructor, i); + if (e == NULL) + break; if (e->expr_type != EXPR_CONSTANT) continue; @@ -4764,7 +4766,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, if (!type_check (order, 3, BT_INTEGER)) return false; - if (order->expr_type == EXPR_ARRAY && gfc_is_constant_expr (order)) + if (order->expr_type == EXPR_ARRAY && gfc_is_constant_array_expr (order)) { int i, order_size, dim, perm[GFC_MAX_DIMENSIONS]; gfc_expr *e; diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc index bffc0ff..9d0c802 100644 --- a/gcc/fortran/class.cc +++ b/gcc/fortran/class.cc @@ -1631,7 +1631,7 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini, /* Generate the finalization/polymorphic freeing wrapper subroutine for the - derived type "derived". The function first calls the approriate FINAL + derived type "derived". The function first calls the appropriate FINAL subroutine, then it DEALLOCATEs (finalizes/frees) the allocatable components (but not the inherited ones). Last, it calls the wrapper subroutine of the parent. The generated wrapper procedure takes as argument diff --git a/gcc/fortran/cpp.cc b/gcc/fortran/cpp.cc index c3b7c7f..67e4d4e 100644 --- a/gcc/fortran/cpp.cc +++ b/gcc/fortran/cpp.cc @@ -297,16 +297,16 @@ gfc_cpp_init_options (unsigned int decoded_options_count, gfc_cpp_option.deferred_opt_count = 0; } -int +bool gfc_cpp_handle_option (size_t scode, const char *arg, int value ATTRIBUTE_UNUSED) { - int result = 1; + bool result = true; enum opt_code code = (enum opt_code) scode; switch (code) { default: - result = 0; + result = false; break; case OPT_cpp_: @@ -749,7 +749,6 @@ gfc_cpp_add_include_path_after (char *path, bool user_supplied) static void scan_translation_unit_trad (cpp_reader *); static void account_for_newlines (const unsigned char *, size_t); -static int dump_macro (cpp_reader *, cpp_hashnode *, void *); static void print_line (location_t, const char *); static void maybe_print_line (location_t); diff --git a/gcc/fortran/cpp.h b/gcc/fortran/cpp.h index 886996f..d2fbfcf 100644 --- a/gcc/fortran/cpp.h +++ b/gcc/fortran/cpp.h @@ -39,7 +39,7 @@ void gfc_cpp_init (void); void gfc_cpp_init_options (unsigned int decoded_options_count, struct cl_decoded_option *decoded_options); -int gfc_cpp_handle_option(size_t scode, const char *arg, int value); +bool gfc_cpp_handle_option(size_t scode, const char *arg, int value); void gfc_cpp_post_options (bool); diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc index 233bf24..844345d 100644 --- a/gcc/fortran/decl.cc +++ b/gcc/fortran/decl.cc @@ -1056,6 +1056,7 @@ static match char_len_param_value (gfc_expr **expr, bool *deferred) { match m; + gfc_expr *p; *expr = NULL; *deferred = false; @@ -1081,10 +1082,12 @@ char_len_param_value (gfc_expr **expr, bool *deferred) if (!gfc_expr_check_typed (*expr, gfc_current_ns, false)) return MATCH_ERROR; - /* If gfortran gets an EXPR_OP, try to simplifiy it. This catches things - like CHARACTER(([1])). */ - if ((*expr)->expr_type == EXPR_OP) - gfc_simplify_expr (*expr, 1); + /* Try to simplify the expression to catch things like CHARACTER(([1])). */ + p = gfc_copy_expr (*expr); + if (gfc_is_constant_expr (p) && gfc_simplify_expr (p, 1)) + gfc_replace_expr (*expr, p); + else + gfc_free_expr (p); if ((*expr)->expr_type == EXPR_FUNCTION) { @@ -1576,7 +1579,7 @@ gfc_verify_c_interop_param (gfc_symbol *sym) } /* Character strings are only C interoperable if they have a - length of 1. However, as an argument they are also iteroperable + length of 1. However, as an argument they are also interoperable when passed as descriptor (which requires len=: or len=*). */ if (sym->ts.type == BT_CHARACTER) { @@ -2239,8 +2242,7 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) && gfc_is_constant_expr (init) && (init->expr_type == EXPR_CONSTANT || init->expr_type == EXPR_STRUCTURE) - && spec_size (sym->as, &size) - && mpz_cmp_si (size, 0) > 0) + && spec_size (sym->as, &size)) { array = gfc_get_array_expr (init->ts.type, init->ts.kind, &init->where); @@ -2698,7 +2700,7 @@ variable_decl (int elem) } gfc_seen_div0 = false; - + /* F2018:C830 (R816) An explicit-shape-spec whose bounds are not constant expressions shall appear only in a subprogram, derived type definition, BLOCK construct, or interface body. */ @@ -2769,7 +2771,7 @@ variable_decl (int elem) if (e->expr_type != EXPR_CONSTANT) { n = gfc_copy_expr (e); - if (!gfc_simplify_expr (n, 1) && gfc_seen_div0) + if (!gfc_simplify_expr (n, 1) && gfc_seen_div0) { m = MATCH_ERROR; goto cleanup; @@ -2784,12 +2786,12 @@ variable_decl (int elem) if (e->expr_type != EXPR_CONSTANT) { n = gfc_copy_expr (e); - if (!gfc_simplify_expr (n, 1) && gfc_seen_div0) + if (!gfc_simplify_expr (n, 1) && gfc_seen_div0) { m = MATCH_ERROR; goto cleanup; } - + if (n->expr_type == EXPR_CONSTANT) gfc_replace_expr (e, n); else @@ -2847,7 +2849,7 @@ variable_decl (int elem) } } - /* The dummy arguments and result of the abreviated form of MODULE + /* The dummy arguments and result of the abbreviated form of MODULE PROCEDUREs, used in SUBMODULES should not be redefined. */ if (gfc_current_ns->proc_name && gfc_current_ns->proc_name->abr_modproc_decl) @@ -3117,7 +3119,7 @@ variable_decl (int elem) } } - /* Before adding a possible initilizer, do a simple check for compatibility + /* Before adding a possible initializer, do a simple check for compatibility of lhs and rhs types. Assigning a REAL value to a derived type is not a good thing. */ if (current_ts.type == BT_DERIVED && initializer @@ -3367,6 +3369,7 @@ close_brackets: else gfc_error ("Missing right parenthesis at %C"); m = MATCH_ERROR; + goto no_match; } else /* All tests passed. */ @@ -4704,6 +4707,9 @@ get_kind: } m = gfc_match_kind_spec (ts, false); + if (m == MATCH_ERROR) + return MATCH_ERROR; + if (m == MATCH_NO && ts->type != BT_CHARACTER) { m = gfc_match_old_kind_spec (ts); @@ -8348,7 +8354,7 @@ gfc_match_end (gfc_statement *st) match m; gfc_namespace *parent_ns, *ns, *prev_ns; gfc_namespace **nsp; - bool abreviated_modproc_decl = false; + bool abbreviated_modproc_decl = false; bool got_matching_end = false; old_loc = gfc_current_locus; @@ -8372,7 +8378,7 @@ gfc_match_end (gfc_statement *st) state = gfc_state_stack->previous->state; block_name = gfc_state_stack->previous->sym == NULL ? NULL : gfc_state_stack->previous->sym->name; - abreviated_modproc_decl = gfc_state_stack->previous->sym + abbreviated_modproc_decl = gfc_state_stack->previous->sym && gfc_state_stack->previous->sym->abr_modproc_decl; break; @@ -8380,8 +8386,8 @@ gfc_match_end (gfc_statement *st) break; } - if (!abreviated_modproc_decl) - abreviated_modproc_decl = gfc_current_block () + if (!abbreviated_modproc_decl) + abbreviated_modproc_decl = gfc_current_block () && gfc_current_block ()->abr_modproc_decl; switch (state) @@ -8395,7 +8401,7 @@ gfc_match_end (gfc_statement *st) case COMP_SUBROUTINE: *st = ST_END_SUBROUTINE; - if (!abreviated_modproc_decl) + if (!abbreviated_modproc_decl) target = " subroutine"; else target = " procedure"; @@ -8404,7 +8410,7 @@ gfc_match_end (gfc_statement *st) case COMP_FUNCTION: *st = ST_END_FUNCTION; - if (!abreviated_modproc_decl) + if (!abbreviated_modproc_decl) target = " function"; else target = " procedure"; @@ -8533,7 +8539,7 @@ gfc_match_end (gfc_statement *st) { if (!gfc_notify_std (GFC_STD_F2008, "END statement " "instead of %s statement at %L", - abreviated_modproc_decl ? "END PROCEDURE" + abbreviated_modproc_decl ? "END PROCEDURE" : gfc_ascii_statement(*st), &old_loc)) goto cleanup; } @@ -8551,7 +8557,7 @@ gfc_match_end (gfc_statement *st) /* Verify that we've got the sort of end-block that we're expecting. */ if (gfc_match (target) != MATCH_YES) { - gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl + gfc_error ("Expecting %s statement at %L", abbreviated_modproc_decl ? "END PROCEDURE" : gfc_ascii_statement(*st), &old_loc); goto cleanup; } @@ -11637,8 +11643,9 @@ gfc_match_final_decl (void) block = gfc_state_stack->previous->sym; gcc_assert (block); - if (!gfc_state_stack->previous || !gfc_state_stack->previous->previous - || gfc_state_stack->previous->previous->state != COMP_MODULE) + if (gfc_state_stack->previous->previous + && gfc_state_stack->previous->previous->state != COMP_MODULE + && gfc_state_stack->previous->previous->state != COMP_SUBMODULE) { gfc_error ("Derived type declaration with FINAL at %C must be in the" " specification part of a MODULE"); diff --git a/gcc/fortran/dependency.cc b/gcc/fortran/dependency.cc index 9117825..632b398 100644 --- a/gcc/fortran/dependency.cc +++ b/gcc/fortran/dependency.cc @@ -543,7 +543,7 @@ gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mpz_t *result) e1 = gfc_discard_nops (e1); e2 = gfc_discard_nops (e2); - /* Inizialize tentatively, clear if we don't return anything. */ + /* Initialize tentatively, clear if we don't return anything. */ mpz_init (*result); /* Case 1: c1 - c2 = c1 - c2, trivially. */ @@ -921,7 +921,7 @@ gfc_ref_needs_temporary_p (gfc_ref *ref) } -static int +static bool gfc_is_data_pointer (gfc_expr *e) { gfc_ref *ref; @@ -1091,7 +1091,7 @@ gfc_check_argument_dependency (gfc_expr *other, sym_intent intent, /* Like gfc_check_argument_dependency, but check all the arguments in ACTUAL. FNSYM is the function being called, or NULL if not known. */ -int +bool gfc_check_fncall_dependency (gfc_expr *other, sym_intent intent, gfc_symbol *fnsym, gfc_actual_arglist *actual, gfc_dep_check elemental) @@ -1137,7 +1137,7 @@ gfc_check_fncall_dependency (gfc_expr *other, sym_intent intent, e1->ref and e2->ref to determine whether the actually accessed portions of these variables/arrays potentially overlap. */ -int +bool gfc_are_equivalenced_arrays (gfc_expr *e1, gfc_expr *e2) { gfc_equiv_list *l; @@ -2092,13 +2092,11 @@ ref_same_as_full_array (gfc_ref *full_ref, gfc_ref *ref) /* Finds if two array references are overlapping or not. Return value - 2 : array references are overlapping but reversal of one or - more dimensions will clear the dependency. 1 : array references are overlapping, or identical is true and there is some kind of overlap. 0 : array references are identical or not overlapping. */ -int +bool gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref, gfc_reverse *reverse, bool identical) { diff --git a/gcc/fortran/dependency.h b/gcc/fortran/dependency.h index b115031..fbbede8 100644 --- a/gcc/fortran/dependency.h +++ b/gcc/fortran/dependency.h @@ -32,13 +32,13 @@ enum gfc_dep_check bool gfc_ref_needs_temporary_p (gfc_ref *); bool gfc_full_array_ref_p (gfc_ref *, bool *); gfc_expr *gfc_get_noncopying_intrinsic_argument (gfc_expr *); -int gfc_check_fncall_dependency (gfc_expr *, sym_intent, gfc_symbol *, +bool gfc_check_fncall_dependency (gfc_expr *, sym_intent, gfc_symbol *, gfc_actual_arglist *, gfc_dep_check); int gfc_check_dependency (gfc_expr *, gfc_expr *, bool); int gfc_expr_is_one (gfc_expr *, int); -int gfc_dep_resolver (gfc_ref *, gfc_ref *, gfc_reverse *, +bool gfc_dep_resolver (gfc_ref *, gfc_ref *, gfc_reverse *, bool identical = false); -int gfc_are_equivalenced_arrays (gfc_expr *, gfc_expr *); +bool gfc_are_equivalenced_arrays (gfc_expr *, gfc_expr *); gfc_expr * gfc_discard_nops (gfc_expr *); diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc index 3b24bdc..effcebe 100644 --- a/gcc/fortran/dump-parse-tree.cc +++ b/gcc/fortran/dump-parse-tree.cc @@ -55,10 +55,8 @@ static void show_typespec (gfc_typespec *); static void show_ref (gfc_ref *); static void show_attr (symbol_attribute *, const char *); -/* Allow dumping of an expression in the debugger. */ -void gfc_debug_expr (gfc_expr *); - -void debug (symbol_attribute *attr) +DEBUG_FUNCTION void +debug (symbol_attribute *attr) { FILE *tmp = dumpfile; dumpfile = stderr; @@ -67,7 +65,8 @@ void debug (symbol_attribute *attr) dumpfile = tmp; } -void debug (gfc_formal_arglist *formal) +DEBUG_FUNCTION void +debug (gfc_formal_arglist *formal) { FILE *tmp = dumpfile; dumpfile = stderr; @@ -80,12 +79,14 @@ void debug (gfc_formal_arglist *formal) dumpfile = tmp; } -void debug (symbol_attribute attr) +DEBUG_FUNCTION void +debug (symbol_attribute attr) { debug (&attr); } -void debug (gfc_expr *e) +DEBUG_FUNCTION void +debug (gfc_expr *e) { FILE *tmp = dumpfile; dumpfile = stderr; @@ -102,7 +103,8 @@ void debug (gfc_expr *e) dumpfile = tmp; } -void debug (gfc_typespec *ts) +DEBUG_FUNCTION void +debug (gfc_typespec *ts) { FILE *tmp = dumpfile; dumpfile = stderr; @@ -111,12 +113,14 @@ void debug (gfc_typespec *ts) dumpfile = tmp; } -void debug (gfc_typespec ts) +DEBUG_FUNCTION void +debug (gfc_typespec ts) { debug (&ts); } -void debug (gfc_ref *p) +DEBUG_FUNCTION void +debug (gfc_ref *p) { FILE *tmp = dumpfile; dumpfile = stderr; @@ -125,7 +129,17 @@ void debug (gfc_ref *p) dumpfile = tmp; } -void +DEBUG_FUNCTION void +debug (gfc_namespace *ns) +{ + FILE *tmp = dumpfile; + dumpfile = stderr; + show_namespace (ns); + fputc ('\n', dumpfile); + dumpfile = tmp; +} + +DEBUG_FUNCTION void gfc_debug_expr (gfc_expr *e) { FILE *tmp = dumpfile; @@ -136,9 +150,8 @@ gfc_debug_expr (gfc_expr *e) } /* Allow for dumping of a piece of code in the debugger. */ -void gfc_debug_code (gfc_code *c); -void +DEBUG_FUNCTION void gfc_debug_code (gfc_code *c) { FILE *tmp = dumpfile; @@ -148,7 +161,8 @@ gfc_debug_code (gfc_code *c) dumpfile = tmp; } -void debug (gfc_symbol *sym) +DEBUG_FUNCTION void +debug (gfc_symbol *sym) { FILE *tmp = dumpfile; dumpfile = stderr; @@ -758,12 +772,13 @@ show_expr (gfc_expr *p) static void show_attr (symbol_attribute *attr, const char * module) { + fputc ('(', dumpfile); if (attr->flavor != FL_UNKNOWN) { if (attr->flavor == FL_DERIVED && attr->pdt_template) - fputs (" (PDT-TEMPLATE", dumpfile); + fputs ("PDT-TEMPLATE ", dumpfile); else - fprintf (dumpfile, "(%s ", gfc_code2string (flavors, attr->flavor)); + fprintf (dumpfile, "%s ", gfc_code2string (flavors, attr->flavor)); } if (attr->access != ACCESS_UNKNOWN) fprintf (dumpfile, "%s ", gfc_code2string (access_types, attr->access)); @@ -1359,23 +1374,26 @@ show_omp_namelist (int list_type, gfc_omp_namelist *n) } if (list_type == OMP_LIST_ALLOCATE) { - if (n->expr) + if (n->u2.allocator) { fputs ("allocator(", dumpfile); - show_expr (n->expr); + show_expr (n->u2.allocator); fputc (')', dumpfile); } if (n->expr && n->u.align) fputc (',', dumpfile); if (n->u.align) { - fputs ("allocator(", dumpfile); + fputs ("align(", dumpfile); show_expr (n->u.align); fputc (')', dumpfile); } - if (n->expr || n->u.align) + if (n->u2.allocator || n->u.align) fputc (':', dumpfile); - fputs (n->sym->name, dumpfile); + if (n->expr) + show_expr (n->expr); + else + fputs (n->sym->name, dumpfile); if (n->next) fputs (") ALLOCATE(", dumpfile); continue; @@ -1453,9 +1471,20 @@ show_omp_namelist (int list_type, gfc_omp_namelist *n) case OMP_MAP_TO: fputs ("to:", dumpfile); break; case OMP_MAP_FROM: fputs ("from:", dumpfile); break; case OMP_MAP_TOFROM: fputs ("tofrom:", dumpfile); break; + case OMP_MAP_PRESENT_ALLOC: fputs ("present,alloc:", dumpfile); break; + case OMP_MAP_PRESENT_TO: fputs ("present,to:", dumpfile); break; + case OMP_MAP_PRESENT_FROM: fputs ("present,from:", dumpfile); break; + case OMP_MAP_PRESENT_TOFROM: + fputs ("present,tofrom:", dumpfile); break; case OMP_MAP_ALWAYS_TO: fputs ("always,to:", dumpfile); break; case OMP_MAP_ALWAYS_FROM: fputs ("always,from:", dumpfile); break; case OMP_MAP_ALWAYS_TOFROM: fputs ("always,tofrom:", dumpfile); break; + case OMP_MAP_ALWAYS_PRESENT_TO: + fputs ("always,present,to:", dumpfile); break; + case OMP_MAP_ALWAYS_PRESENT_FROM: + fputs ("always,present,from:", dumpfile); break; + case OMP_MAP_ALWAYS_PRESENT_TOFROM: + fputs ("always,present,tofrom:", dumpfile); break; case OMP_MAP_DELETE: fputs ("delete:", dumpfile); break; case OMP_MAP_RELEASE: fputs ("release:", dumpfile); break; default: break; @@ -1778,6 +1807,9 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses) fputs ("inscan, ", dumpfile); if (list_type == OMP_LIST_REDUCTION_TASK) fputs ("task, ", dumpfile); + if ((list_type == OMP_LIST_TO || list_type == OMP_LIST_FROM) + && omp_clauses->lists[list_type]->u.present_modifier) + fputs ("present:", dumpfile); show_omp_namelist (list_type, omp_clauses->lists[list_type]); fputc (')', dumpfile); } @@ -2081,6 +2113,8 @@ show_omp_node (int level, gfc_code *c) case EXEC_OACC_CACHE: name = "CACHE"; is_oacc = true; break; case EXEC_OACC_ENTER_DATA: name = "ENTER DATA"; is_oacc = true; break; case EXEC_OACC_EXIT_DATA: name = "EXIT DATA"; is_oacc = true; break; + case EXEC_OMP_ALLOCATE: name = "ALLOCATE"; break; + case EXEC_OMP_ALLOCATORS: name = "ALLOCATORS"; break; case EXEC_OMP_ASSUME: name = "ASSUME"; break; case EXEC_OMP_ATOMIC: name = "ATOMIC"; break; case EXEC_OMP_BARRIER: name = "BARRIER"; break; @@ -2503,7 +2537,7 @@ show_code_node (int level, gfc_code *c) case EXEC_SYNC_MEMORY: fputs ("SYNC MEMORY ", dumpfile); if (c->expr2 != NULL) - { + { fputs (" stat=", dumpfile); show_expr (c->expr2); } @@ -3409,6 +3443,8 @@ show_code_node (int level, gfc_code *c) case EXEC_OACC_CACHE: case EXEC_OACC_ENTER_DATA: case EXEC_OACC_EXIT_DATA: + case EXEC_OMP_ALLOCATE: + case EXEC_OMP_ALLOCATORS: case EXEC_OMP_ASSUME: case EXEC_OMP_ATOMIC: case EXEC_OMP_CANCEL: @@ -3696,7 +3732,12 @@ get_c_type_name (gfc_typespec *ts, gfc_array_spec *as, const char **pre, if (c_interop_kinds_table[i].f90_type == ts->type && c_interop_kinds_table[i].value == ts->kind) { + /* Skip over 'c_'. */ *type_name = c_interop_kinds_table[i].name + 2; + if (strcmp (*type_name, "long_long") == 0) + *type_name = "long long"; + if (strcmp (*type_name, "long_double") == 0) + *type_name = "long double"; if (strcmp (*type_name, "signed_char") == 0) *type_name = "signed char"; else if (strcmp (*type_name, "size_t") == 0) @@ -4016,7 +4057,8 @@ gfc_dump_global_symbols (FILE *f) /* Show an array ref. */ -void debug (gfc_array_ref *ar) +DEBUG_FUNCTION void +debug (gfc_array_ref *ar) { FILE *tmp = dumpfile; dumpfile = stderr; diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc index 7fb33f8..c960dfe 100644 --- a/gcc/fortran/expr.cc +++ b/gcc/fortran/expr.cc @@ -798,7 +798,7 @@ gfc_copy_ref (gfc_ref *src) /* Detect whether an expression has any vector index array references. */ -int +bool gfc_has_vector_index (gfc_expr *e) { gfc_ref *ref; @@ -812,6 +812,16 @@ gfc_has_vector_index (gfc_expr *e) } +bool +gfc_is_ptr_fcn (gfc_expr *e) +{ + return e != NULL && e->expr_type == EXPR_FUNCTION + && (gfc_expr_attr (e).pointer + || (e->ts.type == BT_CLASS + && CLASS_DATA (e)->attr.class_pointer)); +} + + /* Copy a shape array. */ mpz_t * @@ -888,7 +898,7 @@ gfc_kind_max (gfc_expr *e1, gfc_expr *e2) /* Returns nonzero if the type is numeric, zero otherwise. */ -static int +static bool numeric_type (bt type) { return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER; @@ -897,7 +907,7 @@ numeric_type (bt type) /* Returns nonzero if the typespec is a numeric type, zero otherwise. */ -int +bool gfc_numeric_ts (gfc_typespec *ts) { return numeric_type (ts->type); @@ -1539,6 +1549,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) mpz_init_set_ui (delta_mpz, one); mpz_init_set_ui (nelts, one); mpz_init (tmp_mpz); + mpz_init (ptr); /* Do the initialization now, so that we can cleanup without keeping track of where we were. */ @@ -1682,7 +1693,6 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) mpz_mul (delta_mpz, delta_mpz, tmp_mpz); } - mpz_init (ptr); cons = gfc_constructor_first (base); /* Now clock through the array reference, calculating the index in @@ -1735,7 +1745,8 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) "at %L requires an increase of the allowed %d " "upper limit. See %<-fmax-array-constructor%> " "option", &expr->where, flag_max_array_constructor); - return false; + t = false; + goto cleanup; } cons = gfc_constructor_lookup (base, limit); @@ -1750,8 +1761,6 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) gfc_copy_expr (cons->expr), NULL); } - mpz_clear (ptr); - cleanup: mpz_clear (delta_mpz); @@ -1765,6 +1774,7 @@ cleanup: mpz_clear (ctr[d]); mpz_clear (stride[d]); } + mpz_clear (ptr); gfc_constructor_free (base); return t; } @@ -3504,8 +3514,6 @@ check_restricted (gfc_expr *e) || sym->attr.implied_index || sym->attr.flavor == FL_PARAMETER || is_parent_of_current_ns (sym->ns) - || (sym->ns->proc_name != NULL - && sym->ns->proc_name->attr.flavor == FL_MODULE) || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns))) { t = true; @@ -3658,7 +3666,7 @@ gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, . /* Given an assignable expression and an arbitrary expression, make sure that the assignment can take place. Only add a call to the intrinsic conversion routines, when allow_convert is set. When this assign is a - coarray call, then the convert is done by the coarray routine implictly and + coarray call, then the convert is done by the coarray routine implicitly and adding the intrinsic conversion would do harm in most cases. */ bool @@ -5849,9 +5857,9 @@ gfc_get_corank (gfc_expr *e) if (!gfc_is_coarray (e)) return 0; - if (e->ts.type == BT_CLASS && e->ts.u.derived->components) - corank = e->ts.u.derived->components->as - ? e->ts.u.derived->components->as->corank : 0; + if (e->ts.type == BT_CLASS && CLASS_DATA (e)) + corank = CLASS_DATA (e)->as + ? CLASS_DATA (e)->as->corank : 0; else corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0; @@ -6258,7 +6266,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, && !(sym->attr.flavor == FL_PROCEDURE && sym == sym->result) && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer) && !(sym->attr.flavor == FL_PROCEDURE - && sym->attr.function && sym->attr.pointer)) + && sym->attr.function && attr.pointer)) { if (context) gfc_error ("%qs in variable definition context (%s) at %L is not" @@ -6472,6 +6480,22 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, } return false; } + else if (context && gfc_is_ptr_fcn (assoc->target)) + { + if (!gfc_notify_std (GFC_STD_F2018, "%qs at %L associated to " + "pointer function target being used in a " + "variable definition context (%s)", name, + &e->where, context)) + return false; + else if (gfc_has_vector_index (e)) + { + gfc_error ("%qs at %L associated to vector-indexed target" + " cannot be used in a variable definition" + " context (%s)", + name, &e->where, context); + return false; + } + } /* Target must be allowed to appear in a variable definition context. */ if (!gfc_check_vardef_context (assoc->target, pointer, false, false, NULL)) diff --git a/gcc/fortran/f95-lang.cc b/gcc/fortran/f95-lang.cc index 9684f1d..89944f4 100644 --- a/gcc/fortran/f95-lang.cc +++ b/gcc/fortran/f95-lang.cc @@ -836,6 +836,20 @@ gfc_init_builtin_functions (void) gfc_define_builtin ("__builtin_scalbnf", mfunc_float[2], BUILT_IN_SCALBNF, "scalbnf", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_fmaxl", mfunc_longdouble[1], + BUILT_IN_FMAXL, "fmaxl", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_fmax", mfunc_double[1], + BUILT_IN_FMAX, "fmax", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_fmaxf", mfunc_float[1], + BUILT_IN_FMAXF, "fmaxf", ATTR_CONST_NOTHROW_LEAF_LIST); + + gfc_define_builtin ("__builtin_fminl", mfunc_longdouble[1], + BUILT_IN_FMINL, "fminl", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_fmin", mfunc_double[1], + BUILT_IN_FMIN, "fmin", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_fminf", mfunc_float[1], + BUILT_IN_FMINF, "fminf", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__builtin_fmodl", mfunc_longdouble[1], BUILT_IN_FMODL, "fmodl", ATTR_CONST_NOTHROW_LEAF_LIST); gfc_define_builtin ("__builtin_fmod", mfunc_double[1], diff --git a/gcc/fortran/frontend-passes.cc b/gcc/fortran/frontend-passes.cc index 9042898..136a292 100644 --- a/gcc/fortran/frontend-passes.cc +++ b/gcc/fortran/frontend-passes.cc @@ -424,9 +424,9 @@ copy_walk_reduction_arg (gfc_constructor *c, gfc_expr *fn) return fcn; } -/* Callback function for optimzation of reductions to scalars. Transform ANY +/* Callback function for optimization of reductions to scalars. Transform ANY ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT - correspondingly. Handly only the simple cases without MASK and DIM. */ + correspondingly. Handle only the simple cases without MASK and DIM. */ static int callback_reduction (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, @@ -1455,7 +1455,7 @@ simplify_io_impl_do (gfc_code **code, int *walk_subtrees, } /* Optimize a namespace, including all contained namespaces. - flag_frontend_optimize and flag_fronend_loop_interchange are + flag_frontend_optimize and flag_frontend_loop_interchange are handled separately. */ static void diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 130d5d7..30631ab 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -318,6 +318,8 @@ enum gfc_statement ST_OMP_END_MASKED_TASKLOOP, ST_OMP_MASKED_TASKLOOP_SIMD, ST_OMP_END_MASKED_TASKLOOP_SIMD, ST_OMP_SCOPE, ST_OMP_END_SCOPE, ST_OMP_ERROR, ST_OMP_ASSUME, ST_OMP_END_ASSUME, ST_OMP_ASSUMES, + ST_OMP_ALLOCATE, ST_OMP_ALLOCATE_EXEC, + ST_OMP_ALLOCATORS, ST_OMP_END_ALLOCATORS, /* Note: gfc_match_omp_nothing returns ST_NONE. */ ST_OMP_NOTHING, ST_NONE }; @@ -1306,7 +1308,14 @@ enum gfc_omp_map_op OMP_MAP_RELEASE, OMP_MAP_ALWAYS_TO, OMP_MAP_ALWAYS_FROM, - OMP_MAP_ALWAYS_TOFROM + OMP_MAP_ALWAYS_TOFROM, + OMP_MAP_PRESENT_ALLOC, + OMP_MAP_PRESENT_TO, + OMP_MAP_PRESENT_FROM, + OMP_MAP_PRESENT_TOFROM, + OMP_MAP_ALWAYS_PRESENT_TO, + OMP_MAP_ALWAYS_PRESENT_FROM, + OMP_MAP_ALWAYS_PRESENT_TOFROM }; enum gfc_omp_defaultmap @@ -1360,11 +1369,13 @@ typedef struct gfc_omp_namelist } linear; struct gfc_common_head *common; bool lastprivate_conditional; + bool present_modifier; } u; union { struct gfc_omp_namelist_udr *udr; gfc_namespace *ns; + gfc_expr *allocator; } u2; struct gfc_omp_namelist *next; locus where; @@ -1916,7 +1927,7 @@ typedef struct gfc_symbol = 1 if it has been resolved in resolve_symbol. */ unsigned resolve_symbol_called:2; /* Set if this is a module function or subroutine with the - abreviated declaration in a submodule. */ + abbreviated declaration in a submodule. */ unsigned abr_modproc_decl:1; /* Set if a previous error or warning has occurred and no other should be reported. */ @@ -2177,8 +2188,9 @@ typedef struct gfc_namespace /* Linked list of !$omp declare variant constructs. */ struct gfc_omp_declare_variant *omp_declare_variant; - /* OpenMP assumptions. */ + /* OpenMP assumptions and allocate for static/stack vars. */ struct gfc_omp_assumptions *omp_assumes; + struct gfc_omp_namelist *omp_allocate; /* A hash set for the gfc expressions that have already been finalized in this namespace. */ @@ -2191,7 +2203,7 @@ typedef struct gfc_namespace /* Set to 1 if namespace is an interface body with "IMPORT" used. */ unsigned has_import_set:1; - /* Set to 1 if the namespace uses "IMPLICT NONE (export)". */ + /* Set to 1 if the namespace uses "IMPLICIT NONE (export)". */ unsigned has_implicit_none_export:1; /* Set to 1 if resolved has been called for this namespace. @@ -2910,9 +2922,6 @@ typedef struct gfc_association_list for memory handling. */ unsigned dangling:1; - /* True when the rank of the target expression is guessed during parsing. */ - unsigned rankguessed:1; - char name[GFC_MAX_SYMBOL_LEN + 1]; gfc_symtree *st; /* Symtree corresponding to name. */ locus where; @@ -2974,7 +2983,7 @@ enum gfc_exec_op EXEC_OMP_TARGET_TEAMS_LOOP, EXEC_OMP_MASKED, EXEC_OMP_PARALLEL_MASKED, 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_ERROR + EXEC_OMP_ERROR, EXEC_OMP_ALLOCATE, EXEC_OMP_ALLOCATORS }; typedef struct gfc_code @@ -3005,6 +3014,8 @@ typedef struct gfc_code /* Take the array specification from expr3 to allocate arrays without an explicit array specification. */ unsigned arr_spec_from_expr3:1; + /* expr3 is not explicit */ + unsigned expr3_not_explicit:1; } alloc; @@ -3218,16 +3229,16 @@ void gfc_release_include_path (void); void gfc_check_include_dirs (bool); FILE *gfc_open_included_file (const char *, bool, bool); -int gfc_at_end (void); -int gfc_at_eof (void); -int gfc_at_bol (void); -int gfc_at_eol (void); +bool gfc_at_end (void); +bool gfc_at_eof (void); +bool gfc_at_bol (void); +bool gfc_at_eol (void); void gfc_advance_line (void); -int gfc_define_undef_line (void); +bool gfc_define_undef_line (void); -int gfc_wide_is_printable (gfc_char_t); -int gfc_wide_is_digit (gfc_char_t); -int gfc_wide_fits_in_byte (gfc_char_t); +bool gfc_wide_is_printable (gfc_char_t); +bool gfc_wide_is_digit (gfc_char_t); +bool gfc_wide_fits_in_byte (gfc_char_t); gfc_char_t gfc_wide_tolower (gfc_char_t); gfc_char_t gfc_wide_toupper (gfc_char_t); size_t gfc_wide_strlen (const gfc_char_t *); @@ -3485,7 +3496,7 @@ void gfc_release_symbol (gfc_symbol *&); gfc_symbol *gfc_new_symbol (const char *, gfc_namespace *); gfc_symtree* gfc_find_symtree_in_proc (const char *, gfc_namespace *); int gfc_find_symbol (const char *, gfc_namespace *, int, gfc_symbol **); -int gfc_find_sym_tree (const char *, gfc_namespace *, int, gfc_symtree **); +bool gfc_find_sym_tree (const char *, gfc_namespace *, int, gfc_symtree **); int gfc_get_symbol (const char *, gfc_namespace *, gfc_symbol **); bool gfc_verify_c_interop (gfc_typespec *); bool gfc_verify_c_interop_param (gfc_symbol *); @@ -3565,10 +3576,10 @@ bool gfc_convert_type (gfc_expr *, gfc_typespec *, int); bool gfc_convert_type_warn (gfc_expr *, gfc_typespec *, int, int, bool array = false); bool gfc_convert_chartype (gfc_expr *, gfc_typespec *); -int gfc_generic_intrinsic (const char *); -int gfc_specific_intrinsic (const char *); +bool gfc_generic_intrinsic (const char *); +bool gfc_specific_intrinsic (const char *); bool gfc_is_intrinsic (gfc_symbol*, int, locus); -int gfc_intrinsic_actual_ok (const char *, const bool); +bool gfc_intrinsic_actual_ok (const char *, const bool); gfc_intrinsic_sym *gfc_find_function (const char *); gfc_intrinsic_sym *gfc_find_subroutine (const char *); gfc_intrinsic_sym *gfc_intrinsic_function_by_id (gfc_isym_id); @@ -3611,6 +3622,7 @@ void gfc_free_omp_declare_simd (gfc_omp_declare_simd *); void gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *); void gfc_free_omp_udr (gfc_omp_udr *); gfc_omp_udr *gfc_omp_udr_find (gfc_symtree *, gfc_typespec *); +void gfc_resolve_omp_allocate (gfc_namespace *, gfc_omp_namelist *); void gfc_resolve_omp_assumptions (gfc_omp_assumptions *); void gfc_resolve_omp_directive (gfc_code *, gfc_namespace *); void gfc_resolve_do_iterator (gfc_code *, gfc_symbol *, bool); @@ -3646,7 +3658,8 @@ void gfc_type_convert_binary (gfc_expr *, int); bool gfc_is_constant_expr (gfc_expr *); bool gfc_simplify_expr (gfc_expr *, int); bool gfc_try_simplify_expr (gfc_expr *, int); -int gfc_has_vector_index (gfc_expr *); +bool gfc_has_vector_index (gfc_expr *); +bool gfc_is_ptr_fcn (gfc_expr *); gfc_expr *gfc_get_expr (void); gfc_expr *gfc_get_array_expr (bt type, int kind, locus *); @@ -3670,7 +3683,7 @@ gfc_ref* gfc_copy_ref (gfc_ref*); bool gfc_specification_expr (gfc_expr *); -int gfc_numeric_ts (gfc_typespec *); +bool gfc_numeric_ts (gfc_typespec *); int gfc_kind_max (gfc_expr *, gfc_expr *); bool gfc_check_conformance (gfc_expr *, gfc_expr *, const char *, ...) ATTRIBUTE_PRINTF_3; @@ -3728,17 +3741,18 @@ void gfc_free_association_list (gfc_association_list *); /* resolve.cc */ void gfc_expression_rank (gfc_expr *); +bool gfc_op_rank_conformable (gfc_expr *, gfc_expr *); bool gfc_resolve_ref (gfc_expr *); bool gfc_resolve_expr (gfc_expr *); void gfc_resolve (gfc_namespace *); void gfc_resolve_code (gfc_code *, gfc_namespace *); void gfc_resolve_blocks (gfc_code *, gfc_namespace *); void gfc_resolve_formal_arglist (gfc_symbol *); -int gfc_impure_variable (gfc_symbol *); -int gfc_pure (gfc_symbol *); -int gfc_implicit_pure (gfc_symbol *); +bool gfc_impure_variable (gfc_symbol *); +bool gfc_pure (gfc_symbol *); +bool gfc_implicit_pure (gfc_symbol *); void gfc_unset_implicit_pure (gfc_symbol *); -int gfc_elemental (gfc_symbol *); +bool gfc_elemental (gfc_symbol *); bool gfc_resolve_iterator (gfc_iterator *, bool, bool); bool find_forall_index (gfc_expr *, gfc_symbol *, int); bool gfc_resolve_index (gfc_expr *, int); @@ -3752,8 +3766,8 @@ bool gfc_resolve_intrinsic (gfc_symbol *, locus *); bool gfc_explicit_interface_required (gfc_symbol *, char *, int); extern int gfc_do_concurrent_flag; const char* gfc_lookup_function_fuzzy (const char *, gfc_symtree *); -int gfc_pure_function (gfc_expr *e, const char **name); -int gfc_implicit_pure_function (gfc_expr *e); +bool gfc_pure_function (gfc_expr *e, const char **name); +bool gfc_implicit_pure_function (gfc_expr *e); /* array.cc */ @@ -3766,12 +3780,12 @@ bool gfc_set_array_spec (gfc_symbol *, gfc_array_spec *, locus *); gfc_array_spec *gfc_copy_array_spec (gfc_array_spec *); bool gfc_resolve_array_spec (gfc_array_spec *, int); -int gfc_compare_array_spec (gfc_array_spec *, gfc_array_spec *); +bool gfc_compare_array_spec (gfc_array_spec *, gfc_array_spec *); void gfc_simplify_iterator_var (gfc_expr *); bool gfc_expand_constructor (gfc_expr *, bool); -int gfc_constant_ac (gfc_expr *); -int gfc_expanded_ac (gfc_expr *); +bool gfc_constant_ac (gfc_expr *); +bool gfc_expanded_ac (gfc_expr *); bool gfc_resolve_character_array_constructor (gfc_expr *); bool gfc_resolve_array_constructor (gfc_expr *); bool gfc_check_constructor_type (gfc_expr *); @@ -3856,7 +3870,7 @@ symbol_attribute gfc_expr_attr (gfc_expr *); symbol_attribute gfc_caf_attr (gfc_expr *, bool i = false, bool *r = NULL); match gfc_match_rvalue (gfc_expr **); match gfc_match_varspec (gfc_expr*, int, bool, bool); -int gfc_check_digit (char, int); +bool gfc_check_digit (char, int); bool gfc_is_function_return_value (gfc_symbol *, gfc_namespace *); bool gfc_convert_to_structure_constructor (gfc_expr *, gfc_symbol *, gfc_expr **, @@ -3967,6 +3981,7 @@ bool gfc_fix_implicit_pure (gfc_namespace *); void gfc_convert_mpz_to_signed (mpz_t, int); gfc_expr *gfc_simplify_ieee_functions (gfc_expr *); +bool gfc_is_constant_array_expr (gfc_expr *); bool gfc_is_size_zero_array (gfc_expr *); /* trans-array.cc */ diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi index b967129..7786d23 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -1407,7 +1407,7 @@ When omitted, the count is implicitly assumed to be one. To support legacy codes, GNU Fortran allows the comma separator to be omitted immediately before and after character string edit descriptors in @code{FORMAT} statements. A comma with no following format -decriptor is permited if the @option{-fdec-blank-format-item} is given on +descriptor is permitted if the @option{-fdec-blank-format-item} is given on the command line. This is considered non-conforming code and is discouraged. @@ -3893,7 +3893,7 @@ typedef enum caf_deregister_t { caf_deregister_t; @end verbatim -Allows to specifiy the type of deregistration of a coarray object. The +Allows to specify the type of deregistration of a coarray object. The @code{CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY} flag is only allowed for allocatable components in derived type coarrays. @@ -4858,7 +4858,7 @@ an error message; may be NULL. @item @emph{NOTES} This acts like an atomic add of one to the remote image's event variable. The statement is an image-control statement but does not imply sync memory. -Still, all preceeding push communications of this image to the specified +Still, all preceding push communications of this image to the specified remote image have to be completed before @code{event_wait} on the remote image returns. @end table @@ -4903,7 +4903,7 @@ cores) followed by another waiting strategy such as a sleeping wait (possibly with an increasing number of sleep time) or, if possible, a futex wait. The statement is an image-control statement but does not imply sync memory. -Still, all preceeding push communications of this image to the specified +Still, all preceding push communications of this image to the specified remote image have to be completed before @code{event_wait} on the remote image returns. @end table diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc index db79b10..ea82056 100644 --- a/gcc/fortran/interface.cc +++ b/gcc/fortran/interface.cc @@ -2361,7 +2361,23 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, && formal->ts.u.derived && formal->ts.u.derived->ts.is_iso_c && actual->ts.type == BT_DERIVED && actual->ts.u.derived && actual->ts.u.derived->ts.is_iso_c) - return true; + { + if (formal->ts.u.derived->intmod_sym_id + != actual->ts.u.derived->intmod_sym_id) + return false; + + if (ranks_must_agree + && symbol_rank (formal) != actual->rank + && symbol_rank (formal) != -1) + { + if (where) + argument_rank_mismatch (formal->name, &actual->where, + symbol_rank (formal), actual->rank, + NULL); + return false; + } + return true; + } if (formal->ts.type == BT_CLASS && actual->ts.type == BT_DERIVED) /* Make sure the vtab symbol is present when @@ -3296,6 +3312,16 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, } } + if (UNLIMITED_POLY (a->expr) + && !(f->sym->ts.type == BT_ASSUMED || UNLIMITED_POLY (f->sym))) + { + gfc_error ("Unlimited polymorphic actual argument at %L is not " + "matched with either an unlimited polymorphic or " + "assumed type dummy argument", &a->expr->where); + ok = false; + goto match; + } + /* Special case for character arguments. For allocatable, pointer and assumed-shape dummies, the string length needs to match exactly. */ @@ -3622,6 +3648,18 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, goto match; } + if (a->expr->expr_type == EXPR_FUNCTION + && a->expr->value.function.esym + && f->sym->attr.allocatable) + { + if (where) + gfc_error ("Actual argument for %qs at %L is a function result " + "and the dummy argument is ALLOCATABLE", + f->sym->name, &a->expr->where); + ok = false; + goto match; + } + /* Check intent = OUT/INOUT for definable actual argument. */ if (!in_statement_function && (f->sym->attr.intent == INTENT_OUT diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc index 1a26b7a..74970e5 100644 --- a/gcc/fortran/intrinsic.cc +++ b/gcc/fortran/intrinsic.cc @@ -1107,7 +1107,7 @@ gfc_find_subroutine (const char *name) /* Given a string, figure out if it is the name of a generic intrinsic function or not. */ -int +bool gfc_generic_intrinsic (const char *name) { gfc_intrinsic_sym *sym; @@ -1120,7 +1120,7 @@ gfc_generic_intrinsic (const char *name) /* Given a string, figure out if it is the name of a specific intrinsic function or not. */ -int +bool gfc_specific_intrinsic (const char *name) { gfc_intrinsic_sym *sym; @@ -1132,7 +1132,7 @@ gfc_specific_intrinsic (const char *name) /* Given a string, figure out if it is the name of an intrinsic function or subroutine allowed as an actual argument or not. */ -int +bool gfc_intrinsic_actual_ok (const char *name, const bool subroutine_flag) { gfc_intrinsic_sym *sym; @@ -3310,7 +3310,7 @@ add_functions (void) make_generic ("loc", GFC_ISYM_LOC, GFC_STD_GNU); - /* The next of intrinsic subprogram are the degree trignometric functions. + /* The next of intrinsic subprogram are the degree trigonometric functions. These were hidden behind the -fdec-math option, but are now simply included as extensions to the set of intrinsic subprograms. */ diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index 5555db2..6c7ad03 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -15247,8 +15247,9 @@ with the following options: @code{-fno-unsafe-math-optimizations @table @asis @item @emph{Standard}: OpenMP Application Program Interface v4.5, -OpenMP Application Program Interface v5.0 (partially supported) and -OpenMP Application Program Interface v5.1 (partially supported). +OpenMP Application Program Interface v5.0 (partially supported), +OpenMP Application Program Interface v5.1 (partially supported) and +OpenMP Application Program Interface v5.2 (partially supported). @end table The OpenMP Fortran runtime library routines are provided both in @@ -15262,9 +15263,13 @@ below. For details refer to the actual @uref{https://www.openmp.org/wp-content/uploads/openmp-4.5.pdf, -OpenMP Application Program Interface v4.5} and +OpenMP Application Program Interface v4.5}, @uref{https://www.openmp.org/wp-content/uploads/OpenMP-API-Specification-5.0.pdf, -OpenMP Application Program Interface v5.0}. +OpenMP Application Program Interface v5.0}, +@uref{https://www.openmp.org/wp-content/uploads/OpenMP-API-Specification-5-1.pdf, +OpenMP Application Program Interface v5.1} and +@uref{https://www.openmp.org/wp-content/uploads/OpenMP-API-Specification-5-2.pdf, +OpenMP Application Program Interface v5.2}. @code{OMP_LIB_KINDS} provides the following scalar default-integer named constants: @@ -15295,6 +15300,13 @@ The following derived type: @item @code{omp_alloctrait} @end table +The following scalar default-integer named constants: +@table @asis +@item @code{omp_initial_device} +@item @code{omp_invalid_device} +@end table + + The following scalar integer named constants of the kind @code{omp_sched_kind}: diff --git a/gcc/fortran/io.cc b/gcc/fortran/io.cc index 594f609..f0c605e 100644 --- a/gcc/fortran/io.cc +++ b/gcc/fortran/io.cc @@ -2010,15 +2010,6 @@ gfc_free_open (gfc_open *open) free (open); } - -static int -compare_to_allowed_values (const char *specifier, const char *allowed[], - const char *allowed_f2003[], - const char *allowed_gnu[], gfc_char_t *value, - const char *statement, bool warn, locus *where, - int *num = NULL); - - static bool check_open_constraints (gfc_open *open, locus *where); @@ -2062,12 +2053,12 @@ gfc_resolve_open (gfc_open *open, locus *where) value if it is not allowed. */ -static int +static bool compare_to_allowed_values (const char *specifier, const char *allowed[], const char *allowed_f2003[], const char *allowed_gnu[], gfc_char_t *value, const char *statement, bool warn, locus *where, - int *num) + int *num = NULL) { int i; unsigned int len; diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc index 33794f0..571e1bd 100644 --- a/gcc/fortran/iresolve.cc +++ b/gcc/fortran/iresolve.cc @@ -230,7 +230,9 @@ gfc_resolve_adjustl (gfc_expr *f, gfc_expr *string) { f->ts.type = BT_CHARACTER; f->ts.kind = string->ts.kind; - if (string->ts.u.cl) + if (string->ts.deferred) + f->ts = string->ts; + else if (string->ts.u.cl) f->ts.u.cl = gfc_new_charlen (gfc_current_ns, string->ts.u.cl); f->value.function.name = gfc_get_string ("__adjustl_s%d", f->ts.kind); @@ -242,7 +244,9 @@ gfc_resolve_adjustr (gfc_expr *f, gfc_expr *string) { f->ts.type = BT_CHARACTER; f->ts.kind = string->ts.kind; - if (string->ts.u.cl) + if (string->ts.deferred) + f->ts = string->ts; + else if (string->ts.u.cl) f->ts.u.cl = gfc_new_charlen (gfc_current_ns, string->ts.u.cl); f->value.function.name = gfc_get_string ("__adjustr_s%d", f->ts.kind); @@ -2420,7 +2424,7 @@ gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape, break; } - if (shape->expr_type == EXPR_ARRAY && gfc_is_constant_expr (shape)) + if (shape->expr_type == EXPR_ARRAY && gfc_is_constant_array_expr (shape)) { gfc_constructor *c; f->shape = gfc_get_shape (f->rank); @@ -3100,7 +3104,7 @@ gfc_resolve_trim (gfc_expr *f, gfc_expr *string) } -/* Resolve the degree trignometric functions. This amounts to setting +/* Resolve the degree 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. */ @@ -3361,7 +3365,7 @@ gfc_resolve_mvbits (gfc_code *c) } -/* Set up the call to RANDOM_INIT. */ +/* Set up the call to RANDOM_INIT. */ void gfc_resolve_random_init (gfc_code *c) diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc index 5eb6d0e..ca64e59 100644 --- a/gcc/fortran/match.cc +++ b/gcc/fortran/match.cc @@ -1084,7 +1084,8 @@ gfc_match_char (char c, bool gobble_ws) %% Literal percent sign %e Expression, pointer to a pointer is set - %s Symbol, pointer to the symbol is set + %s Symbol, pointer to the symbol is set (host_assoc = 0) + %S Symbol, pointer to the symbol is set (host_assoc = 1) %n Name, character buffer is set to name %t Matches end of statement. %o Matches an intrinsic operator, returned as an INTRINSIC enum. @@ -1151,8 +1152,9 @@ loop: goto loop; case 's': + case 'S': vp = va_arg (argp, void **); - n = gfc_match_symbol ((gfc_symbol **) vp, 0); + n = gfc_match_symbol ((gfc_symbol **) vp, c == 'S'); if (n != MATCH_YES) { m = n; @@ -5534,17 +5536,20 @@ gfc_free_namelist (gfc_namelist *name) /* Free an OpenMP namelist structure. */ void -gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns, bool free_align) +gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns, + bool free_align_allocator) { gfc_omp_namelist *n; for (; name; name = n) { gfc_free_expr (name->expr); - if (free_align) + if (free_align_allocator) gfc_free_expr (name->u.align); if (free_ns) gfc_free_namespace (name->u2.ns); + else if (free_align_allocator) + gfc_free_expr (name->u2.allocator); else if (name->u2.udr) { if (name->u2.udr->combiner) @@ -5736,7 +5741,7 @@ gfc_match_equivalence (void) /* EQUIVALENCE has been matched. After gobbling any possible whitespace, the next character needs to be '('. Check that here, and return - MATCH_NO for a variable of the form equivalencej. */ + MATCH_NO for a variable of the form equivalence. */ gfc_gobble_whitespace (); c = gfc_peek_ascii_char (); if (c != '(') @@ -6374,6 +6379,39 @@ build_class_sym: } +/* Build the associate name */ +static int +build_associate_name (const char *name, gfc_expr **e1, gfc_expr **e2) +{ + gfc_expr *expr1 = *e1; + gfc_expr *expr2 = *e2; + gfc_symbol *sym; + + /* For the case where the associate name is already an associate name. */ + if (!expr2) + expr2 = expr1; + expr1 = gfc_get_expr (); + expr1->expr_type = EXPR_VARIABLE; + expr1->where = expr2->where; + if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false)) + return 1; + + sym = expr1->symtree->n.sym; + if (expr2->ts.type == BT_UNKNOWN) + sym->attr.untyped = 1; + else + copy_ts_from_selector_to_associate (expr1, expr2); + + sym->attr.flavor = FL_VARIABLE; + sym->attr.referenced = 1; + sym->attr.class_ok = 1; + + *e1 = expr1; + *e2 = expr2; + return 0; +} + + /* Push the current selector onto the SELECT TYPE stack. */ static void @@ -6529,7 +6567,6 @@ gfc_match_select_type (void) match m; char name[GFC_MAX_SYMBOL_LEN + 1]; bool class_array; - gfc_symbol *sym; gfc_namespace *ns = gfc_current_ns; m = gfc_match_label (); @@ -6551,24 +6588,11 @@ gfc_match_select_type (void) m = gfc_match (" %n => %e", name, &expr2); if (m == MATCH_YES) { - expr1 = gfc_get_expr (); - expr1->expr_type = EXPR_VARIABLE; - expr1->where = expr2->where; - if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false)) + if (build_associate_name (name, &expr1, &expr2)) { m = MATCH_ERROR; goto cleanup; } - - sym = expr1->symtree->n.sym; - if (expr2->ts.type == BT_UNKNOWN) - sym->attr.untyped = 1; - else - copy_ts_from_selector_to_associate (expr1, expr2); - - sym->attr.flavor = FL_VARIABLE; - sym->attr.referenced = 1; - sym->attr.class_ok = 1; } else { @@ -6615,6 +6639,17 @@ gfc_match_select_type (void) goto cleanup; } + /* Prevent an existing associate name from reuse here by pushing expr1 to + expr2 and building a new associate name. */ + if (!expr2 && expr1->symtree->n.sym->assoc + && !expr1->symtree->n.sym->attr.select_type_temporary + && !expr1->symtree->n.sym->attr.select_rank_temporary + && build_associate_name (expr1->symtree->n.sym->name, &expr1, &expr2)) + { + m = MATCH_ERROR; + goto cleanup; + } + new_st.op = EXEC_SELECT_TYPE; new_st.expr1 = expr1; new_st.expr2 = expr2; diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 4430aff..7d72725 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -149,6 +149,8 @@ match gfc_match_oacc_routine (void); /* OpenMP directive matchers. */ match gfc_match_omp_eos_error (void); +match gfc_match_omp_allocate (void); +match gfc_match_omp_allocators (void); match gfc_match_omp_assume (void); match gfc_match_omp_assumes (void); match gfc_match_omp_atomic (void); diff --git a/gcc/fortran/mathbuiltins.def b/gcc/fortran/mathbuiltins.def index c6bb3e8..51cb9a4 100644 --- a/gcc/fortran/mathbuiltins.def +++ b/gcc/fortran/mathbuiltins.def @@ -61,6 +61,8 @@ OTHER_BUILTIN (COPYSIGN, "copysign", 2, true) OTHER_BUILTIN (CPOW, "cpow", cpow, true) OTHER_BUILTIN (FABS, "fabs", 1, true) OTHER_BUILTIN (FMA, "fma", 3, true) +OTHER_BUILTIN (FMAX, "fmax", 2, true) +OTHER_BUILTIN (FMIN, "fmin", 2, true) OTHER_BUILTIN (FMOD, "fmod", 2, true) OTHER_BUILTIN (FREXP, "frexp", frexp, false) OTHER_BUILTIN (LOGB, "logb", 1, true) diff --git a/gcc/fortran/module.cc b/gcc/fortran/module.cc index 601497e..95fdda6 100644 --- a/gcc/fortran/module.cc +++ b/gcc/fortran/module.cc @@ -2419,7 +2419,7 @@ mio_symbol_attribute (symbol_attribute *attr) MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_SEQ, attr_bits); break; case OACC_ROUTINE_LOP_ERROR: - /* ... intentionally omitted here; it's only unsed internally. */ + /* ... intentionally omitted here; it's only used internally. */ default: gcc_unreachable (); } diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc index b8b6686..8efc4b3 100644 --- a/gcc/fortran/openmp.cc +++ b/gcc/fortran/openmp.cc @@ -54,8 +54,8 @@ struct gfc_omp_directive { and "nothing". */ static const struct gfc_omp_directive gfc_omp_directives[] = { - /* {"allocate", GFC_OMP_DIR_DECLARATIVE, ST_OMP_ALLOCATE}, */ - /* {"allocators", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ALLOCATORS}, */ + {"allocate", GFC_OMP_DIR_DECLARATIVE, ST_OMP_ALLOCATE}, + {"allocators", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ALLOCATORS}, {"assumes", GFC_OMP_DIR_INFORMATIONAL, ST_OMP_ASSUMES}, {"assume", GFC_OMP_DIR_INFORMATIONAL, ST_OMP_ASSUME}, {"atomic", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ATOMIC}, @@ -394,7 +394,8 @@ gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list, gfc_omp_namelist ***headp = NULL, bool allow_sections = false, bool allow_derived = false, - bool *has_all_memory = NULL) + bool *has_all_memory = NULL, + bool reject_common_vars = false) { gfc_omp_namelist *head, *tail, *p; locus old_loc, cur_loc; @@ -482,6 +483,15 @@ gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list, tail->sym = sym; tail->expr = expr; tail->where = cur_loc; + if (reject_common_vars && sym->attr.in_common) + { + gcc_assert (allow_common); + gfc_error ("%qs at %L is part of the common block %</%s/%> and " + "may only be specificed implicitly via the named " + "common block", sym->name, &cur_loc, + sym->common_head->name); + goto cleanup; + } goto next_item; case MATCH_NO: break; @@ -1326,6 +1336,30 @@ failed: return MATCH_NO; } +/* Match target update's to/from( [present:] var-list). */ + +static match +gfc_match_motion_var_list (const char *str, gfc_omp_namelist **list, + gfc_omp_namelist ***headp) +{ + match m = gfc_match (str); + if (m != MATCH_YES) + return m; + + match m_present = gfc_match (" present : "); + + m = gfc_match_omp_variable_list ("", list, false, NULL, headp, true, true); + if (m != MATCH_YES) + return m; + if (m_present == MATCH_YES) + { + gfc_omp_namelist *n; + for (n = **headp; n; n = n->next) + n->u.present_modifier = true; + } + return MATCH_YES; +} + /* reduction ( reduction-modifier, reduction-operator : variable-list ) in_reduction ( reduction-operator : variable-list ) task_reduction ( reduction-operator : variable-list ) */ @@ -1895,7 +1929,8 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, for (gfc_omp_namelist *n = *head; n; n = n->next) { - n->expr = (allocator) ? gfc_copy_expr (allocator) : NULL; + n->u2.allocator = ((allocator) + ? gfc_copy_expr (allocator) : NULL); n->u.align = (align) ? gfc_copy_expr (align) : NULL; } gfc_free_expr (allocator); @@ -2087,6 +2122,8 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, behavior = OMP_DEFAULTMAP_FROM; else if (gfc_match ("firstprivate ") == MATCH_YES) behavior = OMP_DEFAULTMAP_FIRSTPRIVATE; + else if (gfc_match ("present ") == MATCH_YES) + behavior = OMP_DEFAULTMAP_PRESENT; else if (gfc_match ("none ") == MATCH_YES) behavior = OMP_DEFAULTMAP_NONE; else if (gfc_match ("default ") == MATCH_YES) @@ -2094,7 +2131,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, else { gfc_error ("Expected ALLOC, TO, FROM, TOFROM, FIRSTPRIVATE, " - "NONE or DEFAULT at %C"); + "PRESENT, NONE or DEFAULT at %C"); break; } if (')' == gfc_peek_ascii_char ()) @@ -2518,10 +2555,8 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, true) == MATCH_YES) continue; if ((mask & OMP_CLAUSE_FROM) - && (gfc_match_omp_variable_list ("from (", - &c->lists[OMP_LIST_FROM], false, - NULL, &head, true, true) - == MATCH_YES)) + && gfc_match_motion_var_list ("from (", &c->lists[OMP_LIST_FROM], + &head) == MATCH_YES) continue; break; case 'g': @@ -2877,8 +2912,10 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, locus old_loc2 = gfc_current_locus; int always_modifier = 0; int close_modifier = 0; + int present_modifier = 0; locus second_always_locus = old_loc2; locus second_close_locus = old_loc2; + locus second_present_locus = old_loc2; for (;;) { @@ -2893,20 +2930,38 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if (close_modifier++ == 1) second_close_locus = current_locus; } + else if (gfc_match ("present ") == MATCH_YES) + { + if (present_modifier++ == 1) + second_present_locus = current_locus; + } else break; gfc_match (", "); } gfc_omp_map_op map_op = OMP_MAP_TOFROM; + int always_present_modifier + = always_modifier && present_modifier; + if (gfc_match ("alloc : ") == MATCH_YES) - map_op = OMP_MAP_ALLOC; + map_op = (present_modifier ? OMP_MAP_PRESENT_ALLOC + : OMP_MAP_ALLOC); else if (gfc_match ("tofrom : ") == MATCH_YES) - map_op = always_modifier ? OMP_MAP_ALWAYS_TOFROM : OMP_MAP_TOFROM; + map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_TOFROM + : present_modifier ? OMP_MAP_PRESENT_TOFROM + : always_modifier ? OMP_MAP_ALWAYS_TOFROM + : OMP_MAP_TOFROM); else if (gfc_match ("to : ") == MATCH_YES) - map_op = always_modifier ? OMP_MAP_ALWAYS_TO : OMP_MAP_TO; + map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_TO + : present_modifier ? OMP_MAP_PRESENT_TO + : always_modifier ? OMP_MAP_ALWAYS_TO + : OMP_MAP_TO); else if (gfc_match ("from : ") == MATCH_YES) - map_op = always_modifier ? OMP_MAP_ALWAYS_FROM : OMP_MAP_FROM; + map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_FROM + : present_modifier ? OMP_MAP_PRESENT_FROM + : always_modifier ? OMP_MAP_ALWAYS_FROM + : OMP_MAP_FROM); else if (gfc_match ("release : ") == MATCH_YES) map_op = OMP_MAP_RELEASE; else if (gfc_match ("delete : ") == MATCH_YES) @@ -2930,6 +2985,12 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, &second_close_locus); break; } + if (present_modifier > 1) + { + gfc_error ("too many %<present%> modifiers at %L", + &second_present_locus); + break; + } head = NULL; if (gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_MAP], @@ -3456,10 +3517,8 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, continue; } else if ((mask & OMP_CLAUSE_TO) - && (gfc_match_omp_variable_list ("to (", - &c->lists[OMP_LIST_TO], false, - NULL, &head, true, true) - == MATCH_YES)) + && gfc_match_motion_var_list ("to (", &c->lists[OMP_LIST_TO], + &head) == MATCH_YES) continue; break; case 'u': @@ -4270,6 +4329,8 @@ cleanup: (omp_mask (OMP_CLAUSE_AT) | OMP_CLAUSE_MESSAGE | OMP_CLAUSE_SEVERITY) #define OMP_WORKSHARE_CLAUSES \ omp_mask (OMP_CLAUSE_NOWAIT) +#define OMP_ALLOCATORS_CLAUSES \ + omp_mask (OMP_CLAUSE_ALLOCATE) static match @@ -4284,6 +4345,113 @@ match_omp (gfc_exec_op op, const omp_mask mask) return MATCH_YES; } +/* Handles both declarative and (deprecated) executable ALLOCATE directive; + accepts optional list (for executable) and common blocks. + If no variables have been provided, the single omp namelist has sym == NULL. + + Note that the executable ALLOCATE directive permits structure elements only + in OpenMP 5.0 and 5.1 but not longer in 5.2. See also the comment on the + 'omp allocators' directive below. The accidental change was reverted for + OpenMP TR12, permitting them again. See also gfc_match_omp_allocators. + + Hence, structure elements are rejected for now, also to make resolving + OMP_LIST_ALLOCATE simpler (check for duplicates, same symbol in + Fortran allocate stmt). TODO: Permit structure elements. */ + +match +gfc_match_omp_allocate (void) +{ + match m; + bool first = true; + gfc_omp_namelist *vars = NULL; + gfc_expr *align = NULL; + gfc_expr *allocator = NULL; + locus loc = gfc_current_locus; + + m = gfc_match_omp_variable_list (" (", &vars, true, NULL, NULL, true, true, + NULL, true); + + if (m == MATCH_ERROR) + return m; + + while (true) + { + gfc_gobble_whitespace (); + if (gfc_match_omp_eos () == MATCH_YES) + break; + if (!first) + gfc_match (", "); + first = false; + if ((m = gfc_match_dupl_check (!align, "align", true, &align)) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + continue; + } + if ((m = gfc_match_dupl_check (!allocator, "allocator", + true, &allocator)) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + continue; + } + gfc_error ("Expected ALIGN or ALLOCATOR clause at %C"); + return MATCH_ERROR; + } + for (gfc_omp_namelist *n = vars; n; n = n->next) + if (n->expr) + { + if ((n->expr->ref && n->expr->ref->type == REF_COMPONENT) + || (n->expr->ref->next && n->expr->ref->type == REF_COMPONENT)) + gfc_error ("Sorry, structure-element list item at %L in ALLOCATE " + "directive is not yet supported", &n->expr->where); + else + gfc_error ("Unexpected expression as list item at %L in ALLOCATE " + "directive", &n->expr->where); + + gfc_free_omp_namelist (vars, false, true); + goto error; + } + + new_st.op = EXEC_OMP_ALLOCATE; + new_st.ext.omp_clauses = gfc_get_omp_clauses (); + if (vars == NULL) + { + vars = gfc_get_omp_namelist (); + vars->where = loc; + vars->u.align = align; + vars->u2.allocator = allocator; + new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = vars; + } + else + { + new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = vars; + for (; vars; vars = vars->next) + { + vars->u.align = (align) ? gfc_copy_expr (align) : NULL; + vars->u2.allocator = ((allocator) ? gfc_copy_expr (allocator) : NULL); + } + gfc_free_expr (allocator); + gfc_free_expr (align); + } + return MATCH_YES; + +error: + gfc_free_expr (align); + gfc_free_expr (allocator); + return MATCH_ERROR; +} + +/* In line with OpenMP 5.2 derived-type components are rejected. + See also comment before gfc_match_omp_allocate. */ + +match +gfc_match_omp_allocators (void) +{ + return match_omp (EXEC_OMP_ALLOCATORS, OMP_ALLOCATORS_CLAUSES); +} + match gfc_match_omp_assume (void) @@ -6903,6 +7071,128 @@ resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns, return copy; } +/* Assume that a constant expression in the range 1 (omp_default_mem_alloc) + to 8 (omp_thread_mem_alloc) range is fine. The original symbol name is + already lost during matching via gfc_match_expr. */ +bool +is_predefined_allocator (gfc_expr *expr) +{ + return (gfc_resolve_expr (expr) + && expr->rank == 0 + && expr->ts.type == BT_INTEGER + && expr->ts.kind == gfc_c_intptr_kind + && expr->expr_type == EXPR_CONSTANT + && mpz_sgn (expr->value.integer) > 0 + && mpz_cmp_si (expr->value.integer, 8) <= 0); +} + +/* Resolve declarative ALLOCATE statement. Note: Common block vars only appear + as /block/ not individual, which is ensured during parsing. */ + +void +gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list) +{ + for (gfc_omp_namelist *n = list; n; n = n->next) + n->sym->mark = 0; + for (gfc_omp_namelist *n = list; n; n = n->next) + { + if (n->sym->attr.flavor != FL_VARIABLE) + { + gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE " + "directive must be a variable", n->sym->name, + &n->where); + continue; + } + if (ns != n->sym->ns || n->sym->attr.use_assoc + || n->sym->attr.host_assoc || n->sym->attr.imported) + { + gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE shall be" + " in the same scope as the variable declaration", + n->sym->name, &n->where); + continue; + } + if (n->sym->attr.dummy) + { + gfc_error ("Unexpected dummy argument %qs as argument at %L to " + "declarative !$OMP ALLOCATE", n->sym->name, &n->where); + continue; + } + if (n->sym->mark) + { + if (n->sym->attr.in_common) + { + gfc_error ("Duplicated common block %</%s/%> in !$OMP ALLOCATE " + "at %L", n->sym->common_head->name, &n->where); + while (n->next && n->next->sym + && n->sym->common_head == n->next->sym->common_head) + n = n->next; + } + else + gfc_error ("Duplicated variable %qs in !$OMP ALLOCATE at %L", + n->sym->name, &n->where); + continue; + } + n->sym->mark = 1; + if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok + && CLASS_DATA (n->sym)->attr.allocatable) + || (n->sym->ts.type != BT_CLASS && n->sym->attr.allocatable)) + gfc_error ("Unexpected allocatable variable %qs at %L in declarative " + "!$OMP ALLOCATE directive", n->sym->name, &n->where); + else if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok + && CLASS_DATA (n->sym)->attr.class_pointer) + || (n->sym->ts.type != BT_CLASS && n->sym->attr.pointer)) + gfc_error ("Unexpected pointer variable %qs at %L in declarative " + "!$OMP ALLOCATE directive", n->sym->name, &n->where); + HOST_WIDE_INT alignment = 0; + if (n->u.align + && (!gfc_resolve_expr (n->u.align) + || n->u.align->ts.type != BT_INTEGER + || n->u.align->rank != 0 + || n->u.align->expr_type != EXPR_CONSTANT + || gfc_extract_hwi (n->u.align, &alignment) + || !pow2p_hwi (alignment))) + { + gfc_error ("ALIGN requires a scalar positive constant integer " + "alignment expression at %L that is a power of two", + &n->u.align->where); + while (n->sym->attr.in_common && n->next && n->next->sym + && n->sym->common_head == n->next->sym->common_head) + n = n->next; + continue; + } + 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))) + { + bool com = n->sym->attr.in_common; + if (!n->u2.allocator) + gfc_error ("An ALLOCATOR clause is required as the list item " + "%<%s%s%s%> at %L has the SAVE attribute", com ? "/" : "", + com ? n->sym->common_head->name : n->sym->name, + com ? "/" : "", &n->where); + else if (!is_predefined_allocator (n->u2.allocator)) + gfc_error ("Predefined allocator required in ALLOCATOR clause at %L" + " as the list item %<%s%s%s%> at %L has the SAVE attribute", + &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; + } + else if (n->u2.allocator + && (!gfc_resolve_expr (n->u2.allocator) + || n->u2.allocator->ts.type != BT_INTEGER + || n->u2.allocator->rank != 0 + || n->u2.allocator->ts.kind != gfc_c_intptr_kind)) + gfc_error ("Expected integer expression of the " + "%<omp_allocator_handle_kind%> kind at %L", + &n->u2.allocator->where); + } + gfc_error ("Sorry, declarative !$OMP ALLOCATE at %L not yet supported", + &list->where); +} /* Resolve ASSUME's and ASSUMES' assumption clauses. Note that absent/contains is handled during parse time in omp_verify_merge_absent_contains. */ @@ -7376,28 +7666,31 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, { for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) { - if (n->expr && (!gfc_resolve_expr (n->expr) - || n->expr->ts.type != BT_INTEGER - || n->expr->ts.kind != gfc_c_intptr_kind)) + if (n->u2.allocator + && (!gfc_resolve_expr (n->u2.allocator) + || n->u2.allocator->ts.type != BT_INTEGER + || n->u2.allocator->rank != 0 + || n->u2.allocator->ts.kind != gfc_c_intptr_kind)) { gfc_error ("Expected integer expression of the " "%<omp_allocator_handle_kind%> kind at %L", - &n->expr->where); + &n->u2.allocator->where); break; } if (!n->u.align) continue; - int alignment = 0; + HOST_WIDE_INT alignment = 0; if (!gfc_resolve_expr (n->u.align) || n->u.align->ts.type != BT_INTEGER || n->u.align->rank != 0 - || gfc_extract_int (n->u.align, &alignment) + || n->u.align->expr_type != EXPR_CONSTANT + || gfc_extract_hwi (n->u.align, &alignment) || alignment <= 0 || !pow2p_hwi (alignment)) { - gfc_error ("ALIGN modifier requires at %L a scalar positive " - "constant integer alignment expression that is a " - "power of two", &n->u.align->where); + gfc_error ("ALIGN requires a scalar positive constant integer " + "alignment expression at %L that is a power of two", + &n->u.align->where); break; } } @@ -7407,15 +7700,21 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, 2. Variable in allocate clause are also present in some privatization clase (non-composite case). */ for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) - n->sym->mark = 0; + if (n->sym) + n->sym->mark = 0; gfc_omp_namelist *prev = NULL; - for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n;) + for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; ) { + if (n->sym == NULL) + { + n = n->next; + continue; + } if (n->sym->mark == 1) { gfc_warning (0, "%qs appears more than once in %<allocate%> " - "clauses at %L" , n->sym->name, &n->where); + "at %L" , n->sym->name, &n->where); /* We have already seen this variable so it is a duplicate. Remove it. */ if (prev != NULL && prev->next == n) @@ -7460,6 +7759,28 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, "in an explicit privatization clause", n->sym->name, &n->where); } + if (code + && (code->op == EXEC_OMP_ALLOCATORS || code->op == EXEC_OMP_ALLOCATE) + && code->block + && code->block->next + && code->block->next->op == EXEC_ALLOCATE) + { + gfc_alloc *a; + for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) + { + if (n->sym == NULL) + continue; + for (a = code->block->next->ext.alloc.list; a; a = a->next) + if (a->expr->expr_type == EXPR_VARIABLE + && a->expr->symtree->n.sym == n->sym) + break; + if (a == NULL) + gfc_error ("%qs specified in %<allocate%> at %L but not " + "in the associated ALLOCATE statement", + n->sym->name, &n->where); + } + } + } /* OpenACC reductions. */ @@ -7563,15 +7884,13 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, n->sym->name, &n->where); else if (n->expr) { - gfc_expr *expr = n->expr; - int alignment = 0; - if (!gfc_resolve_expr (expr) - || expr->ts.type != BT_INTEGER - || expr->rank != 0 - || gfc_extract_int (expr, &alignment) - || alignment <= 0) - gfc_error ("%qs in ALIGNED clause at %L requires a scalar " - "positive constant integer alignment " + if (!gfc_resolve_expr (n->expr) + || n->expr->ts.type != BT_INTEGER + || n->expr->rank != 0 + || n->expr->expr_type != EXPR_CONSTANT + || mpz_sgn (n->expr->value.integer) <= 0) + gfc_error ("%qs in ALIGNED clause at %L requires a scalar" + " positive constant integer alignment " "expression", n->sym->name, &n->where); } } @@ -7711,6 +8030,22 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, &n->where); } } + if (openacc + && list == OMP_LIST_MAP + && (n->u.map_op == OMP_MAP_ATTACH + || n->u.map_op == OMP_MAP_DETACH)) + { + symbol_attribute attr; + if (n->expr) + attr = gfc_expr_attr (n->expr); + else + attr = n->sym->attr; + if (!attr.pointer && !attr.allocatable) + gfc_error ("%qs clause argument must be ALLOCATABLE or " + "a POINTER at %L", + (n->u.map_op == OMP_MAP_ATTACH) ? "attach" + : "detach", &n->where); + } if (lastref || (n->expr && (!resolved || n->expr->expr_type != EXPR_VARIABLE))) @@ -7805,11 +8140,18 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, { case OMP_MAP_TO: case OMP_MAP_ALWAYS_TO: + case OMP_MAP_PRESENT_TO: + case OMP_MAP_ALWAYS_PRESENT_TO: case OMP_MAP_FROM: case OMP_MAP_ALWAYS_FROM: + case OMP_MAP_PRESENT_FROM: + case OMP_MAP_ALWAYS_PRESENT_FROM: case OMP_MAP_TOFROM: case OMP_MAP_ALWAYS_TOFROM: + case OMP_MAP_PRESENT_TOFROM: + case OMP_MAP_ALWAYS_PRESENT_TOFROM: case OMP_MAP_ALLOC: + case OMP_MAP_PRESENT_ALLOC: break; default: gfc_error ("TARGET%s with map-type other than TO, " @@ -7825,7 +8167,10 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, { case OMP_MAP_TO: case OMP_MAP_ALWAYS_TO: + case OMP_MAP_PRESENT_TO: + case OMP_MAP_ALWAYS_PRESENT_TO: case OMP_MAP_ALLOC: + case OMP_MAP_PRESENT_ALLOC: break; case OMP_MAP_TOFROM: n->u.map_op = OMP_MAP_TO; @@ -7833,6 +8178,12 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, case OMP_MAP_ALWAYS_TOFROM: n->u.map_op = OMP_MAP_ALWAYS_TO; break; + case OMP_MAP_PRESENT_TOFROM: + n->u.map_op = OMP_MAP_PRESENT_TO; + break; + case OMP_MAP_ALWAYS_PRESENT_TOFROM: + n->u.map_op = OMP_MAP_ALWAYS_PRESENT_TO; + break; default: gfc_error ("TARGET ENTER DATA with map-type other " "than TO, TOFROM or ALLOC on MAP clause " @@ -7845,6 +8196,8 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, { case OMP_MAP_FROM: case OMP_MAP_ALWAYS_FROM: + case OMP_MAP_PRESENT_FROM: + case OMP_MAP_ALWAYS_PRESENT_FROM: case OMP_MAP_RELEASE: case OMP_MAP_DELETE: break; @@ -7854,6 +8207,12 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, case OMP_MAP_ALWAYS_TOFROM: n->u.map_op = OMP_MAP_ALWAYS_FROM; break; + case OMP_MAP_PRESENT_TOFROM: + n->u.map_op = OMP_MAP_PRESENT_FROM; + break; + case OMP_MAP_ALWAYS_PRESENT_TOFROM: + n->u.map_op = OMP_MAP_ALWAYS_PRESENT_FROM; + break; default: gfc_error ("TARGET EXIT DATA with map-type other " "than FROM, TOFROM, RELEASE, or DELETE on " @@ -7935,6 +8294,12 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, default: for (; n != NULL; n = n->next) { + if (n->sym == NULL) + { + gcc_assert (code->op == EXEC_OMP_ALLOCATORS + || code->op == EXEC_OMP_ALLOCATE); + continue; + } bool bad = false; bool is_reduction = (list == OMP_LIST_REDUCTION || list == OMP_LIST_REDUCTION_INSCAN @@ -9067,17 +9432,34 @@ gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns) if (code->ext.omp_clauses->sched_kind != OMP_SCHED_NONE) gfc_error ("SCHEDULE clause specified together with %<inscan%> " "REDUCTION clause at %L", loc); - if (!c->block - || !c->block->next - || !c->block->next->next - || c->block->next->next->op != EXEC_OMP_SCAN - || !c->block->next->next->next - || c->block->next->next->next->next) + gfc_code *block = c->block ? c->block->next : NULL; + if (block && block->op != EXEC_OMP_SCAN) + while (block && block->next && block->next->op != EXEC_OMP_SCAN) + block = block->next; + if (!block + || (block->op != EXEC_OMP_SCAN + && (!block->next || block->next->op != EXEC_OMP_SCAN))) gfc_error ("With INSCAN at %L, expected loop body with !$OMP SCAN " - "between two structured-block-sequences", loc); + "between two structured block sequences", loc); else - /* Mark as checked; flag will be unset later. */ - c->block->next->next->ext.omp_clauses->if_present = true; + { + if (block->op == EXEC_OMP_SCAN) + gfc_warning (0, "!$OMP SCAN at %L with zero executable " + "statements in preceding structured block " + "sequence", &block->loc); + if ((block->op == EXEC_OMP_SCAN && !block->next) + || (block->next && block->next->op == EXEC_OMP_SCAN + && !block->next->next)) + gfc_warning (0, "!$OMP SCAN at %L with zero executable " + "statements in succeeding structured block " + "sequence", block->op == EXEC_OMP_SCAN + ? &block->loc : &block->next->loc); + } + if (block && block->op != EXEC_OMP_SCAN) + block = block->next; + if (block && block->op == EXEC_OMP_SCAN) + /* Mark 'omp scan' as checked; flag will be unset later. */ + block->ext.omp_clauses->if_present = true; } } gfc_resolve_blocks (code->block, ns); @@ -9634,6 +10016,10 @@ omp_code_to_statement (gfc_code *code) return ST_OMP_DO; case EXEC_OMP_LOOP: return ST_OMP_LOOP; + case EXEC_OMP_ALLOCATE: + return ST_OMP_ALLOCATE_EXEC; + case EXEC_OMP_ALLOCATORS: + return ST_OMP_ALLOCATORS; case EXEC_OMP_ASSUME: return ST_OMP_ASSUME; case EXEC_OMP_ATOMIC: @@ -10155,6 +10541,8 @@ gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns) case EXEC_OMP_TEAMS_LOOP: resolve_omp_do (code); break; + case EXEC_OMP_ALLOCATE: + case EXEC_OMP_ALLOCATORS: case EXEC_OMP_ASSUME: case EXEC_OMP_CANCEL: case EXEC_OMP_ERROR: diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc index f1e55316..e53b7a4 100644 --- a/gcc/fortran/parse.cc +++ b/gcc/fortran/parse.cc @@ -39,6 +39,7 @@ static jmp_buf eof_buf; gfc_state_data *gfc_state_stack; static bool last_was_use_stmt = false; +bool in_exec_part; /* TODO: Re-order functions to kill these forward decls. */ static void check_statement_label (gfc_statement); @@ -745,6 +746,82 @@ decode_oacc_directive (void) return ST_GET_FCN_CHARACTERISTICS; } +/* Checks for the ST_OMP_ALLOCATE. First, check whether all list items + are allocatables/pointers - and if so, assume it is associated with a Fortran + ALLOCATE stmt. If not, do some initial parsing-related checks and append + namelist to namespace. + The check follows OpenMP 5.1 by requiring an executable stmt or OpenMP + construct before a directive associated with an allocate statement + (-> ST_OMP_ALLOCATE_EXEC); instead of showing an error, conversion of + ST_OMP_ALLOCATE -> ST_OMP_ALLOCATE_EXEC would be an alternative. */ + +bool +check_omp_allocate_stmt (locus *loc) +{ + gfc_omp_namelist *n; + + if (new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->sym == NULL) + { + gfc_error ("%qs directive at %L must either have a variable argument or, " + "if associated with an ALLOCATE stmt, must be preceded by an " + "executable statement or OpenMP construct", + gfc_ascii_statement (ST_OMP_ALLOCATE), loc); + return false; + } + bool has_allocatable = false; + bool has_non_allocatable = false; + for (n = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) + { + if (n->expr) + { + gfc_error ("Structure-component expression at %L in %qs directive not" + " permitted in declarative directive; as directive " + "associated with an ALLOCATE stmt it must be preceded by " + "an executable statement or OpenMP construct", + &n->expr->where, gfc_ascii_statement (ST_OMP_ALLOCATE)); + return false; + } + bool alloc_ptr; + if (n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok) + alloc_ptr = (CLASS_DATA (n->sym)->attr.allocatable + || CLASS_DATA (n->sym)->attr.class_pointer); + else + alloc_ptr = (n->sym->attr.allocatable || n->sym->attr.pointer + || n->sym->attr.proc_pointer); + if (alloc_ptr + || (n->sym->ns && n->sym->ns->proc_name + && (n->sym->ns->proc_name->attr.allocatable + || n->sym->ns->proc_name->attr.pointer + || n->sym->ns->proc_name->attr.proc_pointer))) + has_allocatable = true; + else + has_non_allocatable = true; + } + /* All allocatables - assume it is allocated with an ALLOCATE stmt. */ + if (has_allocatable && !has_non_allocatable) + { + gfc_error ("%qs directive at %L associated with an ALLOCATE stmt must be " + "preceded by an executable statement or OpenMP construct; " + "note the variables in the list all have the allocatable or " + "pointer attribute", gfc_ascii_statement (ST_OMP_ALLOCATE), + loc); + return false; + } + if (!gfc_current_ns->omp_allocate) + gfc_current_ns->omp_allocate + = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]; + else + { + for (n = gfc_current_ns->omp_allocate; n->next; n = n->next) + ; + n->next = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]; + } + new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = NULL; + gfc_free_omp_clauses (new_st.ext.omp_clauses); + return true; +} + + /* Like match, but set a flag simd_matched if keyword matched and if spec_only, goto do_spec_only without actually matching. */ #define matchs(keyword, subr, st) \ @@ -857,7 +934,16 @@ decode_omp_directive (void) first (those also shall not turn off implicit pure). */ switch (c) { + case 'a': + /* For -fopenmp-simd, ignore 'assumes'; note no clause starts with 's'. */ + if (!flag_openmp && gfc_match ("assumes") == MATCH_YES) + break; + matcho ("assumes", gfc_match_omp_assumes, ST_OMP_ASSUMES); + matchs ("assume", gfc_match_omp_assume, ST_OMP_ASSUME); + break; case 'd': + matchds ("declare reduction", gfc_match_omp_declare_reduction, + ST_OMP_DECLARE_REDUCTION); matchds ("declare simd", gfc_match_omp_declare_simd, ST_OMP_DECLARE_SIMD); matchdo ("declare target", gfc_match_omp_declare_target, @@ -865,16 +951,25 @@ decode_omp_directive (void) matchdo ("declare variant", gfc_match_omp_declare_variant, ST_OMP_DECLARE_VARIANT); break; + case 'e': + matchs ("end assume", gfc_match_omp_eos_error, ST_OMP_END_ASSUME); + matchs ("end simd", gfc_match_omp_eos_error, ST_OMP_END_SIMD); + matcho ("error", gfc_match_omp_error, ST_OMP_ERROR); + break; case 's': + matchs ("scan", gfc_match_omp_scan, ST_OMP_SCAN); matchs ("simd", gfc_match_omp_simd, ST_OMP_SIMD); break; + case 'n': + matcho ("nothing", gfc_match_omp_nothing, ST_NONE); + break; } pure_ok = false; if (flag_openmp && gfc_pure (NULL)) { - gfc_error_now ("OpenMP directives other than SIMD or DECLARE TARGET " - "at %C may not appear in PURE procedures"); + gfc_error_now ("OpenMP directive at %C is not pure and thus may not " + "appear in a PURE procedure"); gfc_error_recovery (); return ST_NONE; } @@ -885,11 +980,11 @@ decode_omp_directive (void) switch (c) { case 'a': - /* For -fopenmp-simd, ignore 'assumes'; note no clause starts with 's'. */ - if (!flag_openmp && gfc_match ("assumes") == MATCH_YES) - break; - matcho ("assumes", gfc_match_omp_assumes, ST_OMP_ASSUMES); - matchs ("assume", gfc_match_omp_assume, ST_OMP_ASSUME); + if (in_exec_part) + matcho ("allocate", gfc_match_omp_allocate, ST_OMP_ALLOCATE_EXEC); + else + matcho ("allocate", gfc_match_omp_allocate, ST_OMP_ALLOCATE); + matcho ("allocators", gfc_match_omp_allocators, ST_OMP_ALLOCATORS); matcho ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC); break; case 'b': @@ -902,8 +997,6 @@ decode_omp_directive (void) matcho ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL); break; case 'd': - matchds ("declare reduction", gfc_match_omp_declare_reduction, - ST_OMP_DECLARE_REDUCTION); matcho ("depobj", gfc_match_omp_depobj, ST_OMP_DEPOBJ); matchs ("distribute parallel do simd", gfc_match_omp_distribute_parallel_do_simd, @@ -917,8 +1010,7 @@ decode_omp_directive (void) matcho ("do", gfc_match_omp_do, ST_OMP_DO); break; case 'e': - matcho ("error", gfc_match_omp_error, ST_OMP_ERROR); - matchs ("end assume", gfc_match_omp_eos_error, ST_OMP_END_ASSUME); + matcho ("end allocators", gfc_match_omp_eos_error, ST_OMP_END_ALLOCATORS); matcho ("end atomic", gfc_match_omp_eos_error, ST_OMP_END_ATOMIC); matcho ("end critical", gfc_match_omp_end_critical, ST_OMP_END_CRITICAL); matchs ("end distribute parallel do simd", gfc_match_omp_eos_error, @@ -931,7 +1023,6 @@ decode_omp_directive (void) matchs ("end do simd", gfc_match_omp_end_nowait, ST_OMP_END_DO_SIMD); matcho ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO); matchs ("end loop", gfc_match_omp_eos_error, ST_OMP_END_LOOP); - matchs ("end simd", gfc_match_omp_eos_error, ST_OMP_END_SIMD); matcho ("end masked taskloop simd", gfc_match_omp_eos_error, ST_OMP_END_MASKED_TASKLOOP_SIMD); matcho ("end masked taskloop", gfc_match_omp_eos_error, @@ -1077,7 +1168,6 @@ decode_omp_directive (void) matcho ("requires", gfc_match_omp_requires, ST_OMP_REQUIRES); break; case 's': - matchs ("scan", gfc_match_omp_scan, ST_OMP_SCAN); matcho ("scope", gfc_match_omp_scope, ST_OMP_SCOPE); matcho ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS); matcho ("section", gfc_match_omp_eos_error, ST_OMP_SECTION); @@ -1161,19 +1251,35 @@ decode_omp_directive (void) return ST_NONE; finish: + if (ret == ST_OMP_ERROR && new_st.ext.omp_clauses->at == OMP_AT_EXECUTION) + { + gfc_unset_implicit_pure (NULL); + + if (gfc_pure (NULL)) + { + gfc_error_now ("OpenMP ERROR directive at %L with %<at(execution)%> " + "clause in a PURE procedure", &old_locus); + reject_statement (); + gfc_error_recovery (); + return ST_NONE; + } + } if (!pure_ok) { gfc_unset_implicit_pure (NULL); if (!flag_openmp && gfc_pure (NULL)) { - gfc_error_now ("OpenMP directives other than SIMD or DECLARE TARGET " - "at %C may not appear in PURE procedures"); + gfc_error_now ("OpenMP directive at %C is not pure and thus may not " + "appear in a PURE procedure"); reject_statement (); gfc_error_recovery (); return ST_NONE; } } + if (ret == ST_OMP_ALLOCATE && !check_omp_allocate_stmt (&old_locus)) + goto error_handling; + switch (ret) { /* Set omp_target_seen; exclude ST_OMP_DECLARE_TARGET. @@ -1723,7 +1829,7 @@ next_statement (void) case ST_OMP_TARGET_SIMD: case ST_OMP_TASKLOOP: case ST_OMP_TASKLOOP_SIMD: \ case ST_OMP_LOOP: case ST_OMP_PARALLEL_LOOP: case ST_OMP_TEAMS_LOOP: \ case ST_OMP_TARGET_PARALLEL_LOOP: case ST_OMP_TARGET_TEAMS_LOOP: \ - case ST_OMP_ASSUME: \ + case ST_OMP_ALLOCATE_EXEC: case ST_OMP_ALLOCATORS: case ST_OMP_ASSUME: \ case ST_CRITICAL: \ case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \ case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: \ @@ -1741,7 +1847,7 @@ 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_ASSUMES: \ + 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 /* Block end statements. Errors associated with interchanging these @@ -2362,6 +2468,13 @@ gfc_ascii_statement (gfc_statement st, bool strip_sentinel) case ST_OACC_END_ATOMIC: p = "!$ACC END ATOMIC"; break; + case ST_OMP_ALLOCATE: + case ST_OMP_ALLOCATE_EXEC: + p = "!$OMP ALLOCATE"; + break; + case ST_OMP_ALLOCATORS: + p = "!$OMP ALLOCATORS"; + break; case ST_OMP_ASSUME: p = "!$OMP ASSUME"; break; @@ -2416,6 +2529,9 @@ gfc_ascii_statement (gfc_statement st, bool strip_sentinel) case ST_OMP_DO_SIMD: p = "!$OMP DO SIMD"; break; + case ST_OMP_END_ALLOCATORS: + p = "!$OMP END ALLOCATORS"; + break; case ST_OMP_END_ASSUME: p = "!$OMP END ASSUME"; break; @@ -2983,6 +3099,7 @@ verify_st_order (st_state *p, gfc_statement st, bool silent) { case ST_NONE: p->state = ORDER_START; + in_exec_part = false; break; case ST_USE: @@ -3056,6 +3173,7 @@ verify_st_order (st_state *p, gfc_statement st, bool silent) case_exec_markers: if (p->state < ORDER_EXEC) p->state = ORDER_EXEC; + in_exec_part = true; break; default: @@ -4710,7 +4828,7 @@ done: context that causes it to become redefined. If the symbol is an iterator, we generate an error message and return nonzero. */ -int +bool gfc_check_do_variable (gfc_symtree *st) { gfc_state_data *s; @@ -4919,6 +5037,7 @@ parse_associate (void) gfc_state_data s; gfc_statement st; gfc_association_list* a; + gfc_array_spec *as; gfc_notify_std (GFC_STD_F2003, "ASSOCIATE construct at %C"); @@ -4934,8 +5053,7 @@ parse_associate (void) for (a = new_st.ext.block.assoc; a; a = a->next) { gfc_symbol* sym; - gfc_ref *ref; - gfc_array_ref *array_ref; + gfc_expr *target; if (gfc_get_sym_tree (a->name, NULL, &a->st, false)) gcc_unreachable (); @@ -4952,6 +5070,7 @@ parse_associate (void) for parsing component references on the associate-name in case of association to a derived-type. */ sym->ts = a->target->ts; + target = a->target; /* Don’t share the character length information between associate variable and target if the length is not a compile-time constant, @@ -4971,31 +5090,37 @@ parse_associate (void) && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)) sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); - /* Check if the target expression is array valued. This cannot always - be done by looking at target.rank, because that might not have been - set yet. Therefore traverse the chain of refs, looking for the last - array ref and evaluate that. */ - array_ref = NULL; - for (ref = a->target->ref; ref; ref = ref->next) - if (ref->type == REF_ARRAY) - array_ref = &ref->u.ar; - if (array_ref || a->target->rank) + /* Check if the target expression is array valued. This cannot be done + by calling gfc_resolve_expr because the context is unavailable. + However, the references can be resolved and the rank of the target + expression set. */ + if (target->ref && gfc_resolve_ref (target) + && target->expr_type != EXPR_ARRAY + && target->expr_type != EXPR_COMPCALL) + gfc_expression_rank (target); + + /* Determine whether or not function expressions with unknown type are + structure constructors. If so, the function result can be converted + to be a derived type. + TODO: Deal with references to sibling functions that have not yet been + parsed (PRs 89645 and 99065). */ + if (target->expr_type == EXPR_FUNCTION && target->ts.type == BT_UNKNOWN) { - gfc_array_spec *as; - int dim, rank = 0; - if (array_ref) + gfc_symbol *derived; + /* The derived type has a leading uppercase character. */ + gfc_find_symbol (gfc_dt_upper_string (target->symtree->name), + my_ns->parent, 1, &derived); + if (derived && derived->attr.flavor == FL_DERIVED) { - a->rankguessed = 1; - /* Count the dimension, that have a non-scalar extend. */ - for (dim = 0; dim < array_ref->dimen; ++dim) - if (array_ref->dimen_type[dim] != DIMEN_ELEMENT - && !(array_ref->dimen_type[dim] == DIMEN_UNKNOWN - && array_ref->end[dim] == NULL - && array_ref->start[dim] != NULL)) - ++rank; + sym->ts.type = BT_DERIVED; + sym->ts.u.derived = derived; } - else - rank = a->target->rank; + } + + if (target->rank) + { + int rank = 0; + rank = target->rank; /* When the rank is greater than zero then sym will be an array. */ if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)) { @@ -5006,8 +5131,8 @@ parse_associate (void) /* Don't just (re-)set the attr and as in the sym.ts, because this modifies the target's attr and as. Copy the data and do a build_class_symbol. */ - symbol_attribute attr = CLASS_DATA (a->target)->attr; - int corank = gfc_get_corank (a->target); + symbol_attribute attr = CLASS_DATA (target)->attr; + int corank = gfc_get_corank (target); gfc_typespec type; if (rank || corank) @@ -5042,7 +5167,7 @@ parse_associate (void) as = gfc_get_array_spec (); as->type = AS_DEFERRED; as->rank = rank; - as->corank = gfc_get_corank (a->target); + as->corank = gfc_get_corank (target); sym->as = as; sym->attr.dimension = 1; if (as->corank) @@ -5532,6 +5657,77 @@ parse_oacc_loop (gfc_statement acc_st) } +/* Parse an OpenMP allocate block, including optional ALLOCATORS + end directive. */ + +static gfc_statement +parse_openmp_allocate_block (gfc_statement omp_st) +{ + gfc_statement st; + gfc_code *cp, *np; + gfc_state_data s; + bool empty_list = false; + locus empty_list_loc; + gfc_omp_namelist *n_first = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]; + + if (omp_st == ST_OMP_ALLOCATE_EXEC + && new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->sym == NULL) + { + empty_list = true; + empty_list_loc = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->where; + } + + accept_statement (omp_st); + + cp = gfc_state_stack->tail; + push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL); + np = new_level (cp); + np->op = cp->op; + np->block = NULL; + + st = next_statement (); + while (omp_st == ST_OMP_ALLOCATE_EXEC && st == ST_OMP_ALLOCATE_EXEC) + { + if (empty_list && !new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->sym) + { + locus *loc = &new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->where; + gfc_error_now ("%s statements at %L and %L have both no list item but" + " only one may", gfc_ascii_statement (st), + &empty_list_loc, loc); + empty_list = false; + } + if (!new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->sym) + { + empty_list = true; + empty_list_loc = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->where; + } + for ( ; n_first->next; n_first = n_first->next) + ; + n_first->next = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]; + new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = NULL; + gfc_free_omp_clauses (new_st.ext.omp_clauses); + + accept_statement (ST_NONE); + st = next_statement (); + } + if (st != ST_ALLOCATE && omp_st == ST_OMP_ALLOCATE_EXEC) + gfc_error_now ("Unexpected %s at %C; expected ALLOCATE or %s statement", + gfc_ascii_statement (st), gfc_ascii_statement (omp_st)); + else if (st != ST_ALLOCATE) + gfc_error_now ("Unexpected %s at %C; expected ALLOCATE statement after %s", + gfc_ascii_statement (st), gfc_ascii_statement (omp_st)); + accept_statement (st); + pop_state (); + st = next_statement (); + if (omp_st == ST_OMP_ALLOCATORS && st == ST_OMP_END_ALLOCATORS) + { + accept_statement (st); + st = next_statement (); + } + return st; +} + + /* Parse the statements of an OpenMP structured block. */ static gfc_statement @@ -5687,6 +5883,11 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only) parse_forall_block (); break; + case ST_OMP_ALLOCATE_EXEC: + case ST_OMP_ALLOCATORS: + st = parse_openmp_allocate_block (st); + continue; + case ST_OMP_ASSUME: case ST_OMP_PARALLEL: case ST_OMP_PARALLEL_MASKED: @@ -5819,6 +6020,7 @@ static gfc_statement parse_executable (gfc_statement st) { int close_flag; + in_exec_part = true; if (st == ST_NONE) st = next_statement (); @@ -5929,6 +6131,11 @@ parse_executable (gfc_statement st) parse_oacc_structured_block (st); break; + case ST_OMP_ALLOCATE_EXEC: + case ST_OMP_ALLOCATORS: + st = parse_openmp_allocate_block (st); + continue; + case ST_OMP_ASSUME: case ST_OMP_PARALLEL: case ST_OMP_PARALLEL_MASKED: diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h index 75aac8b..cc57e7d 100644 --- a/gcc/fortran/parse.h +++ b/gcc/fortran/parse.h @@ -63,7 +63,7 @@ extern gfc_state_data *gfc_state_stack; #define gfc_comp_struct(s) \ ((s) == COMP_DERIVED || (s) == COMP_STRUCTURE || (s) == COMP_MAP) -int gfc_check_do_variable (gfc_symtree *); +bool gfc_check_do_variable (gfc_symtree *); bool gfc_find_state (gfc_compile_state); gfc_state_data *gfc_enclosing_unit (gfc_compile_state *); const char *gfc_ascii_statement (gfc_statement, bool strip_sentinel = false) ; diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc index 00d35a7..0bb440b 100644 --- a/gcc/fortran/primary.cc +++ b/gcc/fortran/primary.cc @@ -109,10 +109,10 @@ get_kind (int *is_iso_c) /* Given a character and a radix, see if the character is a valid digit in that radix. */ -int +bool gfc_check_digit (char c, int radix) { - int r; + bool r; switch (radix) { @@ -756,8 +756,8 @@ done: } /* Warn about trailing digits which suggest the user added too many - trailing digits, which may cause the appearance of higher pecision - than the kind kan support. + trailing digits, which may cause the appearance of higher precision + than the kind can support. This is done by replacing the rightmost non-zero digit with zero and comparing with the original value. If these are equal, we @@ -3060,7 +3060,7 @@ build_actual_constructor (gfc_structure_ctor_component **comp_head, return false; value = gfc_get_null_expr (&gfc_current_locus); } - /* ....(Preceeding sentence) If a component with default + /* ....(Preceding sentence) If a component with default initialization has no corresponding component-data-source, then the default initialization is applied to that component. */ else if (comp->initializer) @@ -3188,10 +3188,11 @@ gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **c goto cleanup; /* For a constant string constructor, make sure the length is - correct; truncate of fill with blanks if needed. */ + correct; truncate or fill with blanks if needed. */ if (this_comp->ts.type == BT_CHARACTER && !this_comp->attr.allocatable && this_comp->ts.u.cl && this_comp->ts.u.cl->length && this_comp->ts.u.cl->length->expr_type == EXPR_CONSTANT + && this_comp->ts.u.cl->length->ts.type == BT_INTEGER && actual->expr->ts.type == BT_CHARACTER && actual->expr->expr_type == EXPR_CONSTANT) { diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index f6ec76a..82e6ac5 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -702,7 +702,8 @@ resolve_entries (gfc_namespace *ns) gfc_code *c; gfc_symbol *proc; gfc_entry_list *el; - char name[GFC_MAX_SYMBOL_LEN + 1]; + /* Provide sufficient space to hold "master.%d.%s". */ + char name[GFC_MAX_SYMBOL_LEN + 1 + 18]; static int master_count = 0; if (ns->proc_name == NULL) @@ -827,6 +828,9 @@ resolve_entries (gfc_namespace *ns) "entries returning variables of different " "string lengths", ns->entries->sym->name, &ns->entries->sym->declared_at); + else if (el->sym->result->attr.allocatable + != ns->entries->sym->result->attr.allocatable) + break; } if (el == NULL) @@ -838,6 +842,8 @@ resolve_entries (gfc_namespace *ns) gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL); if (sym->attr.pointer) gfc_add_pointer (&proc->attr, NULL); + if (sym->attr.allocatable) + gfc_add_allocatable (&proc->attr, NULL); } else { @@ -869,6 +875,17 @@ resolve_entries (gfc_namespace *ns) "FUNCTION %s at %L", sym->name, ns->entries->sym->name, &sym->declared_at); } + else if (sym->attr.allocatable) + { + if (el == ns->entries) + gfc_error ("FUNCTION result %s cannot be ALLOCATABLE in " + "FUNCTION %s at %L", sym->name, + ns->entries->sym->name, &sym->declared_at); + else + gfc_error ("ENTRY result %s cannot be ALLOCATABLE in " + "FUNCTION %s at %L", sym->name, + ns->entries->sym->name, &sym->declared_at); + } else { ts = &sym->ts; @@ -1568,7 +1585,7 @@ resolve_structure_cons (gfc_expr *expr, int init) /* Returns 0 if a symbol was not declared with a type or attribute declaration statement, nonzero otherwise. */ -static int +static bool was_declared (gfc_symbol *sym) { symbol_attribute a; @@ -3074,13 +3091,13 @@ is_external_proc (gfc_symbol *sym) /* Figure out if a function reference is pure or not. Also set the name of the function for a potential error message. Return nonzero if the function is PURE, zero if not. */ -static int +static bool pure_stmt_function (gfc_expr *, gfc_symbol *); -int +bool gfc_pure_function (gfc_expr *e, const char **name) { - int pure; + bool pure; gfc_component *comp; *name = NULL; @@ -3120,7 +3137,7 @@ gfc_pure_function (gfc_expr *e, const char **name) /* Check if the expression is a reference to an implicitly pure function. */ -int +bool gfc_implicit_pure_function (gfc_expr *e) { gfc_component *comp = gfc_get_proc_ptr_comp (e); @@ -3151,7 +3168,7 @@ impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym, } -static int +static bool pure_stmt_function (gfc_expr *e, gfc_symbol *sym) { return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1; @@ -4183,6 +4200,17 @@ resolve_operator (gfc_expr *e) case INTRINSIC_POWER: if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts)) { + /* Do not perform conversions if operands are not conformable as + required for the binary intrinsic operators (F2018:10.1.5). + Defer to a possibly overloading user-defined operator. */ + if (!gfc_op_rank_conformable (op1, op2)) + { + dual_locus_error = true; + snprintf (msg, sizeof (msg), + _("Inconsistent ranks for operator at %%L and %%L")); + goto bad_op; + } + gfc_type_convert_binary (e, 1); break; } @@ -4355,6 +4383,17 @@ resolve_operator (gfc_expr *e) if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts)) { + /* Do not perform conversions if operands are not conformable as + required for the binary intrinsic operators (F2018:10.1.5). + Defer to a possibly overloading user-defined operator. */ + if (!gfc_op_rank_conformable (op1, op2)) + { + dual_locus_error = true; + snprintf (msg, sizeof (msg), + _("Inconsistent ranks for operator at %%L and %%L")); + goto bad_op; + } + gfc_type_convert_binary (e, 1); e->ts.type = BT_LOGICAL; @@ -5487,7 +5526,9 @@ gfc_resolve_ref (gfc_expr *expr) case REF_INQUIRY: /* Implement requirement in note 9.7 of F2018 that the result of the LEN inquiry be a scalar. */ - if (ref->u.i == INQUIRY_LEN && array_ref && expr->ts.deferred) + 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; @@ -5627,6 +5668,21 @@ done: } +/* Given two expressions, check that their rank is conformable, i.e. either + both have the same rank or at least one is a scalar. */ + +bool +gfc_op_rank_conformable (gfc_expr *op1, gfc_expr *op2) +{ + if (op1->expr_type == EXPR_VARIABLE) + gfc_expression_rank (op1); + if (op2->expr_type == EXPR_VARIABLE) + gfc_expression_rank (op2); + + return (op1->rank == 0 || op2->rank == 0 || op1->rank == op2->rank); +} + + static void add_caf_get_intrinsic (gfc_expr *e) { @@ -5816,7 +5872,15 @@ resolve_variable (gfc_expr *e) if (sym->ts.type == BT_CLASS) gfc_fix_class_refs (e); if (!sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY) - return false; + { + /* Unambiguously scalar! */ + if (sym->assoc->target + && (sym->assoc->target->expr_type == EXPR_CONSTANT + || sym->assoc->target->expr_type == EXPR_STRUCTURE)) + gfc_error ("Scalar variable %qs has an array reference at %L", + sym->name, &e->where); + return false; + } else if (sym->attr.dimension && (!e->ref || e->ref->type != REF_ARRAY)) { /* This can happen because the parser did not detect that the @@ -5866,7 +5930,7 @@ resolve_variable (gfc_expr *e) /* Because this is an associate var and the first ref either is a ref to the _data component or not, no traversal of the ref chain is needed. The array ref needs to be inserted after the _data ref, - or when that is not present, which may happend for polymorphic + or when that is not present, which may happened for polymorphic types, then at the first position. */ ref = e->ref; if (!ref) @@ -6085,7 +6149,7 @@ resolve_procedure: the symbol in the expression and convert the array reference into an actual arglist if the old symbol is a variable; or (ii) That in which an external function is typed but not declared - explcitly to be external. Here, the old symbol is changed + explicitly to be external. Here, the old symbol is changed from a variable to an external function. */ static bool check_host_association (gfc_expr *e) @@ -7576,7 +7640,7 @@ resolve_forall_iterators (gfc_forall_iterator *it) PRIVATE. The search is recursive if necessary. Returns zero if no inaccessible components are found, nonzero otherwise. */ -static int +static bool derived_inaccessible (gfc_symbol *sym) { gfc_component *c; @@ -8072,6 +8136,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec) if (!t) goto failure; + code->ext.alloc.expr3_not_explicit = 0; if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension && !code->expr3 && code->ext.alloc.ts.type == BT_DERIVED) { @@ -8080,6 +8145,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec) when the allocated type is different from the declared type but no SOURCE exists by setting expr3. */ code->expr3 = gfc_default_initializer (&code->ext.alloc.ts); + code->ext.alloc.expr3_not_explicit = 1; } else if (flag_coarray != GFC_FCOARRAY_LIB && e->ts.type == BT_DERIVED && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV @@ -8087,6 +8153,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec) { /* We have to zero initialize the integer variable. */ code->expr3 = gfc_get_int_expr (gfc_default_integer_kind, &e->where, 0); + code->ext.alloc.expr3_not_explicit = 1; } if (e->ts.type == BT_CLASS && !unlimited && !UNLIMITED_POLY (code->expr3)) @@ -9084,6 +9151,7 @@ static void resolve_assoc_var (gfc_symbol* sym, bool resolve_target) { gfc_expr* target; + bool parentheses = false; gcc_assert (sym->assoc); gcc_assert (sym->attr.flavor == FL_VARIABLE); @@ -9096,6 +9164,16 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) return; gcc_assert (!sym->assoc->dangling); + if (target->expr_type == EXPR_OP + && target->value.op.op == INTRINSIC_PARENTHESES + && target->value.op.op1->expr_type == EXPR_VARIABLE) + { + sym->assoc->target = gfc_copy_expr (target->value.op.op1); + gfc_free_expr (target); + target = sym->assoc->target; + parentheses = true; + } + if (resolve_target && !gfc_resolve_expr (target)) return; @@ -9176,8 +9254,10 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) gcc_assert (sym->ts.type != BT_UNKNOWN); /* See if this is a valid association-to-variable. */ - sym->assoc->variable = (target->expr_type == EXPR_VARIABLE - && !gfc_has_vector_subscript (target)); + sym->assoc->variable = ((target->expr_type == EXPR_VARIABLE + && !parentheses + && !gfc_has_vector_subscript (target)) + || gfc_is_ptr_fcn (target)); /* Finally resolve if this is an array or not. */ if (sym->attr.dimension && target->rank == 0) @@ -9191,7 +9271,6 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) return; } - /* We cannot deal with class selectors that need temporaries. */ if (target->ts.type == BT_CLASS && gfc_ref_needs_temporary_p (target->ref)) @@ -9209,7 +9288,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) gfc_array_spec *as; /* The rank may be incorrectly guessed at parsing, therefore make sure it is corrected now. */ - if (sym->ts.type != BT_CLASS && (!sym->as || sym->assoc->rankguessed)) + if (sym->ts.type != BT_CLASS && !sym->as) { if (!sym->as) sym->as = gfc_get_array_spec (); @@ -9222,8 +9301,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) sym->attr.codimension = 1; } else if (sym->ts.type == BT_CLASS - && CLASS_DATA (sym) - && (!CLASS_DATA (sym)->as || sym->assoc->rankguessed)) + && CLASS_DATA (sym) && !CLASS_DATA (sym)->as) { if (!CLASS_DATA (sym)->as) CLASS_DATA (sym)->as = gfc_get_array_spec (); @@ -9863,8 +9941,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) gfc_resolve_blocks (code->block, gfc_current_ns); gfc_current_ns = old_ns; - if (ref) - free (ref); + free (ref); } @@ -9951,11 +10028,6 @@ resolve_select_rank (gfc_code *code, gfc_namespace *old_ns) || gfc_expr_attr (code->expr1).pointer)) gfc_error ("RANK (*) at %L cannot be used with the pointer or " "allocatable selector at %L", &c->where, &code->expr1->where); - - if (case_value == -1 && (gfc_expr_attr (code->expr1).allocatable - || gfc_expr_attr (code->expr1).pointer)) - gfc_error ("RANK (*) at %L cannot be used with the pointer or " - "allocatable selector at %L", &c->where, &code->expr1->where); } /* Add EXEC_SELECT to switch on rank. */ @@ -10885,11 +10957,6 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) /* Resolve a BLOCK construct statement. */ -static gfc_expr* -get_temp_from_expr (gfc_expr *, gfc_namespace *); -static gfc_code * -build_assignment (gfc_exec_op, gfc_expr *, gfc_expr *, - gfc_component *, gfc_component *, locus); static void resolve_block_construct (gfc_code* code) @@ -10980,6 +11047,8 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns) case EXEC_OACC_ENTER_DATA: case EXEC_OACC_EXIT_DATA: case EXEC_OACC_ROUTINE: + case EXEC_OMP_ALLOCATE: + case EXEC_OMP_ALLOCATORS: case EXEC_OMP_ASSUME: case EXEC_OMP_CRITICAL: case EXEC_OMP_DISTRIBUTE: @@ -11103,12 +11172,23 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) lhs = code->expr1; rhs = code->expr2; + if ((lhs->symtree->n.sym->ts.type == BT_DERIVED + || lhs->symtree->n.sym->ts.type == BT_CLASS) + && !lhs->symtree->n.sym->attr.proc_pointer + && gfc_expr_attr (lhs).proc_pointer) + { + gfc_error ("Variable in the ordinary assignment at %L is a procedure " + "pointer component", + &lhs->where); + return false; + } + if ((gfc_numeric_ts (&lhs->ts) || lhs->ts.type == BT_LOGICAL) && rhs->ts.type == BT_CHARACTER && (rhs->expr_type != EXPR_CONSTANT || !flag_dec_char_conversions)) { /* Use of -fdec-char-conversions allows assignment of character data - to non-character variables. This not permited for nonconstant + to non-character variables. This not permitted for nonconstant strings. */ gfc_error ("Cannot convert %s to %s at %L", gfc_typename (rhs), gfc_typename (lhs), &rhs->where); @@ -12637,6 +12717,8 @@ start: gfc_resolve_oacc_directive (code, ns); break; + case EXEC_OMP_ALLOCATE: + case EXEC_OMP_ALLOCATORS: case EXEC_OMP_ASSUME: case EXEC_OMP_ATOMIC: case EXEC_OMP_BARRIER: @@ -13183,7 +13265,10 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) if (allocatable) { - if (dimension && as->type != AS_ASSUMED_RANK) + if (dimension + && as + && as->type != AS_ASSUMED_RANK + && !sym->attr.select_rank_temporary) { gfc_error ("Allocatable array %qs at %L must have a deferred " "shape or assumed rank", sym->name, &sym->declared_at); @@ -15114,7 +15199,7 @@ resolve_component (gfc_component *c, gfc_symbol *sym) /* Check type-spec if this is not the parent-type component. */ if (((sym->attr.is_class && (!sym->components->ts.u.derived->attr.extension - || c != sym->components->ts.u.derived->components)) + || c != CLASS_DATA (sym->components))) || (!sym->attr.is_class && (!sym->attr.extension || c != sym->components))) && !sym->attr.vtype @@ -15127,7 +15212,7 @@ resolve_component (gfc_component *c, gfc_symbol *sym) component. */ if (super_type && ((sym->attr.is_class - && c == sym->components->ts.u.derived->components) + && c == CLASS_DATA (sym->components)) || (!sym->attr.is_class && c == sym->components)) && strcmp (super_type->name, c->name) == 0) c->attr.access = super_type->attr.access; @@ -15373,7 +15458,7 @@ resolve_fl_derived0 (gfc_symbol *sym) return false; } - c = (sym->attr.is_class) ? sym->components->ts.u.derived->components + c = (sym->attr.is_class) ? CLASS_DATA (sym->components) : sym->components; success = true; @@ -16012,7 +16097,8 @@ resolve_symbol (gfc_symbol *sym) if (((as->type == AS_ASSUMED_SIZE && !as->cp_was_assumed) || as->type == AS_ASSUMED_SHAPE) - && !sym->attr.dummy && !sym->attr.select_type_temporary) + && !sym->attr.dummy && !sym->attr.select_type_temporary + && !sym->attr.associate_var) { if (as->type == AS_ASSUMED_SIZE) gfc_error ("Assumed size array at %L must be a dummy argument", @@ -17064,7 +17150,7 @@ resolve_data (gfc_data *d) /* Determines if a variable is not 'pure', i.e., not assignable within a pure procedure. Returns zero if assignment is OK, nonzero if there is a problem. */ -int +bool gfc_impure_variable (gfc_symbol *sym) { gfc_symbol *proc; @@ -17099,7 +17185,7 @@ gfc_impure_variable (gfc_symbol *sym) /* Test whether a symbol is pure or not. For a NULL pointer, checks if the current namespace is inside a pure procedure. */ -int +bool gfc_pure (gfc_symbol *sym) { symbol_attribute attr; @@ -17131,7 +17217,7 @@ gfc_pure (gfc_symbol *sym) checks if the current namespace is implicitly pure. Note that this function returns false for a PURE procedure. */ -int +bool gfc_implicit_pure (gfc_symbol *sym) { gfc_namespace *ns; @@ -17185,7 +17271,7 @@ gfc_unset_implicit_pure (gfc_symbol *sym) /* Test whether the current procedure is elemental or not. */ -int +bool gfc_elemental (gfc_symbol *sym) { symbol_attribute attr; @@ -17932,6 +18018,8 @@ resolve_codes (gfc_namespace *ns) gfc_resolve_oacc_declare (ns); gfc_resolve_oacc_routines (ns); gfc_resolve_omp_local_vars (ns); + if (ns->omp_allocate) + gfc_resolve_omp_allocate (ns, ns->omp_allocate); gfc_resolve_code (ns->code, ns); bitmap_obstack_release (&labels_obstack); diff --git a/gcc/fortran/scanner.cc b/gcc/fortran/scanner.cc index 4f45da446..9f0d9a7 100644 --- a/gcc/fortran/scanner.cc +++ b/gcc/fortran/scanner.cc @@ -56,7 +56,7 @@ gfc_directorylist *include_dirs, *intrinsic_modules_dirs; static gfc_file *file_head, *current_file; -static int continue_flag, end_flag, gcc_attribute_flag; +static bool continue_flag, end_flag, gcc_attribute_flag; /* If !$omp/!$acc occurred in current comment line. */ static int openmp_flag, openacc_flag; static int continue_count, continue_line; @@ -86,7 +86,7 @@ static gfc_char_t *last_error_char; /* Functions dealing with our wide characters (gfc_char_t) and sequences of such characters. */ -int +bool gfc_wide_fits_in_byte (gfc_char_t c) { return (c <= UCHAR_MAX); @@ -98,7 +98,7 @@ wide_is_ascii (gfc_char_t c) return (gfc_wide_fits_in_byte (c) && ((unsigned char) c & ~0x7f) == 0); } -int +bool gfc_wide_is_printable (gfc_char_t c) { return (gfc_wide_fits_in_byte (c) && ISPRINT ((unsigned char) c)); @@ -116,7 +116,7 @@ gfc_wide_toupper (gfc_char_t c) return (wide_is_ascii (c) ? (gfc_char_t) TOUPPER((unsigned char) c) : c); } -int +bool gfc_wide_is_digit (gfc_char_t c) { return (c >= '0' && c <= '9'); @@ -518,7 +518,7 @@ gfc_open_included_file (const char *name, bool include_cwd, bool module) /* Test to see if we're at the end of the main source file. */ -int +bool gfc_at_end (void) { return end_flag; @@ -527,7 +527,7 @@ gfc_at_end (void) /* Test to see if we're at the end of the current file. */ -int +bool gfc_at_eof (void) { if (gfc_at_end ()) @@ -545,7 +545,7 @@ gfc_at_eof (void) /* Test to see if we're at the beginning of a new line. */ -int +bool gfc_at_bol (void) { if (gfc_at_eof ()) @@ -557,7 +557,7 @@ gfc_at_bol (void) /* Test to see if we're at the end of a line. */ -int +bool gfc_at_eol (void) { if (gfc_at_eof ()) @@ -702,7 +702,7 @@ skip_comment_line (void) } -int +bool gfc_define_undef_line (void) { char *tmp; @@ -1803,7 +1803,7 @@ gfc_gobble_whitespace (void) easily report line and column numbers consistent with other parts of gfortran. */ -static int +static bool load_line (FILE *input, gfc_char_t **pbuf, int *pbuflen, const int *first_char) { int c, maxlen, i, preprocessor_flag, buflen = *pbuflen; diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc index ecf0e35..8168011 100644 --- a/gcc/fortran/simplify.cc +++ b/gcc/fortran/simplify.cc @@ -254,12 +254,19 @@ is_constant_array_expr (gfc_expr *e) break; } - /* Check and expand the constructor. */ - if (!array_OK && gfc_init_expr_flag && e->rank == 1) + /* Check and expand the constructor. We do this when either + gfc_init_expr_flag is set or for not too large array constructors. */ + bool expand; + expand = (e->rank == 1 + && e->shape + && (mpz_cmp_ui (e->shape[0], flag_max_array_constructor) < 0)); + + if (!array_OK && (gfc_init_expr_flag || expand) && e->rank == 1) { + bool saved_init_expr_flag = gfc_init_expr_flag; array_OK = gfc_reduce_init_expr (e); /* gfc_reduce_init_expr resets the flag. */ - gfc_init_expr_flag = true; + gfc_init_expr_flag = saved_init_expr_flag; } else return array_OK; @@ -284,6 +291,13 @@ is_constant_array_expr (gfc_expr *e) return array_OK; } +bool +gfc_is_constant_array_expr (gfc_expr *e) +{ + return is_constant_array_expr (e); +} + + /* Test for a size zero array. */ bool gfc_is_size_zero_array (gfc_expr *array) @@ -3116,28 +3130,28 @@ gfc_simplify_extends_type_of (gfc_expr *a, gfc_expr *mold) /* Return .false. if the dynamic type can never be an extension. */ if ((a->ts.type == BT_CLASS && mold->ts.type == BT_CLASS && !gfc_type_is_extension_of - (mold->ts.u.derived->components->ts.u.derived, - a->ts.u.derived->components->ts.u.derived) + (CLASS_DATA (mold)->ts.u.derived, + CLASS_DATA (a)->ts.u.derived) && !gfc_type_is_extension_of - (a->ts.u.derived->components->ts.u.derived, - mold->ts.u.derived->components->ts.u.derived)) + (CLASS_DATA (a)->ts.u.derived, + CLASS_DATA (mold)->ts.u.derived)) || (a->ts.type == BT_DERIVED && mold->ts.type == BT_CLASS && !gfc_type_is_extension_of - (mold->ts.u.derived->components->ts.u.derived, + (CLASS_DATA (mold)->ts.u.derived, a->ts.u.derived)) || (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED && !gfc_type_is_extension_of (mold->ts.u.derived, - a->ts.u.derived->components->ts.u.derived) + CLASS_DATA (a)->ts.u.derived) && !gfc_type_is_extension_of - (a->ts.u.derived->components->ts.u.derived, + (CLASS_DATA (a)->ts.u.derived, mold->ts.u.derived))) return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false); /* Return .true. if the dynamic type is guaranteed to be an extension. */ if (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED && gfc_type_is_extension_of (mold->ts.u.derived, - a->ts.u.derived->components->ts.u.derived)) + CLASS_DATA (a)->ts.u.derived)) return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, true); return NULL; @@ -4130,11 +4144,11 @@ simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper, /* For {L,U}BOUND, the value depends on whether the array is empty. We can nevertheless simplify if the declared bound has the same value as that of an empty array, in which case - the result isn't dependent on the array emptyness. */ + the result isn't dependent on the array emptiness. */ if (mpz_cmp_si (declared_bound->value.integer, empty_bound) == 0) mpz_set_si (result->value.integer, empty_bound); else if (!constant_lbound || !constant_ubound) - /* Array emptyness can't be determined, we can't simplify. */ + /* Array emptiness can't be determined, we can't simplify. */ goto returnNull; else if (mpz_cmp (l->value.integer, u->value.integer) > 0) mpz_set_si (result->value.integer, empty_bound); @@ -4344,8 +4358,8 @@ simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper) return NULL; /* Follow any component references. */ - as = (array->ts.type == BT_CLASS && array->ts.u.derived->components) - ? array->ts.u.derived->components->as + as = (array->ts.type == BT_CLASS && CLASS_DATA (array)) + ? CLASS_DATA (array)->as : array->symtree->n.sym->as; for (ref = array->ref; ref; ref = ref->next) { @@ -6866,6 +6880,7 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, gfc_error ("The SHAPE array for the RESHAPE intrinsic at %L has a " "negative value %d for dimension %d", &shape_exp->where, shape[rank], rank+1); + mpz_clear (index); return &gfc_bad_expr; } @@ -6889,6 +6904,7 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, { gfc_error ("Shapes of ORDER at %L and SHAPE at %L are different", &order_exp->where, &shape_exp->where); + mpz_clear (index); return &gfc_bad_expr; } @@ -6902,6 +6918,7 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, { gfc_error ("Sizes of ORDER at %L and SHAPE at %L are different", &order_exp->where, &shape_exp->where); + mpz_clear (index); return &gfc_bad_expr; } @@ -6918,6 +6935,7 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, "in the range [1, ..., %d] for the RESHAPE intrinsic " "near %L", order[i], &order_exp->where, rank, &shape_exp->where); + mpz_clear (index); return &gfc_bad_expr; } @@ -6926,6 +6944,7 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, { gfc_error ("ORDER at %L is not a permutation of the size of " "SHAPE at %L", &order_exp->where, &shape_exp->where); + mpz_clear (index); return &gfc_bad_expr; } x[order[i]] = 1; @@ -6996,6 +7015,11 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp, if (npad <= 0) { mpz_clear (index); + if (pad == NULL) + gfc_error ("Without padding, there are not enough elements " + "in the intrinsic RESHAPE source at %L to match " + "the shape", &source->where); + gfc_free_expr (result); return NULL; } j = j - nsource; @@ -7364,7 +7388,7 @@ gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i) { gfc_expr *result; mpfr_t exp, absv, log2, pow2, frac; - unsigned long exp2; + long exp2; if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT) return NULL; @@ -7396,19 +7420,19 @@ gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i) mpfr_abs (absv, x->value.real, GFC_RND_MODE); mpfr_log2 (log2, absv, GFC_RND_MODE); - mpfr_trunc (log2, log2); + mpfr_floor (log2, log2); mpfr_add_ui (exp, log2, 1, GFC_RND_MODE); /* Old exponent value, and fraction. */ mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE); - mpfr_div (frac, absv, pow2, GFC_RND_MODE); + mpfr_div (frac, x->value.real, pow2, GFC_RND_MODE); /* New exponent. */ - exp2 = (unsigned long) mpz_get_d (i->value.integer); - mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE); + exp2 = mpz_get_si (i->value.integer); + mpfr_mul_2si (result->value.real, frac, exp2, GFC_RND_MODE); - mpfr_clears (absv, log2, pow2, frac, NULL); + mpfr_clears (absv, log2, exp, pow2, frac, NULL); return range_check (result, "SET_EXPONENT"); } @@ -7570,7 +7594,17 @@ simplify_size (gfc_expr *array, gfc_expr *dim, int k) if (dim->expr_type != EXPR_CONSTANT) return NULL; - d = mpz_get_ui (dim->value.integer) - 1; + if (array->rank == -1) + return NULL; + + d = mpz_get_si (dim->value.integer) - 1; + if (d < 0 || d > array->rank - 1) + { + gfc_error ("DIM argument (%d) to intrinsic SIZE at %L out of range " + "(1:%d)", d+1, &array->where, array->rank); + return &gfc_bad_expr; + } + if (!gfc_array_dimen_size (array, d, &size)) return NULL; } diff --git a/gcc/fortran/st.cc b/gcc/fortran/st.cc index 657bc9d..55debca 100644 --- a/gcc/fortran/st.cc +++ b/gcc/fortran/st.cc @@ -214,6 +214,8 @@ gfc_free_statement (gfc_code *p) case EXEC_OACC_ENTER_DATA: case EXEC_OACC_EXIT_DATA: case EXEC_OACC_ROUTINE: + case EXEC_OMP_ALLOCATE: + case EXEC_OMP_ALLOCATORS: case EXEC_OMP_ASSUME: case EXEC_OMP_ATOMIC: case EXEC_OMP_CANCEL: diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc index 221165d..37a9e8f 100644 --- a/gcc/fortran/symbol.cc +++ b/gcc/fortran/symbol.cc @@ -3214,9 +3214,9 @@ gfc_find_symtree_in_proc (const char* name, gfc_namespace* ns) /* Search for a symtree starting in the current namespace, resorting to any parent namespaces if requested by a nonzero parent_flag. - Returns nonzero if the name is ambiguous. */ + Returns true if the name is ambiguous. */ -int +bool gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag, gfc_symtree **result) { @@ -3238,10 +3238,10 @@ gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag, if (st->ambiguous && !st->n.sym->attr.generic) { ambiguous_symbol (name, st); - return 1; + return true; } - return 0; + return false; } if (!parent_flag) @@ -3270,12 +3270,12 @@ gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag, } } *result = st; - return 0; + return false; } *result = NULL; - return 0; + return false; } diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 41661b4..e7c51ba 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -880,7 +880,7 @@ is_pointer_array (tree expr) || GFC_CLASS_TYPE_P (TREE_TYPE (expr))) return false; - if (TREE_CODE (expr) == VAR_DECL + if (VAR_P (expr) && GFC_DECL_PTR_ARRAY_P (expr)) return true; @@ -888,7 +888,7 @@ is_pointer_array (tree expr) && GFC_DECL_PTR_ARRAY_P (expr)) return true; - if (TREE_CODE (expr) == INDIRECT_REF + if (INDIRECT_REF_P (expr) && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 0))) return true; @@ -1117,7 +1117,7 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post, desc = info->descriptor; info->offset = gfc_index_zero_node; - if (size == NULL_TREE || integer_zerop (size)) + if (size == NULL_TREE || (dynamic && integer_zerop (size))) { /* A callee allocated array. */ gfc_conv_descriptor_data_set (pre, desc, null_pointer_node); @@ -3803,7 +3803,7 @@ gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar, { if (TREE_CODE (info->descriptor) == COMPONENT_REF) decl = info->descriptor; - else if (TREE_CODE (info->descriptor) == INDIRECT_REF) + else if (INDIRECT_REF_P (info->descriptor)) decl = TREE_OPERAND (info->descriptor, 0); if (decl == NULL_TREE) @@ -4057,7 +4057,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr, { if (TREE_CODE (se->expr) == COMPONENT_REF) decl = se->expr; - else if (TREE_CODE (se->expr) == INDIRECT_REF) + else if (INDIRECT_REF_P (se->expr)) decl = TREE_OPERAND (se->expr, 0); else decl = se->expr; @@ -4069,7 +4069,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr, if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr))) { decl = se->expr; - if (TREE_CODE (decl) == INDIRECT_REF) + if (INDIRECT_REF_P (decl)) decl = TREE_OPERAND (decl, 0); } else @@ -4982,7 +4982,7 @@ done: /* Return true if both symbols could refer to the same data object. Does not take account of aliasing due to equivalence statements. */ -static int +static bool symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer, bool lsym_target, bool rsym_pointer, bool rsym_target) { @@ -7568,6 +7568,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) int full; bool subref_array_target = false; bool deferred_array_component = false; + bool substr = false; gfc_expr *arg, *ss_expr; if (se->want_coarray) @@ -7618,6 +7619,9 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) && TREE_CODE (desc) == COMPONENT_REF) deferred_array_component = true; + substr = info->ref && info->ref->next + && info->ref->next->type == REF_SUBSTRING; + subref_array_target = (is_subref_array (expr) && (se->direct_byref || expr->ts.type == BT_CHARACTER)); @@ -7659,7 +7663,10 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) subref_array_target, expr); /* ....and set the span field. */ - tmp = gfc_conv_descriptor_span_get (desc); + if (ss_info->expr->ts.type == BT_CHARACTER) + tmp = gfc_conv_descriptor_span_get (desc); + else + tmp = gfc_get_array_span (desc, expr); gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp); } else if (se->want_pointer) @@ -7730,6 +7737,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) need_tmp = 1; if (expr->ts.type == BT_CHARACTER + && expr->ts.u.cl->length && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT) get_array_charlen (expr, se); @@ -7915,7 +7923,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) /* Set the string_length for a character array. */ if (expr->ts.type == BT_CHARACTER) { - if (deferred_array_component) + if (deferred_array_component && !substr) se->string_length = ss_info->string_length; else se->string_length = gfc_get_expr_charlen (expr); @@ -7926,7 +7934,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) else tmp = se->string_length; - if (expr->ts.deferred && VAR_P (expr->ts.u.cl->backend_decl)) + if (expr->ts.deferred && expr->ts.u.cl->backend_decl + && VAR_P (expr->ts.u.cl->backend_decl)) gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, tmp); else expr->ts.u.cl->backend_decl = tmp; @@ -7991,8 +8000,21 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) } } + if (expr->ts.type == BT_CHARACTER + && VAR_P (TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (parm))))) + { + tree elem_len = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (parm))); + gfc_add_modify (&loop.pre, elem_len, + fold_convert (TREE_TYPE (elem_len), + gfc_get_array_span (desc, expr))); + } + /* Set the span field. */ - tmp = gfc_get_array_span (desc, expr); + tmp = NULL_TREE; + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) + tmp = gfc_conv_descriptor_span_get (desc); + else + tmp = gfc_get_array_span (desc, expr); if (tmp) gfc_conv_descriptor_span_set (&loop.pre, parm, tmp); @@ -8576,7 +8598,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77, "Creating array temporary at %L", &expr->where); } - /* When optmizing, we can use gfc_conv_subref_array_arg for + /* When optimizing, we can use gfc_conv_subref_array_arg for making the packing and unpacking operation visible to the optimizers. */ @@ -8766,6 +8788,7 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank, tree add_when_allocated) { tree tmp; + tree eltype; tree size; tree nelems; tree null_cond; @@ -8782,10 +8805,11 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank, null_data = gfc_finish_block (&block); gfc_init_block (&block); + eltype = TREE_TYPE (type); if (str_sz != NULL_TREE) size = str_sz; else - size = TYPE_SIZE_UNIT (TREE_TYPE (type)); + size = TYPE_SIZE_UNIT (eltype); if (!no_malloc) { @@ -8812,11 +8836,19 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank, else nelems = gfc_index_one_node; + /* If type is not the array type, then it is the element type. */ + if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type)) + eltype = gfc_get_element_type (type); + else + eltype = type; + if (str_sz != NULL_TREE) tmp = fold_convert (gfc_array_index_type, str_sz); else tmp = fold_convert (gfc_array_index_type, - TYPE_SIZE_UNIT (gfc_get_element_type (type))); + TYPE_SIZE_UNIT (eltype)); + + tmp = gfc_evaluate_now (tmp, &block); size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, nelems, tmp); if (!no_malloc) @@ -9865,6 +9897,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, /* This component cannot have allocatable components, therefore add_when_allocated of duplicate_allocatable () is always NULL. */ + rank = c->as ? c->as->rank : 0; tmp = duplicate_allocatable (dcmp, comp, ctype, rank, false, false, size, NULL_TREE); gfc_add_expr_to_block (&fnblock, tmp); @@ -11170,7 +11203,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, } -/* Initialize class descriptor's TKR infomation. */ +/* Initialize class descriptor's TKR information. */ void gfc_trans_class_array (gfc_symbol * sym, gfc_wrapped_block * block) @@ -11448,6 +11481,12 @@ gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref) break; case AR_FULL: + /* Assumed shape arrays from interface mapping need this fix. */ + if (!ar->as && expr->symtree->n.sym->as) + { + ar->as = gfc_get_array_spec(); + *ar->as = *expr->symtree->n.sym->as; + } newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION); newss->info->data.array.ref = ref; diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index 2573788..18589e1 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -483,7 +483,7 @@ gfc_set_decl_assembler_name (tree decl, tree name) /* Returns true if a variable of specified size should go on the stack. */ -int +bool gfc_can_put_var_on_stack (tree size) { unsigned HOST_WIDE_INT low; @@ -558,7 +558,7 @@ gfc_finish_decl (tree decl) return; if (DECL_SIZE (decl) == NULL_TREE - && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE) + && COMPLETE_TYPE_P (TREE_TYPE (decl))) layout_decl (decl, 0); /* A few consistency checks. */ @@ -1791,6 +1791,9 @@ gfc_get_symbol_decl (gfc_symbol * sym) return decl; } + if (sym->ts.type == BT_UNKNOWN) + gfc_fatal_error ("%s at %C has no default type", sym->name); + if (sym->attr.intrinsic) gfc_internal_error ("intrinsic variable which isn't a procedure"); @@ -1824,6 +1827,8 @@ gfc_get_symbol_decl (gfc_symbol * sym) /* Add attributes to variables. Functions are handled elsewhere. */ attributes = add_attributes_to_decl (sym->attr, NULL_TREE); decl_attributes (&decl, attributes, 0); + if (sym->ts.deferred && VAR_P (length)) + decl_attributes (&length, attributes, 0); /* Symbols from modules should have their assembler names mangled. This is done here rather than in gfc_finish_var_decl because it @@ -1870,6 +1875,15 @@ gfc_get_symbol_decl (gfc_symbol * sym) && !(sym->attr.use_assoc && !intrinsic_array_parameter))) gfc_defer_symbol_init (sym); + /* Set the vptr of unlimited polymorphic pointer variables so that + they do not cause segfaults in select type, when the selector + is an intrinsic type. Arrays are captured above. */ + if (sym->ts.type == BT_CLASS && UNLIMITED_POLY (sym) + && CLASS_DATA (sym)->attr.class_pointer + && !CLASS_DATA (sym)->attr.dimension && !sym->attr.dummy + && sym->attr.flavor == FL_VARIABLE && !sym->assoc) + gfc_defer_symbol_init (sym); + if (sym->ts.type == BT_CHARACTER && sym->attr.allocatable && !sym->attr.dimension @@ -1886,7 +1900,7 @@ gfc_get_symbol_decl (gfc_symbol * sym) length = fold_convert (gfc_charlen_type_node, length); gfc_finish_var_decl (length, sym); if (!sym->attr.associate_var - && TREE_CODE (length) == VAR_DECL + && VAR_P (length) && sym->value && sym->value->expr_type != EXPR_NULL && sym->value->ts.u.cl->length) { @@ -1901,6 +1915,7 @@ gfc_get_symbol_decl (gfc_symbol * sym) gcc_assert (!sym->value || sym->value->expr_type == EXPR_NULL); } + gfc_finish_var_decl (decl, sym); if (sym->ts.type == BT_CHARACTER) @@ -4647,6 +4662,29 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) if (sym->assoc) continue; + /* Set the vptr of unlimited polymorphic pointer variables so that + they do not cause segfaults in select type, when the selector + is an intrinsic type. */ + if (sym->ts.type == BT_CLASS && UNLIMITED_POLY (sym) + && sym->attr.flavor == FL_VARIABLE && !sym->assoc + && !sym->attr.dummy && CLASS_DATA (sym)->attr.class_pointer) + { + gfc_symbol *vtab; + gfc_init_block (&tmpblock); + vtab = gfc_find_vtab (&sym->ts); + if (!vtab->backend_decl) + { + if (!vtab->attr.referenced) + gfc_set_sym_referenced (vtab); + gfc_get_symbol_decl (vtab); + } + tmp = gfc_class_vptr_get (sym->backend_decl); + gfc_add_modify (&tmpblock, tmp, + gfc_build_addr_expr (TREE_TYPE (tmp), + vtab->backend_decl)); + gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL); + } + if (sym->ts.type == BT_DERIVED && sym->ts.u.derived && sym->ts.u.derived->attr.pdt_type) @@ -7538,6 +7576,7 @@ gfc_generate_function_code (gfc_namespace * ns) } trans_function_start (sym); + gfc_current_locus = sym->declared_at; gfc_init_block (&init); gfc_init_block (&cleanup); @@ -7617,7 +7656,7 @@ gfc_generate_function_code (gfc_namespace * ns) desc = desc_p; else if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (desc_p)))) { - /* Character(len=*) explict-size/assumed-size array. */ + /* Character(len=*) explicit-size/assumed-size array. */ desc = desc_p; gfc_build_qualified_array (desc, fsym); } diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index d996d29..3c209bc 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -996,6 +996,12 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e, tree var; tree tmp; int dim; + bool unlimited_poly; + + unlimited_poly = class_ts.type == BT_CLASS + && class_ts.u.derived->components->ts.type == BT_DERIVED + && class_ts.u.derived->components->ts.u.derived + ->attr.unlimited_polymorphic; /* The intrinsic type needs to be converted to a temporary CLASS object. */ @@ -1067,9 +1073,7 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e, } gcc_assert (class_ts.type == BT_CLASS); - if (class_ts.u.derived->components->ts.type == BT_DERIVED - && class_ts.u.derived->components->ts.u.derived - ->attr.unlimited_polymorphic) + if (unlimited_poly) { ctree = gfc_class_len_get (var); /* When the actual arg is a char array, then set the _len component of the @@ -1116,10 +1120,7 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e, gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp)); } - else if (class_ts.type == BT_CLASS - && class_ts.u.derived->components - && class_ts.u.derived->components->ts.u - .derived->attr.unlimited_polymorphic) + else if (unlimited_poly) { ctree = gfc_class_len_get (var); gfc_add_modify (&parmse->pre, ctree, @@ -2124,6 +2125,7 @@ gfc_get_expr_charlen (gfc_expr *e) { gfc_ref *r; tree length; + tree previous = NULL_TREE; gfc_se se; gcc_assert (e->expr_type == EXPR_VARIABLE @@ -2149,6 +2151,7 @@ gfc_get_expr_charlen (gfc_expr *e) /* Look through the reference chain for component references. */ for (r = e->ref; r; r = r->next) { + previous = length; switch (r->type) { case REF_COMPONENT: @@ -2164,7 +2167,10 @@ gfc_get_expr_charlen (gfc_expr *e) gfc_init_se (&se, NULL); gfc_conv_expr_type (&se, r->u.ss.start, gfc_charlen_type_node); length = se.expr; - gfc_conv_expr_type (&se, r->u.ss.end, gfc_charlen_type_node); + if (r->u.ss.end) + gfc_conv_expr_type (&se, r->u.ss.end, gfc_charlen_type_node); + else + se.expr = previous; length = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node, se.expr, length); @@ -2554,23 +2560,25 @@ gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock) expr_flat = gfc_copy_expr (expr); flatten_array_ctors_without_strlen (expr_flat); gfc_resolve_expr (expr_flat); - - gfc_conv_expr (&se, expr_flat); - gfc_add_block_to_block (pblock, &se.pre); - cl->backend_decl = convert (gfc_charlen_type_node, se.string_length); - + if (expr_flat->rank) + gfc_conv_expr_descriptor (&se, expr_flat); + else + gfc_conv_expr (&se, expr_flat); + if (expr_flat->expr_type != EXPR_VARIABLE) + gfc_add_block_to_block (pblock, &se.pre); + se.expr = convert (gfc_charlen_type_node, se.string_length); + gfc_add_block_to_block (pblock, &se.post); gfc_free_expr (expr_flat); - return; } - - /* Convert cl->length. */ - - gcc_assert (cl->length); - - gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node); - se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node, - se.expr, build_zero_cst (TREE_TYPE (se.expr))); - gfc_add_block_to_block (pblock, &se.pre); + else + { + /* Convert cl->length. */ + gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node); + se.expr = fold_build2_loc (input_location, MAX_EXPR, + gfc_charlen_type_node, se.expr, + build_zero_cst (TREE_TYPE (se.expr))); + gfc_add_block_to_block (pblock, &se.pre); + } if (cl->backend_decl && VAR_P (cl->backend_decl)) gfc_add_modify (pblock, cl->backend_decl, se.expr); @@ -2854,11 +2862,13 @@ conv_inquiry (gfc_se * se, gfc_ref * ref, gfc_expr *expr, gfc_typespec *ts) case INQUIRY_KIND: res = build_int_cst (gfc_typenode_for_spec (&expr->ts), ts->kind); + se->string_length = NULL_TREE; break; case INQUIRY_LEN: res = fold_convert (gfc_typenode_for_spec (&expr->ts), se->string_length); + se->string_length = NULL_TREE; break; default: @@ -3393,11 +3403,12 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr) && TREE_CODE (TREE_TYPE (rse.expr)) == INTEGER_TYPE) { wi::tree_to_wide_ref wlhs = wi::to_wide (lse.expr); - HOST_WIDE_INT v, w; + HOST_WIDE_INT v; + unsigned HOST_WIDE_INT w; int kind, ikind, bit_size; v = wlhs.to_shwi (); - w = abs (v); + w = absu_hwi (v); kind = expr->value.op.op1->ts.kind; ikind = gfc_validate_kind (BT_INTEGER, kind, false); @@ -5588,7 +5599,7 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym) } gfc_add_block_to_block (&block, &se.pre); - /* Create array decriptor and set version, rank, attribute, type. */ + /* Create array descriptor and set version, rank, attribute, type. */ cfi = gfc_create_var (gfc_get_cfi_type (e->rank < 0 ? GFC_MAX_DIMENSIONS : e->rank, false), "cfi"); @@ -5642,7 +5653,7 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym) itype = CFI_type_other; // FIXME: Or CFI_type_cptr ? break; case BT_CLASS: - if (UNLIMITED_POLY (e) && fsym->ts.type == BT_ASSUMED) + if (fsym->ts.type == BT_ASSUMED) { // F2017: 7.3.2.2: "An entity that is declared using the TYPE(*) // type specifier is assumed-type and is an unlimited polymorphic @@ -5742,7 +5753,7 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym) if (e->ts.type == BT_ASSUMED) { /* Note: type(*) implies assumed-shape/assumed-rank if fsym requires - an CFI descriptor. Use the type in the descritor as it provide + an CFI descriptor. Use the type in the descriptor as it provide mode information. (Quality of implementation feature.) */ tree cond; tree ctype = gfc_get_cfi_desc_type (cfi); @@ -6674,20 +6685,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, { tree zero; - gfc_expr *var; - - /* Borrow the function symbol to make a call to - gfc_add_finalizer_call and then restore it. */ - tmp = e->symtree->n.sym->backend_decl; - e->symtree->n.sym->backend_decl - = TREE_OPERAND (parmse.expr, 0); - e->symtree->n.sym->attr.flavor = FL_VARIABLE; - var = gfc_lval_expr_from_sym (e->symtree->n.sym); - finalized = gfc_add_finalizer_call (&parmse.post, - var); - gfc_free_expr (var); - e->symtree->n.sym->backend_decl = tmp; - e->symtree->n.sym->attr.flavor = FL_PROCEDURE; + /* Finalize the expression. */ + gfc_finalize_tree_expr (&parmse, NULL, + gfc_expr_attr (e), e->rank); + gfc_add_block_to_block (&parmse.post, + &parmse.finalblock); /* Then free the class _data. */ zero = build_int_cst (TREE_TYPE (parmse.expr), 0); @@ -7123,7 +7125,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, types passed to class formals need the _data component. */ tmp = gfc_class_data_get (tmp); if (!CLASS_DATA (fsym)->attr.dimension) - tmp = build_fold_indirect_ref_loc (input_location, tmp); + { + if (UNLIMITED_POLY (fsym)) + { + tree type = gfc_typenode_for_spec (&e->ts); + type = build_pointer_type (type); + tmp = fold_convert (type, tmp); + } + tmp = build_fold_indirect_ref_loc (input_location, tmp); + } } if (e->expr_type == EXPR_OP @@ -7310,10 +7320,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, if (parmse.string_length && fsym && fsym->ts.deferred) { if (INDIRECT_REF_P (parmse.string_length)) - /* In chains of functions/procedure calls the string_length already - is a pointer to the variable holding the length. Therefore - remove the deref on call. */ - parmse.string_length = TREE_OPERAND (parmse.string_length, 0); + { + /* In chains of functions/procedure calls the string_length already + is a pointer to the variable holding the length. Therefore + remove the deref on call. */ + tmp = parmse.string_length; + parmse.string_length = TREE_OPERAND (parmse.string_length, 0); + } else { tmp = parmse.string_length; @@ -7321,14 +7334,28 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, tmp = gfc_evaluate_now (parmse.string_length, &se->pre); parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp); } + + if (e && e->expr_type == EXPR_VARIABLE + && fsym->attr.allocatable + && e->ts.u.cl->backend_decl + && VAR_P (e->ts.u.cl->backend_decl)) + { + if (INDIRECT_REF_P (tmp)) + tmp = TREE_OPERAND (tmp, 0); + gfc_add_modify (&se->post, e->ts.u.cl->backend_decl, + fold_convert (gfc_charlen_type_node, tmp)); + } } /* Character strings are passed as two parameters, a length and a - pointer - except for Bind(c) which only passes the pointer. + pointer - except for Bind(c) and c_ptrs which only passe the pointer. An unlimited polymorphic formal argument likewise does not need the length. */ if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c + && !(fsym && fsym->ts.type == BT_DERIVED && fsym->ts.u.derived + && fsym->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR + && fsym->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING ) && !(fsym && UNLIMITED_POLY (fsym))) vec_safe_push (stringargs, parmse.string_length); @@ -7779,6 +7806,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, */ if (flag_f2c && sym->ts.type == BT_REAL && sym->ts.kind == gfc_default_real_kind + && !sym->attr.pointer + && !sym->attr.allocatable && !sym->attr.always_explicit) se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr); @@ -8129,7 +8158,7 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, /* Wstringop-overflow appears at -O3 even though this warning is not explicitly available in fortran nor can it be switched off. If the source length is a constant, its negative appears as a very large - postive number and triggers the warning in BUILTIN_MEMSET. Fixing + positive number and triggers the warning in BUILTIN_MEMSET. Fixing the result of the MINUS_EXPR suppresses this spurious warning. */ tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE(dlen), dlen, slen); @@ -8584,6 +8613,20 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm, gfc_conv_expr_descriptor (&se, expr); gfc_add_block_to_block (&block, &se.pre); gfc_add_modify (&block, dest, se.expr); + if (cm->ts.type == BT_CHARACTER + && gfc_deferred_strlen (cm, &tmp)) + { + tmp = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (tmp), + TREE_OPERAND (dest, 0), + tmp, NULL_TREE); + gfc_add_modify (&block, tmp, + fold_convert (TREE_TYPE (tmp), + se.string_length)); + cm->ts.u.cl->backend_decl = gfc_create_var (gfc_charlen_type_node, + "slen"); + gfc_add_modify (&block, cm->ts.u.cl->backend_decl, se.string_length); + } /* Deal with arrays of derived types with allocatable components. */ if (gfc_bt_struct (cm->ts.type) @@ -8607,11 +8650,16 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm, tmp, expr->rank, NULL_TREE); } } + else if (cm->ts.type == BT_CHARACTER && cm->ts.deferred) + tmp = gfc_duplicate_allocatable (dest, se.expr, + gfc_typenode_for_spec (&cm->ts), + cm->as->rank, NULL_TREE); else tmp = gfc_duplicate_allocatable (dest, se.expr, TREE_TYPE(cm->backend_decl), cm->as->rank, NULL_TREE); + gfc_add_expr_to_block (&block, tmp); gfc_add_block_to_block (&block, &se.post); @@ -8724,11 +8772,9 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm, /* Allocate or reallocate scalar component, as necessary. */ static void -alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block, - tree comp, - gfc_component *cm, - gfc_expr *expr2, - gfc_symbol *sym) +alloc_scalar_allocatable_subcomponent (stmtblock_t *block, tree comp, + gfc_component *cm, gfc_expr *expr2, + tree slen) { tree tmp; tree ptr; @@ -8746,26 +8792,20 @@ alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block, if (cm->ts.type == BT_CHARACTER && cm->ts.deferred) { - char name[GFC_MAX_SYMBOL_LEN+9]; - gfc_component *strlen; - /* Use the rhs string length and the lhs element size. */ gcc_assert (expr2->ts.type == BT_CHARACTER); - if (!expr2->ts.u.cl->backend_decl) - { - gfc_conv_string_length (expr2->ts.u.cl, expr2, block); - gcc_assert (expr2->ts.u.cl->backend_decl); - } + if (!expr2->ts.u.cl->backend_decl + || !VAR_P (expr2->ts.u.cl->backend_decl)) + expr2->ts.u.cl->backend_decl = gfc_create_var (TREE_TYPE (slen), + "slen"); + gfc_add_modify (block, expr2->ts.u.cl->backend_decl, slen); size = expr2->ts.u.cl->backend_decl; - /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length - component. */ - sprintf (name, "_%s_length", cm->name); - strlen = gfc_find_component (sym, name, true, true, NULL); + gfc_deferred_strlen (cm, &tmp); lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF, gfc_charlen_type_node, TREE_OPERAND (comp, 0), - strlen->backend_decl, NULL_TREE); + tmp, NULL_TREE); tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts)); tmp = TYPE_SIZE_UNIT (tmp); @@ -8838,8 +8878,8 @@ alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block, /* Assign a single component of a derived type constructor. */ static tree -gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr, - gfc_symbol *sym, bool init) +gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, + gfc_expr * expr, bool init) { gfc_se se; gfc_se lse; @@ -8933,19 +8973,17 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr, || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable && expr->ts.type != BT_CLASS))) { + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, expr); + /* Take care about non-array allocatable components here. The alloc_* routine below is motivated by the alloc_scalar_allocatable_for_ assignment() routine, but with the realloc portions removed and different input. */ - alloc_scalar_allocatable_for_subcomponent_assignment (&block, - dest, - cm, - expr, - sym); + alloc_scalar_allocatable_subcomponent (&block, dest, cm, expr, + se.string_length); /* The remainder of these instructions follow the if (cm->attr.pointer) if (!cm->attr.dimension) part above. */ - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, expr); gfc_add_block_to_block (&block, &se.pre); if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer @@ -9209,13 +9247,11 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray) if (!c->expr) { gfc_expr *e = gfc_get_null_expr (NULL); - tmp = gfc_trans_subcomponent_assign (tmp, cm, e, expr->ts.u.derived, - init); + tmp = gfc_trans_subcomponent_assign (tmp, cm, e, init); gfc_free_expr (e); } else - tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr, - expr->ts.u.derived, init); + tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr, init); gfc_add_expr_to_block (&block, tmp); } return gfc_finish_block (&block); @@ -10203,7 +10239,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_conv_descriptor_data_set (&block, desc, data); /* Copy the span. */ - if (TREE_CODE (rse.expr) == VAR_DECL + if (VAR_P (rse.expr) && GFC_DECL_PTR_ARRAY_P (rse.expr)) span = gfc_conv_descriptor_span_get (rse.expr); else @@ -10890,7 +10926,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) { tmp = sym->backend_decl; lhs = sym->backend_decl; - if (TREE_CODE (tmp) == INDIRECT_REF) + if (INDIRECT_REF_P (tmp)) tmp = TREE_OPERAND (tmp, 0); sym->backend_decl = gfc_create_var (TREE_TYPE (tmp), "lhs"); gfc_add_modify (&se.pre, sym->backend_decl, tmp); @@ -11840,7 +11876,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, if (expr2->ts.type == BT_CHARACTER && !expr1->ts.deferred && !(VAR_P (rse.string_length) || TREE_CODE (rse.string_length) == PARM_DECL - || TREE_CODE (rse.string_length) == INDIRECT_REF)) + || INDIRECT_REF_P (rse.string_length))) string_length = gfc_evaluate_now (rse.string_length, &rse.pre); else if (expr2->ts.type == BT_CHARACTER) { diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index 3cce9c0..b6ea26e 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -4112,7 +4112,7 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op) /* Handle absent optional arguments by ignoring the comparison. */ if (argexpr->expr->expr_type == EXPR_VARIABLE && argexpr->expr->symtree->n.sym->attr.optional - && TREE_CODE (val) == INDIRECT_REF) + && INDIRECT_REF_P (val)) { cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, @@ -4126,7 +4126,7 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op) tree calc; /* For floating point types, the question is what MAX(a, NaN) or MIN(a, NaN) should return (where "a" is a normal number). - There are valid usecase for returning either one, but the + There are valid use case for returning either one, but the Fortran standard doesn't specify which one should be chosen. Also, there is no consensus among other tested compilers. In short, it's a mess. So lets just do whatever is fastest. */ @@ -10155,7 +10155,7 @@ conv_intrinsic_ieee_value (gfc_se *se, gfc_expr *expr) arg = gfc_evaluate_now (arg, &se->pre); type = gfc_typenode_for_spec (&expr->ts); - gcc_assert (TREE_CODE (type) == REAL_TYPE); + gcc_assert (SCALAR_FLOAT_TYPE_P (type)); ret = gfc_create_var (type, NULL); gfc_init_block (&body); @@ -10263,6 +10263,119 @@ conv_intrinsic_ieee_fma (gfc_se * se, gfc_expr * expr) } +/* Generate code for IEEE_{MIN,MAX}_NUM{,_MAG}. */ + +static void +conv_intrinsic_ieee_minmax (gfc_se * se, gfc_expr * expr, int max, + const char *name) +{ + tree args[2], func; + built_in_function fn; + + conv_ieee_function_args (se, expr, args, 2); + gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[1]))); + args[0] = gfc_evaluate_now (args[0], &se->pre); + args[1] = gfc_evaluate_now (args[1], &se->pre); + + if (startswith (name, "mag")) + { + /* IEEE_MIN_NUM_MAG and IEEE_MAX_NUM_MAG translate to C functions + fminmag() and fmaxmag(), which do not exist as built-ins. + + Following glibc, we emit this: + + fminmag (x, y) { + ax = ABS (x); + ay = ABS (y); + if (isless (ax, ay)) + return x; + else if (isgreater (ax, ay)) + return y; + else if (ax == ay) + return x < y ? x : y; + else if (issignaling (x) || issignaling (y)) + return x + y; + else + return isnan (y) ? x : y; + } + + fmaxmag (x, y) { + ax = ABS (x); + ay = ABS (y); + if (isgreater (ax, ay)) + return x; + else if (isless (ax, ay)) + return y; + else if (ax == ay) + return x > y ? x : y; + else if (issignaling (x) || issignaling (y)) + return x + y; + else + return isnan (y) ? x : y; + } + + */ + + tree abs0, abs1, sig0, sig1; + tree cond1, cond2, cond3, cond4, cond5; + tree res; + tree type = TREE_TYPE (args[0]); + + func = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind); + abs0 = build_call_expr_loc (input_location, func, 1, args[0]); + abs1 = build_call_expr_loc (input_location, func, 1, args[1]); + abs0 = gfc_evaluate_now (abs0, &se->pre); + abs1 = gfc_evaluate_now (abs1, &se->pre); + + cond5 = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_ISNAN), + 1, args[1]); + res = fold_build3_loc (input_location, COND_EXPR, type, cond5, + args[0], args[1]); + + sig0 = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_ISSIGNALING), + 1, args[0]); + sig1 = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_ISSIGNALING), + 1, args[1]); + cond4 = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, + logical_type_node, sig0, sig1); + res = fold_build3_loc (input_location, COND_EXPR, type, cond4, + fold_build2_loc (input_location, PLUS_EXPR, + type, args[0], args[1]), + res); + + cond3 = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, + abs0, abs1); + res = fold_build3_loc (input_location, COND_EXPR, type, cond3, + fold_build2_loc (input_location, + max ? MAX_EXPR : MIN_EXPR, + type, args[0], args[1]), + res); + + func = builtin_decl_explicit (max ? BUILT_IN_ISLESS : BUILT_IN_ISGREATER); + cond2 = build_call_expr_loc (input_location, func, 2, abs0, abs1); + res = fold_build3_loc (input_location, COND_EXPR, type, cond2, + args[1], res); + + func = builtin_decl_explicit (max ? BUILT_IN_ISGREATER : BUILT_IN_ISLESS); + cond1 = build_call_expr_loc (input_location, func, 2, abs0, abs1); + res = fold_build3_loc (input_location, COND_EXPR, type, cond1, + args[0], res); + + se->expr = res; + } + else + { + /* IEEE_MIN_NUM and IEEE_MAX_NUM translate to fmin() and fmax(). */ + fn = max ? BUILT_IN_FMAX : BUILT_IN_FMIN; + func = gfc_builtin_decl_for_float_kind (fn, expr->ts.kind); + se->expr = build_call_expr_loc_array (input_location, func, 2, args); + } +} + + /* Generate code for an intrinsic function from the IEEE_ARITHMETIC module. */ @@ -10301,6 +10414,10 @@ gfc_conv_ieee_arithmetic_function (gfc_se * se, gfc_expr * expr) conv_intrinsic_ieee_value (se, expr); else if (startswith (name, "_gfortran_ieee_fma")) conv_intrinsic_ieee_fma (se, expr); + else if (startswith (name, "_gfortran_ieee_min_num_")) + conv_intrinsic_ieee_minmax (se, expr, 0, name + 23); + else if (startswith (name, "_gfortran_ieee_max_num_")) + conv_intrinsic_ieee_minmax (se, expr, 1, name + 23); else /* It is not among the functions we translate directly. We return false, so a library function call is emitted. */ diff --git a/gcc/fortran/trans-io.cc b/gcc/fortran/trans-io.cc index baeea95..e36ad0e 100644 --- a/gcc/fortran/trans-io.cc +++ b/gcc/fortran/trans-io.cc @@ -791,7 +791,7 @@ gfc_convert_array_to_string (gfc_se * se, gfc_expr * e) } else { - gcc_assert (TREE_CODE (se->expr) == INDIRECT_REF); + gcc_assert (INDIRECT_REF_P (se->expr)); tree ptr = TREE_OPERAND (se->expr, 0); gcc_assert (TREE_CODE (ptr) == POINTER_PLUS_EXPR); @@ -2620,12 +2620,16 @@ gfc_trans_transfer (gfc_code * code) gcc_assert (ref && ref->type == REF_ARRAY); } + /* These expressions don't always have the dtype element length set + correctly, rendering them useless for array transfer. */ if (expr->ts.type != BT_CLASS && expr->expr_type == EXPR_VARIABLE - && gfc_expr_attr (expr).pointer) + && ((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)) goto scalarize; - if (!(gfc_bt_struct (expr->ts.type) || expr->ts.type == BT_CLASS) && ref && ref->next == NULL diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc index 84c0184..4aa16fa 100644 --- a/gcc/fortran/trans-openmp.cc +++ b/gcc/fortran/trans-openmp.cc @@ -73,7 +73,7 @@ static bool gfc_omp_is_optional_argument (const_tree decl) { /* Note: VAR_DECL can occur with BIND(C) and array descriptors. */ - return ((TREE_CODE (decl) == PARM_DECL || TREE_CODE (decl) == VAR_DECL) + return ((TREE_CODE (decl) == PARM_DECL || VAR_P (decl)) && DECL_LANG_SPECIFIC (decl) && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE && !VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl))) @@ -83,7 +83,7 @@ gfc_omp_is_optional_argument (const_tree decl) /* Check whether this DECL belongs to a Fortran optional argument. With 'for_present_check' set to false, decls which are optional parameters - themselve are returned as tree - or a NULL_TREE otherwise. Those decls are + themselves are returned as tree - or a NULL_TREE otherwise. Those decls are always pointers. With 'for_present_check' set to true, the decl for checking whether an argument is present is returned; for arguments with value attribute this is the hidden argument and of BOOLEAN_TYPE. If the decl is @@ -2403,33 +2403,50 @@ static vec<tree, va_heap, vl_embed> *doacross_steps; /* Translate an array section or array element. */ static void -gfc_trans_omp_array_section (stmtblock_t *block, gfc_omp_namelist *n, - tree decl, bool element, gomp_map_kind ptr_kind, - tree &node, tree &node2, tree &node3, tree &node4) +gfc_trans_omp_array_section (stmtblock_t *block, gfc_exec_op op, + gfc_omp_namelist *n, tree decl, bool element, + gomp_map_kind ptr_kind, tree &node, tree &node2, + tree &node3, tree &node4) { gfc_se se; tree ptr, ptr2; tree elemsz = NULL_TREE; gfc_init_se (&se, NULL); - if (element) { gfc_conv_expr_reference (&se, n->expr); gfc_add_block_to_block (block, &se.pre); ptr = se.expr; - OMP_CLAUSE_SIZE (node) = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (ptr))); - elemsz = OMP_CLAUSE_SIZE (node); } else { gfc_conv_expr_descriptor (&se, n->expr); ptr = gfc_conv_array_data (se.expr); + } + if (n->expr->ts.type == BT_CHARACTER && n->expr->ts.deferred) + { + gcc_assert (se.string_length); + tree len = gfc_evaluate_now (se.string_length, block); + elemsz = gfc_get_char_type (n->expr->ts.kind); + elemsz = TYPE_SIZE_UNIT (elemsz); + elemsz = fold_build2 (MULT_EXPR, size_type_node, + fold_convert (size_type_node, len), elemsz); + } + if (element) + { + if (!elemsz) + elemsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (ptr))); + OMP_CLAUSE_SIZE (node) = elemsz; + } + else + { tree type = TREE_TYPE (se.expr); gfc_add_block_to_block (block, &se.pre); OMP_CLAUSE_SIZE (node) = gfc_full_array_size (block, se.expr, GFC_TYPE_ARRAY_RANK (type)); - elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + if (!elemsz) + elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type)); elemsz = fold_convert (gfc_array_index_type, elemsz); OMP_CLAUSE_SIZE (node) = fold_build2 (MULT_EXPR, gfc_array_index_type, OMP_CLAUSE_SIZE (node), elemsz); @@ -2441,7 +2458,11 @@ gfc_trans_omp_array_section (stmtblock_t *block, gfc_omp_namelist *n, if (POINTER_TYPE_P (TREE_TYPE (decl)) && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl))) - && ptr_kind == GOMP_MAP_POINTER) + && ptr_kind == GOMP_MAP_POINTER + && op != EXEC_OMP_TARGET_EXIT_DATA + && OMP_CLAUSE_MAP_KIND (node) != GOMP_MAP_RELEASE + && OMP_CLAUSE_MAP_KIND (node) != GOMP_MAP_DELETE) + { node4 = build_omp_clause (input_location, OMP_CLAUSE_MAP); @@ -2455,13 +2476,13 @@ gfc_trans_omp_array_section (stmtblock_t *block, gfc_omp_namelist *n, && n->expr->ts.deferred) { gomp_map_kind map_kind; - if (GOMP_MAP_COPY_TO_P (OMP_CLAUSE_MAP_KIND (node))) - map_kind = GOMP_MAP_TO; - else if (OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_RELEASE - || OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_DELETE) + if (OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_DELETE) map_kind = OMP_CLAUSE_MAP_KIND (node); + else if (op == EXEC_OMP_TARGET_EXIT_DATA + || OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_RELEASE) + map_kind = GOMP_MAP_RELEASE; else - map_kind = GOMP_MAP_ALLOC; + map_kind = GOMP_MAP_TO; gcc_assert (se.string_length); node4 = build_omp_clause (input_location, OMP_CLAUSE_MAP); OMP_CLAUSE_SET_MAP_KIND (node4, map_kind); @@ -2476,7 +2497,18 @@ gfc_trans_omp_array_section (stmtblock_t *block, gfc_omp_namelist *n, desc_node = build_omp_clause (input_location, OMP_CLAUSE_MAP); OMP_CLAUSE_DECL (desc_node) = decl; OMP_CLAUSE_SIZE (desc_node) = TYPE_SIZE_UNIT (type); - if (ptr_kind == GOMP_MAP_ALWAYS_POINTER) + if (OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_DELETE) + { + OMP_CLAUSE_SET_MAP_KIND (desc_node, GOMP_MAP_DELETE); + node2 = desc_node; + } + else if (OMP_CLAUSE_MAP_KIND (node) == GOMP_MAP_RELEASE + || op == EXEC_OMP_TARGET_EXIT_DATA) + { + OMP_CLAUSE_SET_MAP_KIND (desc_node, GOMP_MAP_RELEASE); + node2 = desc_node; + } + else if (ptr_kind == GOMP_MAP_ALWAYS_POINTER) { OMP_CLAUSE_SET_MAP_KIND (desc_node, GOMP_MAP_TO); node2 = node; @@ -2487,11 +2519,11 @@ gfc_trans_omp_array_section (stmtblock_t *block, gfc_omp_namelist *n, OMP_CLAUSE_SET_MAP_KIND (desc_node, GOMP_MAP_TO_PSET); node2 = desc_node; } - node3 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); + if (op == EXEC_OMP_TARGET_EXIT_DATA) + return; + node3 = build_omp_clause (input_location, OMP_CLAUSE_MAP); OMP_CLAUSE_SET_MAP_KIND (node3, ptr_kind); - OMP_CLAUSE_DECL (node3) - = gfc_conv_descriptor_data_get (decl); + OMP_CLAUSE_DECL (node3) = gfc_conv_descriptor_data_get (decl); /* This purposely does not include GOMP_MAP_ALWAYS_POINTER. The extra cast prevents gimplify.cc from recognising it as being part of the struct - and adding an 'alloc: for the 'desc.data' pointer, which @@ -2595,7 +2627,7 @@ handle_iterator (gfc_namespace *ns, stmtblock_t *iter_block, tree block) static tree gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, locus where, bool declare_simd = false, - bool openacc = false) + bool openacc = false, gfc_exec_op op = EXEC_NOP) { tree omp_clauses = NULL_TREE, prev_clauses, chunk_size, c; tree iterator = NULL_TREE; @@ -2716,11 +2748,11 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, tree node = build_omp_clause (input_location, OMP_CLAUSE_ALLOCATE); OMP_CLAUSE_DECL (node) = t; - if (n->expr) + if (n->u2.allocator) { tree allocator_; gfc_init_se (&se, NULL); - gfc_conv_expr (&se, n->expr); + gfc_conv_expr (&se, n->u2.allocator); allocator_ = gfc_evaluate_now (se.expr, block); OMP_CLAUSE_ALLOCATE_ALLOCATOR (node) = allocator_; } @@ -3026,6 +3058,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, tree node2 = NULL_TREE; tree node3 = NULL_TREE; tree node4 = NULL_TREE; + tree node5 = NULL_TREE; /* OpenMP: automatically map pointer targets with the pointer; hence, always update the descriptor/pointer itself. */ @@ -3066,6 +3099,30 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, always_modifier = true; OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_TOFROM); break; + case OMP_MAP_PRESENT_ALLOC: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_PRESENT_ALLOC); + break; + case OMP_MAP_PRESENT_TO: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_PRESENT_TO); + break; + case OMP_MAP_PRESENT_FROM: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_PRESENT_FROM); + break; + case OMP_MAP_PRESENT_TOFROM: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_PRESENT_TOFROM); + break; + case OMP_MAP_ALWAYS_PRESENT_TO: + always_modifier = true; + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_PRESENT_TO); + break; + case OMP_MAP_ALWAYS_PRESENT_FROM: + always_modifier = true; + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_PRESENT_FROM); + break; + case OMP_MAP_ALWAYS_PRESENT_TOFROM: + always_modifier = true; + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_PRESENT_TOFROM); + break; case OMP_MAP_RELEASE: OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_RELEASE); break; @@ -3130,6 +3187,24 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, || (n->expr->ref->type == REF_ARRAY && n->expr->ref->u.ar.type == AR_FULL)) { + gomp_map_kind map_kind; + tree type = TREE_TYPE (decl); + if (n->sym->ts.type == BT_CHARACTER + && n->sym->ts.deferred + && n->sym->attr.omp_declare_target + && (always_modifier || n->sym->attr.pointer) + && op != EXEC_OMP_TARGET_EXIT_DATA + && n->u.map_op != OMP_MAP_DELETE + && n->u.map_op != OMP_MAP_RELEASE) + { + gcc_assert (n->sym->ts.u.cl->backend_decl); + node5 = build_omp_clause (input_location, OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node5, GOMP_MAP_ALWAYS_TO); + OMP_CLAUSE_DECL (node5) = n->sym->ts.u.cl->backend_decl; + OMP_CLAUSE_SIZE (node5) + = TYPE_SIZE_UNIT (gfc_charlen_type_node); + } + tree present = gfc_omp_check_optional_argument (decl, true); if (openacc && n->sym->ts.type == BT_CLASS) { @@ -3145,13 +3220,12 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, OMP_CLAUSE_SIZE (node2) = size_int (0); goto finalize_map_clause; } - else if (POINTER_TYPE_P (TREE_TYPE (decl)) + else if (POINTER_TYPE_P (type) && (gfc_omp_privatize_by_reference (decl) || GFC_DECL_GET_SCALAR_POINTER (decl) || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl) || GFC_DECL_CRAY_POINTEE (decl) - || GFC_DESCRIPTOR_TYPE_P - (TREE_TYPE (TREE_TYPE (decl))) + || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)) || (n->sym->ts.type == BT_DERIVED && (n->sym->ts.u.derived->ts.f90_type != BT_VOID)))) @@ -3164,7 +3238,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, to avoid accessing undefined variables. We cannot use a temporary variable here as otherwise the replacement of the variables in omp-low.cc will not work. */ - if (present && GFC_ARRAY_TYPE_P (TREE_TYPE (decl))) + if (present && GFC_ARRAY_TYPE_P (type)) { tree tmp = fold_build2_loc (input_location, MODIFY_EXPR, @@ -3181,22 +3255,51 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, cond, tmp, NULL_TREE)); } - node4 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (node4, GOMP_MAP_POINTER); - OMP_CLAUSE_DECL (node4) = decl; - OMP_CLAUSE_SIZE (node4) = size_int (0); + /* For descriptor types, the unmapping happens below. */ + if (op != EXEC_OMP_TARGET_EXIT_DATA + || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + { + enum gomp_map_kind gmk = GOMP_MAP_POINTER; + if (op == EXEC_OMP_TARGET_EXIT_DATA + && n->u.map_op == OMP_MAP_DELETE) + gmk = GOMP_MAP_DELETE; + else if (op == EXEC_OMP_TARGET_EXIT_DATA) + gmk = GOMP_MAP_RELEASE; + tree size; + if (gmk == GOMP_MAP_RELEASE || gmk == GOMP_MAP_DELETE) + size = TYPE_SIZE_UNIT (TREE_TYPE (decl)); + else + size = size_int (0); + node4 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node4, gmk); + OMP_CLAUSE_DECL (node4) = decl; + OMP_CLAUSE_SIZE (node4) = size; + } decl = build_fold_indirect_ref (decl); if ((TREE_CODE (TREE_TYPE (orig_decl)) == REFERENCE_TYPE || gfc_omp_is_optional_argument (orig_decl)) && (GFC_DECL_GET_SCALAR_POINTER (orig_decl) || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl))) { + enum gomp_map_kind gmk; + if (op == EXEC_OMP_TARGET_EXIT_DATA + && n->u.map_op == OMP_MAP_DELETE) + gmk = GOMP_MAP_DELETE; + else if (op == EXEC_OMP_TARGET_EXIT_DATA) + gmk = GOMP_MAP_RELEASE; + else + gmk = GOMP_MAP_POINTER; + tree size; + if (gmk == GOMP_MAP_RELEASE || gmk == GOMP_MAP_DELETE) + size = TYPE_SIZE_UNIT (TREE_TYPE (decl)); + else + size = size_int (0); node3 = build_omp_clause (input_location, OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_POINTER); + OMP_CLAUSE_SET_MAP_KIND (node3, gmk); OMP_CLAUSE_DECL (node3) = decl; - OMP_CLAUSE_SIZE (node3) = size_int (0); + OMP_CLAUSE_SIZE (node3) = size; decl = build_fold_indirect_ref (decl); } } @@ -3210,56 +3313,70 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr))); ptr = build_fold_indirect_ref (ptr); OMP_CLAUSE_DECL (node) = ptr; - node2 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_TO_PSET); + node2 = build_omp_clause (input_location, OMP_CLAUSE_MAP); OMP_CLAUSE_DECL (node2) = decl; OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type); - node3 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); - if (present) - { - ptr = gfc_conv_descriptor_data_get (decl); - ptr = gfc_build_addr_expr (NULL, ptr); - ptr = gfc_build_cond_assign_expr (block, present, ptr, - null_pointer_node); - ptr = build_fold_indirect_ref (ptr); - OMP_CLAUSE_DECL (node3) = ptr; - } + if (n->u.map_op == OMP_MAP_DELETE) + map_kind = GOMP_MAP_DELETE; + else if (op == EXEC_OMP_TARGET_EXIT_DATA + || n->u.map_op == OMP_MAP_RELEASE) + map_kind = GOMP_MAP_RELEASE; else - OMP_CLAUSE_DECL (node3) - = gfc_conv_descriptor_data_get (decl); - OMP_CLAUSE_SIZE (node3) = size_int (0); - if (n->u.map_op == OMP_MAP_ATTACH) - { - /* Standalone attach clauses used with arrays with - descriptors must copy the descriptor to the target, - else they won't have anything to perform the - attachment onto (see OpenACC 2.6, "2.6.3. Data - Structures with Pointers"). */ - OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_ATTACH); - /* We don't want to map PTR at all in this case, so - delete its node and shuffle the others down. */ - node = node2; - node2 = node3; - node3 = NULL; - goto finalize_map_clause; - } - else if (n->u.map_op == OMP_MAP_DETACH) + map_kind = GOMP_MAP_TO_PSET; + OMP_CLAUSE_SET_MAP_KIND (node2, map_kind); + + if (op != EXEC_OMP_TARGET_EXIT_DATA + && n->u.map_op != OMP_MAP_DELETE + && n->u.map_op != OMP_MAP_RELEASE) { - OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_DETACH); - /* Similarly to above, we don't want to unmap PTR - here. */ - node = node2; - node2 = node3; - node3 = NULL; - goto finalize_map_clause; + node3 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + if (present) + { + ptr = gfc_conv_descriptor_data_get (decl); + ptr = gfc_build_addr_expr (NULL, ptr); + ptr = gfc_build_cond_assign_expr ( + block, present, ptr, null_pointer_node); + ptr = build_fold_indirect_ref (ptr); + OMP_CLAUSE_DECL (node3) = ptr; + } + else + OMP_CLAUSE_DECL (node3) + = gfc_conv_descriptor_data_get (decl); + OMP_CLAUSE_SIZE (node3) = size_int (0); + + if (n->u.map_op == OMP_MAP_ATTACH) + { + /* Standalone attach clauses used with arrays with + descriptors must copy the descriptor to the + target, else they won't have anything to + perform the attachment onto (see OpenACC 2.6, + "2.6.3. Data Structures with Pointers"). */ + OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_ATTACH); + /* We don't want to map PTR at all in this case, + so delete its node and shuffle the others + down. */ + node = node2; + node2 = node3; + node3 = NULL; + goto finalize_map_clause; + } + else if (n->u.map_op == OMP_MAP_DETACH) + { + OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_DETACH); + /* Similarly to above, we don't want to unmap PTR + here. */ + node = node2; + node2 = node3; + node3 = NULL; + goto finalize_map_clause; + } + else + OMP_CLAUSE_SET_MAP_KIND (node3, + always_modifier + ? GOMP_MAP_ALWAYS_POINTER + : GOMP_MAP_POINTER); } - else - OMP_CLAUSE_SET_MAP_KIND (node3, - always_modifier - ? GOMP_MAP_ALWAYS_POINTER - : GOMP_MAP_POINTER); /* We have to check for n->sym->attr.dimension because of scalar coarrays. */ @@ -3275,6 +3392,23 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, tem = gfc_full_array_size (&cond_block, decl, GFC_TYPE_ARRAY_RANK (type)); + tree elemsz; + if (n->sym->ts.type == BT_CHARACTER + && n->sym->ts.deferred) + { + tree len = n->sym->ts.u.cl->backend_decl; + len = fold_convert (size_type_node, len); + elemsz = gfc_get_char_type (n->sym->ts.kind); + elemsz = TYPE_SIZE_UNIT (elemsz); + elemsz = fold_build2 (MULT_EXPR, size_type_node, + len, elemsz); + } + else + elemsz + = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + elemsz = fold_convert (gfc_array_index_type, elemsz); + tem = fold_build2 (MULT_EXPR, gfc_array_index_type, + tem, elemsz); gfc_add_modify (&cond_block, size, tem); then_b = gfc_finish_block (&cond_block); gfc_init_block (&cond_block); @@ -3305,6 +3439,12 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, gfc_init_block (&cond_block); tree size = gfc_full_array_size (&cond_block, decl, GFC_TYPE_ARRAY_RANK (type)); + tree elemsz + = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + elemsz = fold_convert (gfc_array_index_type, elemsz); + size = fold_build2 (MULT_EXPR, gfc_array_index_type, + size, elemsz); + size = gfc_evaluate_now (size, &cond_block); if (present) { tree var = gfc_create_var (gfc_array_index_type, @@ -3323,20 +3463,10 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, OMP_CLAUSE_SIZE (node) = size; } } - if (n->sym->attr.dimension) - { - tree elemsz - = TYPE_SIZE_UNIT (gfc_get_element_type (type)); - elemsz = fold_convert (gfc_array_index_type, elemsz); - OMP_CLAUSE_SIZE (node) - = fold_build2 (MULT_EXPR, gfc_array_index_type, - OMP_CLAUSE_SIZE (node), elemsz); - } } else if (present - && TREE_CODE (decl) == INDIRECT_REF - && (TREE_CODE (TREE_OPERAND (decl, 0)) - == INDIRECT_REF)) + && INDIRECT_REF_P (decl) + && INDIRECT_REF_P (TREE_OPERAND (decl, 0))) { /* A single indirectref is handled by the middle end. */ gcc_assert (!POINTER_TYPE_P (TREE_TYPE (decl))); @@ -3347,6 +3477,37 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, } else OMP_CLAUSE_DECL (node) = decl; + + if (!n->sym->attr.dimension + && n->sym->ts.type == BT_CHARACTER + && n->sym->ts.deferred) + { + if (!DECL_P (decl)) + { + gcc_assert (TREE_CODE (decl) == INDIRECT_REF); + decl = TREE_OPERAND (decl, 0); + } + tree cond = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, + decl, null_pointer_node); + if (present) + cond = fold_build2_loc (input_location, + TRUTH_ANDIF_EXPR, + boolean_type_node, + present, cond); + tree len = n->sym->ts.u.cl->backend_decl; + len = fold_convert (size_type_node, len); + tree size = gfc_get_char_type (n->sym->ts.kind); + size = TYPE_SIZE_UNIT (size); + size = fold_build2 (MULT_EXPR, size_type_node, len, size); + size = build3_loc (input_location, + COND_EXPR, + size_type_node, + cond, size, + size_zero_node); + size = gfc_evaluate_now (size, block); + OMP_CLAUSE_SIZE (node) = size; + } } else if (n->expr && n->expr->expr_type == EXPR_VARIABLE @@ -3363,7 +3524,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, && !(POINTER_TYPE_P (type) && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))) k = GOMP_MAP_FIRSTPRIVATE_POINTER; - gfc_trans_omp_array_section (block, n, decl, element, k, + gfc_trans_omp_array_section (block, op, n, decl, element, k, node, node2, node3, node4); } else if (n->expr @@ -3388,6 +3549,19 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, gfc_add_block_to_block (block, &se.post); if (pointer || allocatable) { + /* If it's a bare attach/detach clause, we just want + to perform a single attach/detach operation, of the + pointer itself, not of the pointed-to object. */ + if (openacc + && (n->u.map_op == OMP_MAP_ATTACH + || n->u.map_op == OMP_MAP_DETACH)) + { + OMP_CLAUSE_DECL (node) + = build_fold_addr_expr (OMP_CLAUSE_DECL (node)); + OMP_CLAUSE_SIZE (node) = size_zero_node; + goto finalize_map_clause; + } + node2 = build_omp_clause (input_location, OMP_CLAUSE_MAP); gomp_map_kind kind @@ -3411,9 +3585,15 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, fold_convert (size_type_node, se.string_length), TYPE_SIZE_UNIT (tmp)); + if (n->u.map_op == OMP_MAP_DELETE) + kind = GOMP_MAP_DELETE; + else if (op == EXEC_OMP_TARGET_EXIT_DATA) + kind = GOMP_MAP_RELEASE; + else + kind = GOMP_MAP_TO; node3 = build_omp_clause (input_location, OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_TO); + OMP_CLAUSE_SET_MAP_KIND (node3, kind); OMP_CLAUSE_DECL (node3) = se.string_length; OMP_CLAUSE_SIZE (node3) = TYPE_SIZE_UNIT (gfc_charlen_type_node); @@ -3458,6 +3638,19 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, { if (pointer || (openacc && allocatable)) { + /* If it's a bare attach/detach clause, we just want + to perform a single attach/detach operation, of the + pointer itself, not of the pointed-to object. */ + if (openacc + && (n->u.map_op == OMP_MAP_ATTACH + || n->u.map_op == OMP_MAP_DETACH)) + { + OMP_CLAUSE_DECL (node) + = build_fold_addr_expr (inner); + OMP_CLAUSE_SIZE (node) = size_zero_node; + goto finalize_map_clause; + } + tree data, size; if (lastref->u.c.component->ts.type == BT_CLASS) @@ -3494,12 +3687,20 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, else if (lastref->type == REF_ARRAY && lastref->u.ar.type == AR_FULL) { - /* Just pass the (auto-dereferenced) decl through for - bare attach and detach clauses. */ - if (n->u.map_op == OMP_MAP_ATTACH - || n->u.map_op == OMP_MAP_DETACH) + /* Bare attach and detach clauses don't want any + additional nodes. */ + if ((n->u.map_op == OMP_MAP_ATTACH + || n->u.map_op == OMP_MAP_DETACH) + && (POINTER_TYPE_P (TREE_TYPE (inner)) + || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (inner)))) { - OMP_CLAUSE_DECL (node) = inner; + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (inner))) + { + tree ptr = gfc_conv_descriptor_data_get (inner); + OMP_CLAUSE_DECL (node) = ptr; + } + else + OMP_CLAUSE_DECL (node) = inner; OMP_CLAUSE_SIZE (node) = size_zero_node; goto finalize_map_clause; } @@ -3517,11 +3718,17 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, = gfc_full_array_size (block, inner, rank); tree elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type)); - if (GOMP_MAP_COPY_TO_P (OMP_CLAUSE_MAP_KIND (node))) - map_kind = GOMP_MAP_TO; + map_kind = OMP_CLAUSE_MAP_KIND (node); + if (GOMP_MAP_COPY_TO_P (map_kind) + || map_kind == GOMP_MAP_ALLOC) + map_kind = ((GOMP_MAP_ALWAYS_P (map_kind) + || gfc_expr_attr (n->expr).pointer) + ? GOMP_MAP_ALWAYS_TO : GOMP_MAP_TO); else if (n->u.map_op == OMP_MAP_RELEASE || n->u.map_op == OMP_MAP_DELETE) - map_kind = OMP_CLAUSE_MAP_KIND (node); + ; + else if (op == EXEC_OMP_TARGET_EXIT_DATA) + map_kind = GOMP_MAP_RELEASE; else map_kind = GOMP_MAP_ALLOC; if (!openacc @@ -3562,6 +3769,8 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, node2 = node; node = desc_node; /* Put first. */ } + if (op == EXEC_OMP_TARGET_EXIT_DATA) + goto finalize_map_clause; node3 = build_omp_clause (input_location, OMP_CLAUSE_MAP); OMP_CLAUSE_SET_MAP_KIND (node3, @@ -3592,7 +3801,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, bool element = lastref->u.ar.type == AR_ELEMENT; gomp_map_kind kind = (openacc ? GOMP_MAP_ATTACH_DETACH : GOMP_MAP_ALWAYS_POINTER); - gfc_trans_omp_array_section (block, n, inner, element, + gfc_trans_omp_array_section (block, op, n, inner, element, kind, node, node2, node3, node4); } @@ -3611,6 +3820,8 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, omp_clauses = gfc_trans_add_clause (node3, omp_clauses); if (node4) omp_clauses = gfc_trans_add_clause (node4, omp_clauses); + if (node5) + omp_clauses = gfc_trans_add_clause (node5, omp_clauses); } break; case OMP_LIST_TO: @@ -3707,6 +3918,8 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr))); OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr); } + if (n->u.present_modifier) + OMP_CLAUSE_MOTION_PRESENT (node) = 1; omp_clauses = gfc_trans_add_clause (node, omp_clauses); } break; @@ -4248,6 +4461,9 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, case OMP_DEFAULTMAP_FIRSTPRIVATE: behavior = OMP_CLAUSE_DEFAULTMAP_FIRSTPRIVATE; break; + case OMP_DEFAULTMAP_PRESENT: + behavior = OMP_CLAUSE_DEFAULTMAP_PRESENT; + break; case OMP_DEFAULTMAP_NONE: behavior = OMP_CLAUSE_DEFAULTMAP_NONE; break; case OMP_DEFAULTMAP_DEFAULT: behavior = OMP_CLAUSE_DEFAULTMAP_DEFAULT; @@ -5603,26 +5819,29 @@ gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock, /* Main loop body. */ if (clauses->lists[OMP_LIST_REDUCTION_INSCAN]) { - gcc_assert (code->block->next->next->op == EXEC_OMP_SCAN); - gcc_assert (code->block->next->next->next->next == NULL); - locus *cloc = &code->block->next->next->loc; - location_t loc = gfc_get_location (cloc); - - gfc_code code2 = *code->block->next; - code2.next = NULL; - tmp = gfc_trans_code (&code2); + gfc_code *code1, *scan, *code2, *tmpcode; + code1 = tmpcode = code->block->next; + if (tmpcode && tmpcode->op != EXEC_OMP_SCAN) + while (tmpcode && tmpcode->next && tmpcode->next->op != EXEC_OMP_SCAN) + tmpcode = tmpcode->next; + scan = tmpcode->op == EXEC_OMP_SCAN ? tmpcode : tmpcode->next; + if (code1 != scan) + tmpcode->next = NULL; + code2 = scan->next; + gcc_assert (scan->op == EXEC_OMP_SCAN); + location_t loc = gfc_get_location (&scan->loc); + + tmp = code1 != scan ? gfc_trans_code (code1) : build_empty_stmt (loc); tmp = build2 (OMP_SCAN, void_type_node, tmp, NULL_TREE); SET_EXPR_LOCATION (tmp, loc); gfc_add_expr_to_block (&body, tmp); input_location = loc; - tree c = gfc_trans_omp_clauses (&body, - code->block->next->next->ext.omp_clauses, - *cloc); - code2 = *code->block->next->next->next; - code2.next = NULL; - tmp = gfc_trans_code (&code2); + tree c = gfc_trans_omp_clauses (&body, scan->ext.omp_clauses, scan->loc); + tmp = code2 ? gfc_trans_code (code2) : build_empty_stmt (loc); tmp = build2 (OMP_SCAN, void_type_node, tmp, c); SET_EXPR_LOCATION (tmp, loc); + if (code1 != scan) + tmpcode->next = scan; } else tmp = gfc_trans_omp_code (code->block->next, true); @@ -6065,7 +6284,7 @@ gfc_add_clause_implicitly (gfc_omp_clauses *clauses_out, } if (n_firstp && n_lastp) { - /* For parallel do, GCC puts firstprivatee/lastprivate + /* For parallel do, GCC puts firstprivate/lastprivate on the parallel. */ if (is_parallel_do) continue; @@ -6632,7 +6851,7 @@ gfc_split_omp_clauses (gfc_code *code, clausesa[GFC_OMP_SPLIT_DO].nowait = true; /* Distribute allocate clause to do, parallel, distribute, teams, target - and taskloop. The code below itereates over variables in the + and taskloop. The code below iterates over variables in the allocate list and checks if that available is also in any privatization clause on those construct. If yes, then we add it to the list of 'allocate'ed variables for that construct. If a @@ -6671,6 +6890,8 @@ gfc_split_omp_clauses (gfc_code *code, p = gfc_get_omp_namelist (); p->sym = alloc_nl->sym; p->expr = alloc_nl->expr; + p->u.align = alloc_nl->u.align; + p->u2.allocator = alloc_nl->u2.allocator; p->where = alloc_nl->where; if (clausesa[i].lists[OMP_LIST_ALLOCATE] == NULL) { @@ -7475,7 +7696,7 @@ gfc_trans_omp_target_exit_data (gfc_code *code) gfc_start_block (&block); omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, - code->loc); + code->loc, false, false, code->op); stmt = build1_loc (input_location, OMP_TARGET_EXIT_DATA, void_type_node, omp_clauses); gfc_add_expr_to_block (&block, stmt); @@ -7722,6 +7943,11 @@ gfc_trans_omp_directive (gfc_code *code) { switch (code->op) { + case EXEC_OMP_ALLOCATE: + case EXEC_OMP_ALLOCATORS: + sorry ("%<!$OMP %s%> not yet supported", + code->op == EXEC_OMP_ALLOCATE ? "ALLOCATE" : "ALLOCATORS"); + return NULL_TREE; case EXEC_OMP_ASSUME: return gfc_trans_omp_assume (code); case EXEC_OMP_ATOMIC: diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc index f788754..7e76834 100644 --- a/gcc/fortran/trans-stmt.cc +++ b/gcc/fortran/trans-stmt.cc @@ -82,7 +82,7 @@ gfc_conv_label_variable (gfc_se * se, gfc_expr * expr) if (TREE_CODE (se->expr) == COMPONENT_REF) se->expr = TREE_OPERAND (se->expr, 1); /* Deals with dummy argument. Get the parameter declaration. */ - else if (TREE_CODE (se->expr) == INDIRECT_REF) + else if (INDIRECT_REF_P (se->expr)) se->expr = TREE_OPERAND (se->expr, 0); } @@ -470,7 +470,7 @@ gfc_trans_call (gfc_code * code, bool dependency_check, gfc_conv_ss_startstride (&loop); /* TODO: gfc_conv_loop_setup generates a temporary for vector subscripts. This could be prevented in the elemental case - as temporaries are handled separatedly + as temporaries are handled separately (below in gfc_conv_elemental_dependencies). */ if (code->expr1) gfc_conv_loop_setup (&loop, &code->expr1->where); @@ -1930,15 +1930,13 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) gfc_conv_expr_descriptor (&se, e); if (sym->ts.type == BT_CHARACTER - && sym->ts.deferred && !sym->attr.select_type_temporary + && sym->ts.u.cl->backend_decl && VAR_P (sym->ts.u.cl->backend_decl) && se.string_length != sym->ts.u.cl->backend_decl) - { - gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl, + gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl, fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl), se.string_length)); - } /* If we didn't already do the pointer assignment, set associate-name descriptor to the one generated for the temporary. */ @@ -2141,11 +2139,14 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) tree ctree = gfc_get_class_from_expr (se.expr); tmp = TREE_TYPE (sym->backend_decl); - /* Coarray scalar component expressions can emerge from - the front end as array elements of the _data field. */ + /* F2018:19.5.1.6 "If a selector has the POINTER attribute, + it shall be associated; the associate name is associated + with the target of the pointer and does not have the + POINTER attribute." */ if (sym->ts.type == BT_CLASS - && e->ts.type == BT_CLASS && e->rank == 0 - && !GFC_CLASS_TYPE_P (TREE_TYPE (se.expr)) && ctree) + && e->ts.type == BT_CLASS && e->rank == 0 && ctree + && (!GFC_CLASS_TYPE_P (TREE_TYPE (se.expr)) + || CLASS_DATA (e)->attr.class_pointer)) { tree stmp; tree dtmp; @@ -2155,10 +2156,10 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) ctree = gfc_create_var (dtmp, "class"); stmp = gfc_class_data_get (se.expr); - gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (stmp))); - - /* Set the fields of the target class variable. */ - stmp = gfc_conv_descriptor_data_get (stmp); + /* Coarray scalar component expressions can emerge from + the front end as array elements of the _data field. */ + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (stmp))) + stmp = gfc_conv_descriptor_data_get (stmp); dtmp = gfc_class_data_get (ctree); stmp = fold_convert (TREE_TYPE (dtmp), stmp); gfc_add_modify (&se.pre, dtmp, stmp); @@ -2172,6 +2173,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) dtmp = gfc_class_len_get (ctree); stmp = fold_convert (TREE_TYPE (dtmp), stmp); gfc_add_modify (&se.pre, dtmp, stmp); + need_len_assign = false; } se.expr = ctree; } @@ -2293,7 +2295,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) gfc_init_se (&se, NULL); if (e->symtree->n.sym->ts.type == BT_CHARACTER) { - /* Deferred strings are dealt with in the preceeding. */ + /* Deferred strings are dealt with in the preceding. */ gcc_assert (!e->symtree->n.sym->ts.deferred); tmp = e->symtree->n.sym->ts.u.cl->backend_decl; } @@ -4103,7 +4105,7 @@ gfc_trans_forall_loop (forall_info *forall_tmp, tree body, count, build_int_cst (TREE_TYPE (count), 0)); /* PR 83064 means that we cannot use annot_expr_parallel_kind until - the autoparallelizer can hande this. */ + the autoparallelizer can handle this. */ if (forall_tmp->do_concurrent) cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, build_int_cst (integer_type_node, @@ -6351,7 +6353,7 @@ gfc_trans_allocate (gfc_code * code) } /* Create a temp variable only for component refs to prevent having to go through the full deref-chain each time and to - simplfy computation of array properties. */ + simplify computation of array properties. */ temp_var_needed = TREE_CODE (se.expr) == COMPONENT_REF; } } @@ -6458,12 +6460,15 @@ gfc_trans_allocate (gfc_code * code) /* Deallocate any allocatable components in expressions that use a temporary object, i.e. are not a simple alias of to an EXPR_VARIABLE. E.g. temporaries of a function call need freeing of their components - here. */ + here. Explicit derived type allocation of class entities uses expr3 + to carry the default initializer. This must not be deallocated or + finalized. */ if ((code->expr3->ts.type == BT_DERIVED || code->expr3->ts.type == BT_CLASS) && (code->expr3->expr_type != EXPR_VARIABLE || temp_obj_created) && code->expr3->ts.u.derived->attr.alloc_comp - && !code->expr3->must_finalize) + && !code->expr3->must_finalize + && !code->ext.alloc.expr3_not_explicit) { tmp = gfc_deallocate_alloc_comp (code->expr3->ts.u.derived, expr3, code->expr3->rank); @@ -6623,7 +6628,7 @@ gfc_trans_allocate (gfc_code * code) && DECL_P (expr3) && DECL_ARTIFICIAL (expr3)) { /* Build a temporary symtree and symbol. Do not add it to the current - namespace to prevent accidently modifying a colliding + namespace to prevent accidentaly modifying a colliding symbol's as. */ newsym = XCNEW (gfc_symtree); /* The name of the symtree should be unique, because gfc_create_var () diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc index 9c9489a..d718f28 100644 --- a/gcc/fortran/trans-types.cc +++ b/gcc/fortran/trans-types.cc @@ -1374,7 +1374,7 @@ gfc_get_element_type (tree type) /* Returns true if the array sym does not require a descriptor. */ -int +bool gfc_is_nodesc_array (gfc_symbol * sym) { symbol_attribute *array_attr; @@ -2451,7 +2451,7 @@ gfc_add_field_to_struct (tree context, tree name, tree type, tree **chain) the two derived type symbols are "equal", as described in 4.4.2 and resolved by gfc_compare_derived_types. */ -int +bool gfc_copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to, bool from_gsym) { @@ -2940,7 +2940,7 @@ copy_derived_types: } -int +bool gfc_return_by_reference (gfc_symbol * sym) { if (!sym->attr.function) @@ -2962,6 +2962,8 @@ gfc_return_by_reference (gfc_symbol * sym) 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) return 1; @@ -3273,6 +3275,8 @@ arg_type_list_done: type = gfc_get_mixed_entry_union (sym->ns); else if (flag_f2c && sym->ts.type == BT_REAL && sym->ts.kind == gfc_default_real_kind + && !sym->attr.pointer + && !sym->attr.allocatable && !sym->attr.always_explicit) { /* Special case: f2c calling conventions require that (scalar) diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h index 2dc6923..d5746ca 100644 --- a/gcc/fortran/trans-types.h +++ b/gcc/fortran/trans-types.h @@ -88,7 +88,7 @@ tree gfc_get_character_type_len_for_eltype (tree, tree); tree gfc_sym_type (gfc_symbol *, bool is_bind_c_arg = false); tree gfc_get_cfi_type (int dimen, bool restricted); tree gfc_typenode_for_spec (gfc_typespec *, int c = 0); -int gfc_copy_dt_decls_ifequal (gfc_symbol *, gfc_symbol *, bool); +bool gfc_copy_dt_decls_ifequal (gfc_symbol *, gfc_symbol *, bool); tree gfc_get_function_type (gfc_symbol *, gfc_actual_arglist *args = NULL, const char *fnspec = NULL); @@ -109,10 +109,10 @@ tree gfc_add_field_to_struct (tree, tree, tree, tree **); void gfc_finish_type (tree); /* Some functions have an extra parameter for the return value. */ -int gfc_return_by_reference (gfc_symbol *); +bool gfc_return_by_reference (gfc_symbol *); /* Returns true if the array sym does not require a descriptor. */ -int gfc_is_nodesc_array (gfc_symbol *); +bool gfc_is_nodesc_array (gfc_symbol *); /* Return the DTYPE for an array. */ tree gfc_get_dtype_rank_type (int, tree); diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc index f7745ad..7ad85ae 100644 --- a/gcc/fortran/trans.cc +++ b/gcc/fortran/trans.cc @@ -332,7 +332,7 @@ gfc_build_addr_expr (tree type, tree t) else natural_type = build_pointer_type (base_type); - if (TREE_CODE (t) == INDIRECT_REF) + if (INDIRECT_REF_P (t)) { if (!type) type = natural_type; @@ -365,7 +365,7 @@ get_array_span (tree type, tree decl) if (TREE_CODE (decl) == COMPONENT_REF && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) return gfc_conv_descriptor_span_get (decl); - else if (TREE_CODE (decl) == INDIRECT_REF + else if (INDIRECT_REF_P (decl) && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) return gfc_conv_descriptor_span_get (decl); @@ -2453,6 +2453,8 @@ trans_code (gfc_code * code, tree cond) res = gfc_trans_dt_end (code); break; + case EXEC_OMP_ALLOCATE: + case EXEC_OMP_ALLOCATORS: case EXEC_OMP_ASSUME: case EXEC_OMP_ATOMIC: case EXEC_OMP_BARRIER: diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 1ad6d94..0c8d004 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -670,7 +670,7 @@ void gfc_restore_sym (gfc_symbol *, gfc_saved_var *); void gfc_set_decl_assembler_name (tree, tree); /* Returns true if a variable of specified size should go on the stack. */ -int gfc_can_put_var_on_stack (tree); +bool gfc_can_put_var_on_stack (tree); /* Set GFC_DECL_SCALAR_* on decl from sym if needed. */ void gfc_finish_decl_attrs (tree, symbol_attribute *); |