diff options
| author | Giuliano Belinassi <giuliano.belinassi@usp.br> | 2020-08-22 17:43:43 -0300 |
|---|---|---|
| committer | Giuliano Belinassi <giuliano.belinassi@usp.br> | 2020-08-22 17:43:43 -0300 |
| commit | a926878ddbd5a98b272c22171ce58663fc04c3e0 (patch) | |
| tree | 86af256e5d9a9c06263c00adc90e5fe348008c43 /gcc/fortran | |
| parent | 542730f087133690b47e036dfd43eb0db8a650ce (diff) | |
| parent | 07cbaed8ba7d1b6e4ab3a9f44175502a4e1ecdb1 (diff) | |
| download | gcc-devel/autopar_devel.zip gcc-devel/autopar_devel.tar.gz gcc-devel/autopar_devel.tar.bz2 | |
Merge branch 'autopar_rebase2' into autopar_develdevel/autopar_devel
Quickly commit changes in the rebase branch.
Diffstat (limited to 'gcc/fortran')
38 files changed, 3026 insertions, 668 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index f245cb4..f734d3cb 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,898 @@ +2020-08-13 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/93671 + * trans-array.c (structure_alloc_comps): Keep caf-mode when applying to + components; get the caf_token correctly for allocated scalar components. + +2020-08-13 Matthew Krupcale <mkrupcale@matthewkrupcale.com> + + PR fortran/96595 + * invoke.texi: Fix typos. + +2020-08-12 Tobias Burnus <tobias@codesourcery.com> + + * gfortran.h: Add OMP_LIST_NONTEMPORAL. + * dump-parse-tree.c (show_omp_clauses): Dump it + * openmp.c (enum omp_mask1): Add OMP_CLAUSE_NOTEMPORAL. + (OMP_SIMD_CLAUSES): Add it. + (gfc_match_omp_clauses): Match nontemporal clause. + * trans-openmp.c (gfc_trans_omp_clauses): Process + nontemporal clause. + +2020-08-10 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/96556 + * frontend-passes.c (doloop_contained_function_call): + Do not dereference a NULL pointer for value.function.esym. + +2020-08-10 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/96312 + * trans-expr.c (fcncall_realloc_result): Only compare shapes if + lhs was allocated.. + +2020-08-10 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/96102 + * resolve.c (check_host_association): Replace the gcc_assert + with an error for internal procedures. + +2020-08-05 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/96469 + * frontend-passes.c (doloop_contained_function_call): New + function. + (doloop_contained_procedure_code): New function. + (CHECK_INQ): Macro for inquire checks. + (doloop_code): Invoke doloop_contained_procedure_code and + doloop_contained_function_call if appropriate. + (do_intent): Likewise. + +2020-08-04 Tobias Burnus <tobias@codesourcery.com> + + * openmp.c (resolve_omp_do): Detect not perfectly + nested loop with innermost collapse. + +2020-08-04 Tobias Burnus <tobias@codesourcery.com> + + * trans-openmp.c (gfc_trans_omp_do): Fix 'lastprivate(conditional:'. + +2020-08-03 Julian Brown <julian@codesourcery.com> + Thomas Schwinge <thomas@codesourcery.com> + + * trans-openmp.c (gfc_trans_omp_clauses): Don't create present/release + mappings for array descriptors. + +2020-08-03 Martin Jambor <mjambor@suse.cz> + + * f95-lang.c (gfc_init_builtin_functions): Remove processing of + hsa-builtins.def. + +2020-08-03 Tobias Burnus <tobias@codesourcery.com> + + * gfc-internals.texi: Fix typos. + * gfortran.texi: Likewise. + * intrinsic.texi: Likewise. + * invoke.texi: Likewise. + +2020-08-02 Paul Thomas <pault@gcc.gnu.org> + + PR target/96320 + * interface.c (gfc_check_dummy_characteristics): If a module + procedure arrives with assumed shape in the interface and + deferred shape in the procedure itself, update the latter and + copy the lower bounds. + +2020-08-02 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/96325 + * primary.c (gfc_match_varspec): In the case that a component + reference is added to an intrinsic type component, emit the + error message in this function. + +2020-07-29 Tobias Burnus <tobias@codesourcery.com> + + * dump-parse-tree.c (show_omp_clauses): Handle order(concurrent). + * gfortran.h (struct gfc_omp_clauses): Add order_concurrent. + * openmp.c (enum omp_mask1, OMP_DO_CLAUSES, OMP_SIMD_CLAUSES): + Add OMP_CLAUSE_ORDER. + * trans-openmp.c (gfc_trans_omp_clauses, gfc_split_omp_clauses): + Handle order(concurrent) clause. + +2020-07-29 Tobias Burnus <tobias@codesourcery.com> + + * openmp.c (resolve_omp_clauses): Permit 'omp target data' without + map if use_device_{addr,ptr} is present. + +2020-07-29 Mark Eggleston <markeggleston@gcc.gnu.org> + + PR fortran/96319 + * intrinsic.c (gfc_convert_type_warn): Add check for + LOGICAL type so that warnings are not output. + +2020-07-29 Tobias Burnus <tobias@codesourcery.com> + + * module.c (mio_symbol_attribute): Fix indent of previous + commit. + +2020-07-29 Mark Eggleston <markeggleston@gcc.gnu.org> + + PR fortran/53298 + * trans-array.c (gfc_walk_array_ref): If ref->ss.end is set + call gfc_get_scalar_ss. + +2020-07-29 Tobias Burnus <tobias@codesourcery.com> + + * gfortran.h (enum gfc_statement): Add ST_OMP_REQUIRES. + (enum gfc_omp_requires_kind): New. + (enum gfc_omp_atomic_op): Add GFC_OMP_ATOMIC_ACQ_REL. + (struct gfc_namespace): Add omp_requires and omp_target_seen. + (gfc_omp_requires_add_clause, + (gfc_check_omp_requires): New. + * match.h (gfc_match_omp_requires): New. + * module.c (enum ab_attribute, attr_bits): Add omp requires clauses. + (mio_symbol_attribute): Read/write them. + * openmp.c (gfc_check_omp_requires, (gfc_omp_requires_add_clause, + gfc_match_omp_requires): New. + (gfc_match_omp_oacc_atomic): Use requires's default mem-order. + * parse.c (decode_omp_directive): Match requires, set omp_target_seen. + (gfc_ascii_statement): Handle ST_OMP_REQUIRES. + * trans-openmp.c (gfc_trans_omp_atomic): Handle GFC_OMP_ATOMIC_ACQ_REL. + +2020-07-27 Tobias Burnus <tobias@codesourcery.com> + + * openmp.c (gfc_resolve_omp_directive): Remove NULL check + for clauses in EXEC_OMP_CRITICAL as it no longer can be NULL. + +2020-07-23 Tobias Burnus <tobias@codesourcery.com> + + * gfortran.h (gfc_omp_namelist): Add lastprivate_conditional. + * openmp.c (gfc_match_omp_clauses): Handle 'conditional:' + modifier of 'lastprivate'. + * trans-openmp.c (gfc_omp_clause_default_ctor): Don't assert + on OMP_CLAUSE__CONDTEMP_ and other OMP_*TEMP_. + (gfc_trans_omp_variable_list): Handle lastprivate_conditional. + +2020-07-23 Tobias Burnus <tobias@codesourcery.com> + + * intrinsic.texi (OMP_LIB_KINDS): Add omp_depend_kind. + +2020-07-23 Tobias Burnus <tobias@codesourcery.com> + + * gfortran.texi (Standards): Update URL; state that OpenMP 4.5 + is supported and 5.0 is partially. + * intrinsic.texi (OpenMP Modules): Refer also to OpenMP 5.0; + (OMP_LIB): Add missing derived type and new named constants. + +2020-07-22 Tobias Burnus <tobias@codesourcery.com> + + * gfortran.h (enum gfc_omp_if_kind): Add OMP_IF_CANCEL and OMP_IF_SIMD. + * openmp.c (OMP_SIMD_CLAUSES): Add OMP_CLAUSE_IF. + (gfc_match_omp_clauses, resolve_omp_clauses): Handle 'if (simd/cancel:'. + * dump-parse-tree.c (show_omp_clauses): Likewise. + * trans-openmp.c (gfc_trans_omp_clauses, gfc_trans_omp_cancel, + (gfc_split_omp_clauses): Likewise. + +2020-07-22 Tobias Burnus <tobias@codesourcery.com> + + * openmp.c (gfc_match_omp_critical): Fix handling hints; permit + hint clause without named critical. + (resolve_omp_clauses): Require nonnegative constant integer + for the hint clause. + (gfc_resolve_omp_directive): Check for no name but + nonzero value for hint clause. + * parse.c (parse_omp_structured_block): Fix same-name check + for critical. + * trans-openmp.c (gfc_trans_omp_critical): Handle hint clause properly. + +2020-07-21 Harald Anlauf <anlauf@gmx.de> + + PR fortran/89574 + * trans-decl.c (gfc_get_extern_function_decl): Check whether a + symbol belongs to a different module. + +2020-07-19 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/96220 + * dump-parse-tree.c (get_c_type_name): Always use the entries from + c_interop_kinds_table to find the correct C type. + +2020-07-19 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/96018 + * frontend-passes.c (gfc_check_externals): Adjust formatting. + (implicit_pure_call): New function. + (implicit_pure_expr): New function. + (gfc_fix_implicit_pure): New function. + * gfortran.h (gfc_fix_implicit_pure): New prototype. + * parse.c (translate_all_program_units): Call gfc_fix_implicit_pure. + +2020-07-18 David Edelsohn <dje.gcc@gmail.com> + + * check.c (gfc_invalid_boz): Mark hint for translation using _(). + +2020-07-16 Julian Brown <julian@codesourcery.com> + Thomas Schwinge <thomas@codesourcery.com> + + * trans-openmp.c (gfc_trans_omp_clauses): Rework OpenACC + attach/detach handling for arrays with descriptors. + +2020-07-14 Steven G. Kargl <kargl@gcc.gnu.org> + Mark Eggleston <markeggleston@gcc.gnu.org> + + PR fortran/95612 + * expr.c (gfc_check_pointer_assigb): Output an error if + rvalue is a zero sized array or output an error if rvalue + doesn't have a symbol tree. + +2020-07-14 Tobias Burnus <tobias@codesourcery.com> + + * openmp.c (gfc_match_omp_clauses): Match also derived-type + component refs in OMP_CLAUSE_MAP. + (resolve_omp_clauses): Resolve those. + * trans-openmp.c (gfc_trans_omp_array_section, gfc_trans_omp_clauses): + Handle OpenMP structure-element mapping. + (gfc_trans_oacc_construct, gfc_trans_oacc_executable_directive, + (gfc_trans_oacc_combined_directive, gfc_trans_oacc_declare): Update + add openacc=true in gfc_trans_omp_clauses call. + +2020-07-14 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/67311 + * trans-openmp.c (gfc_has_alloc_comps): Return false also for + pointers to arrays. + +2020-07-14 Steven G. Kargl <kargl@gcc.gnu.org> + Mark Eggleston <markeggleston@gcc.gnu.org> + + PR fortran/96038 + * decl.c (add_init_expr_sym): For a symbol that is a + parameter accept an initialisation if it does not have a + value otherwise output a error and reject. + +2020-07-13 Mark Eggleston <markeggleston@gcc.gnu.org> + + PR fortran/45337 + * resolve.c (resolve_fl_variable): Remove type and intent + checks from the check for dummy. + +2020-07-13 Steven G. Kargl <kargl@gcc.gnu.org> + Mark Eggleston <markeggleston@gcc.gnu.org> + + PR fortran/95981 + * check.c (dim_rank_check): Allow NULL references in call to + gfc_find_array_ref and return false if no reference is found. + +2020-07-11 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/96073 + * frontend-passes.c (check_externals_procedure): Add locus + information for new_sym. + * interface.c (gfc_check_dummy_characteristics): Do not warn + about INTENT for artificially generated variables. + +2020-07-10 Harald Anlauf <anlauf@gmx.de> + + PR fortran/95980 + * class.c (gfc_add_component_ref, gfc_build_class_symbol): + Add checks for NULL pointer dereference. + * primary.c (gfc_variable_attr): Likewise. + * resolve.c (resolve_variable, resolve_assoc_var) + (resolve_fl_var_and_proc, resolve_fl_variable_derived) + (resolve_symbol): Likewise. + +2020-07-10 Harald Anlauf <anlauf@gmx.de> + + PR fortran/96086 + * match.c (gfc_match_select_rank): Catch NULL pointer + dereference. + * resolve.c (resolve_assoc_var): Catch NULL pointer dereference + that may occur after an illegal declaration. + +2020-07-09 Julian Brown <julian@codesourcery.com> + + * trans-openmp.c (gfc_trans_omp_clauses): Use 'inner' not 'decl' for + derived type members which themselves have derived types. + +2020-07-08 Harald Anlauf <anlauf@gmx.de> + + PR fortran/96085 + * resolve.c (gfc_resolve_code): Check whether assign target is a + parameter. + +2020-07-06 Harald Anlauf <anlauf@gmx.de> + + PR fortran/95980 + * match.c (copy_ts_from_selector_to_associate, build_class_sym): + Distinguish between unlimited polymorphic and ordinary variables + to avoid NULL pointer dereference. + * resolve.c (resolve_select_type): + Distinguish between unlimited polymorphic and ordinary variables + to avoid NULL pointer dereference. + +2020-07-06 Harald Anlauf <anlauf@gmx.de> + + PR fortran/95709 + * resolve.c (gfc_resolve_code): Check for valid arguments to + assigned GOTO. + +2020-07-05 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/27318 + * frontend-passes.c (check_against_globals): New function. + (gfc_check_externals): Split; also invoke check_against_globals + via gfc_traverse_ns. + (gfc_check_externals0): Recursive part formerly in + gfc_check_externals. + * resolve.c (resolve_global_procedure): Set sym->error on + interface mismatch. + * symbol.c (ambiguous_symbol): Check for, and set sym->error. + +2020-07-02 Harald Anlauf <anlauf@gmx.de> + + PR fortran/93423 + * resolve.c (resolve_symbol): Avoid NULL pointer dereference. + +2020-07-02 Harald Anlauf <anlauf@gmx.de> + + PR fortran/93337 + * class.c (gfc_find_derived_vtab): Punt if name is not set. + +2020-07-02 Mark Eggleston <markeggleston@gcc.gnu.org> + + PR fortran/52279 + * check.c (gfc_invalid_boz): Change array declaration for + hint into a pointer. + +2020-07-02 Steven G. Kargl <kargl@gcc.gnu.org> + Mark Eggleston <markeggleston@gcc.gnu.org> + + PR fortran/95584 + * interface.c (generic_correspondence): Only use the pointer + to a symbol if exists. + +2020-07-01 David Edelsohn <dje.gcc@gmail.com> + + * check.c (gfc_invalid_boz): Fix bootstrap. Revert + Mark hint for translation using _(). + +2020-07-01 Mark Eggleston <markeggleston@gcc.gnu.org> + + PR fortran/52279 + * arith.c (reduce_binary_aa): Mark for translation the string + parameter to gfc_check_conformance with G_(). + * check.c (gfc_invalid_boz): Mark hint for translation using + _(). (gfc_check_achar): Mark for translation the message + parameter to gfc_invalid_boz using G_(). (gfc_check_char): + Mark for translation the message parameter to gfc_invalid_boz + using G_(). (gfc_check_complex): Mark for translation the + message parameter to gfc_invalid_boz using G_(). + (gfc_check_float): Mark for translation the message + parameter to gfc_invalid_boz using G_(). (check_rest): Mark + for translation the string parameter to gfc_check_conformance + with _(). (gfc_check_minloc_maxloc): Mark for translation + the string parameter to gfc_check_conformance with _(). + (gfc_check_findloc): Mark for translation the string parameter + to gfc_check_conformance with _(). (check_reduction): Mark + for translation the string parameter to gfc_check_conformance + with _(). (gfc_check_pack): Mark for translation the string + parameter to gfc_check_conformance with _(). + * decl.c (match_old_style_init): Mark for translation the + message parameter to gfc_invalid_boz using G_(). + * expr.c (gfc_check_assign): Mark for translation the string + parameter to gfc_check_conformance with _(). + * intrinsic.c (check_specific): Mark for translation the string + parameter to gfc_check_conformance with _(). + (gfc_check_intrinsic_standard): Mark symstd_msg strings for + translation using G_(). No need to mark symstd_msg for + translation in call to gfc_warning or when setting symstd. + * io.c (check_open_constraints): Mark strings for translation + using G_() in all calls to warn_or_error. (match_io_element): + Mark for translation the message parameter to gfc_invalid_boz + using G_(). + * primary.c (match_boz_constant): Mark for translation the + message parameter to gfc_invalid_boz using G_(). + * resolve.c (resolve_elemental_actual): Mark for translation + the string parameter to gfc_check_conformance with _(). + (resolve_operator): Mark for translation the string parameter + to gfc_check_conformance with _(). Mark translation strings + assigned to msg using G_() for use in a call to cfg_warning. + +2020-07-01 Steven G. Kargl <kargl@gcc.gnu.org> + Mark Eggleston <markeggleston@gcc.gnu.org> + + PR fortran/95446 + * resolve.c (resolve_elemental_actual): Add code to check for + non-optional argument of the same rank. Revise warning message + to refer to the Fortran 2018 standard. + +2020-07-01 Steven G. Kargl <kargl@gcc.gnu.org> + Mark Eggleston <markeggleston@gcc.gnu.org> + + PR fortran/95829 + * decl.c (gfc_match_decl_type_spec): Compare with "* ) " instead + of "*)". + +2020-06-30 Harald Anlauf <anlauf@gmx.de> + + PR fortran/88379 + * resolve.c (resolve_assoc_var): Avoid NULL pointer dereference. + +2020-06-30 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/95355 + * gfortran.h (gfc_typename): Add optional argument for_hash. + * misc.c (gfc_typename): When for_hash is true, just retur + CHARACTER(kind). + * class.c (gfc_intrinsic_hash_value): Call gfc_typename with + for_hash = true. + +2020-06-29 Harald Anlauf <anlauf@gmx.de> + + PR fortran/95978 + * decl.c (gfc_match_data): Avoid NULL pointer dereference. + +2020-06-29 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/95743 + * trans-decl.c (gfc_generate_function_code): Do not generate + recursion check for compiler-generated procedures. + +2020-06-29 Harald Anlauf <anlauf@gmx.de> + + PR fortran/71706 + * trans-stmt.c (gfc_trans_sync): Do proper kind conversion in + bounds-checking code. + +2020-06-28 Harald Anlauf <anlauf@gmx.de> + + PR fortran/95340 + * match.c (gfc_match_select_rank): Do not dereference NULL pointer. + +2020-06-28 Harald Anlauf <anlauf@gmx.de> + + PR fortran/95880 + * symbol.c (gfc_add_type): If sym->ns->proc_name is set, use it, + otherwise fall back to sym->name. + +2020-06-27 Harald Anlauf <anlauf@gmx.de> + + PR fortran/95881 + * resolve.c (resolve_symbol): Avoid NULL pointer dereference. + +2020-06-25 Harald Anlauf <anlauf@gmx.de> + + PR fortran/95828 + * match.c (select_rank_set_tmp): Enlarge internal buffer used in + generating a mangled name. + * resolve.c (resolve_select_rank): Likewise. + +2020-06-25 Harald Anlauf <anlauf@gmx.de> + + PR fortran/95826 + * decl.c (gfc_match_decl_type_spec): Replace a fixed size + buffer by a pointer and reallocate if necessary. + +2020-06-25 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/95837 + * resolve.c (gfc_resolve_substring_charlen): Remove + bogus ts.kind setting for the expression. + +2020-06-25 Tobias Burnus <tobias@codesourcery.com> + Kwok Cheung Yeung <kcy@codesourery.com> + + PR fortran/95869 + * trans-openmp.c (gfc_trans_omp_target): Use correct scoping block. + +2020-06-25 Kwok Cheung Yeung <kcy@codesourcery.com> + + * trans-openmp.c (gfc_split_omp_clauses): Add if clause + to target and simd sub-constructs. + +2020-06-24 Harald Anlauf <anlauf@gmx.de> + + PR fortran/95827 + * iresolve.c (gfc_get_string): Enlarge internal buffer used in + generating the mangled name. + +2020-06-23 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/95812 + * dependency.c (ref_same_as_full_array): Handle case of AR_FULL + vs. AR_FULL. + +2020-06-23 Steven G. Kargl <kargl@gcc.gnu.org> + Mark Eggleston <markeggleston@gcc.gnu.org> + + PR fortran/95586 + * decl.c (gfc_match_implicit): Only perform else branch if + the type spect is not BT_DERIVED. + +2020-06-22 Steven G. Kargl <kargl@gcc.gnu.org> + Mark Eggleston <markeggleston@gcc.gnu.org> + + PR fortran/95708 + * intrinsic.c (add_functions): Replace CLASS_INQUIRY with + CLASS_TRANSFORMATIONAL for intrinsic num_images. + (make_generic): Replace ACTUAL_NO with ACTUAL_YES for + intrinsic team_number. + * resolve.c (resolve_fl_procedure): Check pointer ts.u.derived + exists before using it. + +2020-06-22 Steven G. Kargl <kargl@gcc.gnu.org> + Mark Eggleston <markeggleston@gcc.gnu.org> + + PR fortran/95585 + * check.c (gfc_check_reshape): Add check for a value when + the symbol has an attribute flavor FL_PARAMETER. + +2020-06-22 Mark Eggleston <markeggleston@gcc.gnu.org> + + PR fortran/42693 + * arith.c (gfc_arith_error): Enclose strings in G_() instead + of _(). + +2020-06-20 Harald Anlauf <anlauf@gmx.de> + + PR fortran/95707 + * gfortran.h (gfc_common_head): Enlarge buffer. + * trans-common.c (gfc_sym_mangled_common_id): Enlarge temporary + buffers, and add check on length on mangled name to prevent + overflow. + +2020-06-20 Harald Anlauf <anlauf@gmx.de> + + PR fortran/95688 + * iresolve.c (gfc_get_string): Enlarge static buffer size. + +2020-06-20 Harald Anlauf <anlauf@gmx.de> + + PR fortran/95687 + * class.c (get_unique_type_string): Return a string with dynamic + length. + (get_unique_hashed_string, gfc_hash_value): Use dynamic result + from get_unique_type_string instead of static buffer. + +2020-06-20 Harald Anlauf <anlauf@gmx.de> + + PR fortran/95689 + * interface.c (check_sym_interfaces): Enlarge temporary buffer, + and add check on length on mangled name to prevent overflow. + +2020-06-20 Harald Anlauf <anlauf@gmx.de> + + PR fortran/95587 + * match.c (gfc_match_equivalence): Check constraints on + EQUIVALENCE objects also for CLASS variables. + +2020-06-18 Tobias Burnus <tobias@codesourcery.com> + + * openmp.c (resolve_omp_clauses): Reject vars with + allocatable components in OpenMP map clauses. + +2020-06-16 Tobias Burnus <tobias@codesourcery.com> + + * parse.c (decode_oacc_directive): Permit 'acc routine' also + inside pure procedures. + * openmp.c (gfc_match_oacc_routine): Inside pure procedures + do not permit gang, worker or vector clauses. + +2020-06-16 Tobias Burnus <tobias@codesourcery.com> + + * parse.c (decode_omp_directive): Remove "or ELEMENTAL" + from "in PURE" error message also for -fopenmp-simd. + +2020-06-16 Tobias Burnus <tobias@codesourcery.com> + + * parse.c (decode_omp_directive): Remove "or ELEMENTAL" + from "in PURE" error message. + +2020-06-14 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/42122 + * dump-parse-tree.c (gfc_dump_global_symbols): If the symroot is + empty, just output "empty". + +2020-06-14 Harald Anlauf <anlauf@gmx.de> + + PR fortran/95088 + * class.c (get_unique_type_string): Replace use of fixed size + buffer by internally passing a pointer to strings. + +2020-06-14 Thomas Koenig <tkoenig@gcc.gnu.org> + + * check.c (gfc_check_random_seed): Always use locations + from get and put arguments for error messages. + +2020-06-14 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/94109 + * class.c (finalize_component): Return early if finalization has + already happened for expression and component within namespace. + * gfortran.h (gfc_was_finalized): New type. + (gfc_namespace): Add member was_finalzed. + (gfc_expr): Remove finalized. + * symbol.c (gfc_free_namespace): Free was_finalized. + +2020-06-11 Harald Anlauf <anlauf@gmx.de> + Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/95611 + * decl.c (access_attr_decl): Use correct symbol in error message. + +2020-06-11 Steven G. Kargl <kargl@gcc.gnu.org> + Harald Anlauf <anlauf@gmx.de> + + PR fortran/95544 + * check.c (invalid_null_arg): Rename to gfc_invalid_null_arg. + (gfc_check_associated, gfc_check_kind, gfc_check_merge) + (gfc_check_shape, gfc_check_size, gfc_check_spread) + (gfc_check_transfer): Adjust. + (gfc_check_len_lentrim, gfc_check_trim): Check for NULL() argument. + * gfortran.h: Declare gfc_invalid_null_arg (). + * intrinsic.c (check_arglist): Check for NULL() argument. + +2020-06-11 Harald Anlauf <anlauf@gmx.de> + + PR fortran/95503 + * expr.c (gfc_check_pointer_assign): Skip contiguity check of rhs + of pointer assignment if lhs cannot be simply contiguous. + +2020-06-11 José Rui Faustino de Sousa <jrfsousa@gmail.com> + + PR fortran/95331 + * trans-array.c (gfc_conv_array_ref): For class array dummy + arguments use the transformed descriptor in sym->backend_decl + instead of the original descriptor. + +2020-06-11 José Rui Faustino de Sousa <jrfsousa@gmail.com> + + PR fortran/52351 + PR fortran/85868 + * trans-array.c (gfc_conv_expr_descriptor): Enable the + creation of a new descriptor with the correct one based + indexing for array sections. Rework array descriptor + indexing offset calculation. + +2020-06-11 José Rui Faustino de Sousa <jrfsousa@gmail.com> + + PR fortran/94022 + * trans-expr.c (gfc_conv_procedure_call): In the case of + assumed-size arrays ensure that the reference is to a full array. + +2020-06-07 Harald Anlauf <anlauf@gmx.de> + + PR fortran/95091 + * class.c (gfc_hash_value): Add cast. + +2020-06-07 Harald Anlauf <anlauf@gmx.de> + + PR fortran/95091 + * class.c (get_unique_type_string, gfc_hash_value): Enlarge + buffers, and check whether the strings returned by + get_unique_type_string() fit. + +2020-06-05 Harald Anlauf <anlauf@gmx.de> + + PR fortran/95530 + PR fortran/95537 + * decl.c (gfc_match_decl_type_spec): Enlarge buffer, and enhance + string copy to detect buffer overflow. + * gfortran.h (gfc_common_head): Enlarge buffer. + * trans-common.c (finish_equivalences): Enhance string copy to + detect buffer overflow. + +2020-06-05 Tom Tromey <tromey@adacore.com> + + PR fortran/95509 + * misc.c (gfc_closest_fuzzy_match): Update cutoff value + computation. + +2020-06-04 Steven G. Kargl <kargl@gcc.gnu.org> + Harald Anlauf <anlauf@gmx.de> + + PR fortran/95500 + * trans-expr.c (gfc_conv_expr_reference): Do not dereference NULL + pointer. + +2020-06-03 José Rui Faustino de Sousa <jrfsousa@gmail.com> + + PR fortran/95214 + PR fortran/66833 + PR fortran/67938 + * trans-expr.c (gfc_maybe_dereference_var): Add assumed-rank to + character dummy arguments list of possible attributes. + +2020-06-03 Tobias Burnus <tobias@codesourcery.com> + + * f95-lang.c (LANG_HOOKS_OMP_PREDETERMINED_MAPPING): Redefine. + * trans-openmp.c (gfc_omp_predetermined_mapping): New. + * trans.h (gfc_omp_predetermined_mapping): Declare. + +2020-05-31 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/94361 + * class.c (finalize_component): Use expr->finalized instead of + comp->finalized. + * gfortran.h (gfc_component): Remove finalized member. + (gfc_expr): Add it here instead. + +2020-05-30 Harald Anlauf <anlauf@gmx.de> + + PR fortran/95373 + * primary.c (is_inquiry_ref): Move validity check of inquiry + references against selected Fortran standard from here... + (gfc_match_varspec) ...to here. + +2020-05-30 Harald Anlauf <anlauf@gmx.de> + + PR fortran/95090 + * class.c (get_unique_type_string): Use buffer overrun check. + +2020-05-29 Harald Anlauf <anlauf@gmx.de> + + PR fortran/95090 + * class.c (get_unique_type_string): Enlarge temporary for + name-mangling. Use strncpy to prevent buffer overrun. + (get_unique_hashed_string): Enlarge temporary. + (gfc_hash_value): Enlarge temporary for name-mangling. + +2020-05-28 Harald Anlauf <anlauf@gmx.de> + + PR fortran/95373 + * primary.c (is_inquiry_ref): Check validity of inquiry + references against selected Fortran standard. + +2020-05-28 Steven G. Kargl <kargl@gcc.gnu.org> + Mark Eggleston <markeggleston@gcc.gnu.org> + Mark Eggleston <markeggleston@gcc.gnu.org> + + PR fortran/94397 + * match.c (gfc_match_type_spec): New variable ok initialised + to true. Set ok with the return value of gfc_reduce_init_expr + called only if the expression is not EXPR_CONSTANT and is not + EXPR_VARIABLE. Add !ok to the check for type not being integer + or the rank being greater than zero. + +2020-05-27 Harald Anlauf <anlauf@gmx.de> + + PR fortran/95090 + * iresolve.c (gfc_get_string): Enlarge temporary for + name-mangling. + +2020-05-27 Tobias Burnus <tobias@codesourcery.com> + Mark Eggleston <markeggleston@gnu.gcc.org> + + PR fortran/50392 + * trans-decl.c (gfc_get_symbol_decl): Remove unnecessary block + delimiters. Add auxiliary variables if a label is assigned to + a return variable. (gfc_gat_fake_result): If the symbol has an + assign attribute set declaration from the symbol's backend + declaration. + +2020-05-26 Harald Anlauf <anlauf@gmx.de> + + PR fortran/95089 + * trans-types.c (gfc_get_derived_type): Enlarge temporary to hold + mangled name "_caf_symbol". + +2020-05-26 Alexandre Oliva <oliva@adacore.com> + + * options.c (gfc_get_option_string): Drop auxbase, add + dumpbase_ext. + +2020-05-24 Harald Anlauf <anlauf@gmx.de> + + PR fortran/95106 + * trans-common.c (gfc_sym_mangled_common_id): Enlarge temporaries + for name-mangling. + +2020-05-23 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR libfortran/95191 + * libgfortran.h (libgfortran_error_codes): Add + LIBERROR_BAD_WAIT_ID. + +2020-05-20 Mark Eggleston <markeggleston@gcc.gnu.org> + + PR fortran/39695 + * resolve.c (resolve_fl_procedure): Set name depending on + whether the result attribute is set. For PROCEDURE/RESULT + conflict use the name in sym->ns->proc_name->name. + * symbol.c (gfc_add_type): Add check for function and result + attributes use sym->ns->proc_name->name if both are set. + Where the symbol cannot have a type use the name in + sym->ns->proc_name->name. + +2020-05-18 Harald Anlauf <anlauf@gmx.de> + + PR fortran/95053 + * arith.c (gfc_divide): Revert hunk introduced by patch for + PR93499. + * decl.c (variable_decl): Generate error for array shape not being + an INTEGER constant. + (gfc_get_pdt_instance): Generate error if KIND or LEN expressions + in declaration of a PDT instance do not simplify to INTEGER + constants. + +2020-05-15 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/94690 + * openmp.c (resolve_omp_do): Permit more clauses for SIMD + iteration variables. + +2020-05-14 Jakub Jelinek <jakub@redhat.com> + + * trans-openmp.c: Include function.h. + (gfc_trans_omp_target): Set cfun->has_omp_target. + +2020-05-13 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/93497 + * decl.c (char_len_param_value): Check whether character + length expression is of type EXPR_OP and if so simplify it. + * resolve.c (resolve_charlen): Reject length if it has a + rank. + +2020-05-13 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/94690 + * openmp.c (OMP_DISTRIBUTE_CLAUSES): Add OMP_CLAUSE_LASTPRIVATE. + (gfc_resolve_do_iterator): Skip the private handling for SIMD as + that is handled by ME code. + * trans-openmp.c (gfc_trans_omp_do): Don't add private/lastprivate + for dovar_found == 0, unless !simple. + +2020-05-11 Harald Anlauf <anlauf@gmx.de> + + PR fortran/95053 + * arith.c (gfc_divide): Do not error out if operand 2 is + non-numeric. Defer checks to later stage. + +2020-05-11 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/94672 + * trans.h (gfc_conv_expr_present): Add use_saved_decl=false argument. + * trans-expr.c (gfc_conv_expr_present): Likewise; use DECL directly + and only if use_saved_decl is true, use the actual PARAM_DECL arg (saved + descriptor). + * trans-array.c (gfc_trans_dummy_array_bias): Set local 'arg.0' + variable to NULL if 'arg' is not present. + * trans-openmp.c (gfc_omp_check_optional_argument): Simplify by checking + 'arg.0' instead of the true PARM_DECL. + (gfc_omp_finish_clause): Remove setting 'arg.0' to NULL. + +2020-05-11 Janus Weil <janus@gcc.gnu.org> + Dominique d'Humieres <dominiq@lps.ens.fr> + + PR fortran/59107 + * gfortran.h: Rename field resolved as resolve_symbol_called + and assign two 2 bits instead of 1. + * interface.c (check_dtio_interface1): Use new field name. + (gfc_find_typebound_dtio_proc): Use new field name. + * resolve.c (gfc_resolve_intrinsic): Replace check of the formal + field with resolve_symbol_called is at least 2, if it is not + set the field to 2. (resolve_typebound_procedure): Use new field + name. (resolve_symbol): Use new field name and check whether it + is at least 1, if it is not set the field to 1. + +2020-05-10 Harald Anlauf <anlauf@gmx.de> + + PR fortran/93499 + * arith.c (gfc_divide): Catch division by zero. + (eval_intrinsic_f3): Safeguard for NULL operands. + +2020-05-05 Steve Kargl <kargl@gcc.gnu.org> + Harald Anlauf <anlauf@gmx.de> + + PR fortran/93366 + * check.c (gfc_check_associated, invalid_null_arg): Factorize + check for presence of invalid NULL() argument. + (gfc_check_kind, gfc_check_merge, gfc_check_shape) + (gfc_check_sizeof, gfc_check_spread, gfc_check_transfer): Use this + check for presence of invalid NULL() arguments. + 2020-04-29 Stefan Schulze Frielinghaus <stefansf@linux.ibm.com> PR fortran/94769 diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c index 422ef40..c4c1041 100644 --- a/gcc/fortran/arith.c +++ b/gcc/fortran/arith.c @@ -94,30 +94,29 @@ gfc_arith_error (arith code) switch (code) { case ARITH_OK: - p = _("Arithmetic OK at %L"); + p = G_("Arithmetic OK at %L"); break; case ARITH_OVERFLOW: - p = _("Arithmetic overflow at %L"); + p = G_("Arithmetic overflow at %L"); break; case ARITH_UNDERFLOW: - p = _("Arithmetic underflow at %L"); + p = G_("Arithmetic underflow at %L"); break; case ARITH_NAN: - p = _("Arithmetic NaN at %L"); + p = G_("Arithmetic NaN at %L"); break; case ARITH_DIV0: - p = _("Division by zero at %L"); + p = G_("Division by zero at %L"); break; case ARITH_INCOMMENSURATE: - p = _("Array operands are incommensurate at %L"); + p = G_("Array operands are incommensurate at %L"); break; case ARITH_ASYMMETRIC: - p = - _("Integer outside symmetric range implied by Standard Fortran at %L"); + p = G_("Integer outside symmetric range implied by Standard Fortran" + " at %L"); break; case ARITH_WRONGCONCAT: - p = - _("Illegal type in character concatenation at %L"); + p = G_("Illegal type in character concatenation at %L"); break; default: @@ -1388,7 +1387,7 @@ reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), gfc_expr *r; arith rc = ARITH_OK; - if (!gfc_check_conformance (op1, op2, "elemental binary operation")) + if (!gfc_check_conformance (op1, op2, _("elemental binary operation"))) return ARITH_INCOMMENSURATE; head = gfc_constructor_copy (op1->value.constructor); @@ -1746,6 +1745,9 @@ eval_intrinsic_f3 (gfc_intrinsic_op op, gfc_expr *result; eval_f f; + if (!op1 && !op2) + return NULL; + result = reduce_binary0 (op1, op2); if (result != NULL) return eval_type_intrinsic0(op, result); diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index cdabbf5..74e5e44 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -67,7 +67,7 @@ gfc_invalid_boz (const char *msg, locus *loc) return false; } - const char hint[] = " [see %<-fno-allow-invalid-boz%>]"; + const char *hint = _(" [see %<-fno-allow-invalid-boz%>]"); size_t len = strlen (msg) + strlen (hint) + 1; char *msg2 = (char *) alloca (len); strcpy (msg2, msg); @@ -1142,7 +1142,9 @@ dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed) if (array->expr_type == EXPR_VARIABLE) { - ar = gfc_find_array_ref (array); + ar = gfc_find_array_ref (array, true); + if (!ar) + return false; if (ar->as->type == AS_ASSUMED_SIZE && !allow_assumed && ar->type != AR_ELEMENT @@ -1313,8 +1315,8 @@ gfc_check_achar (gfc_expr *a, gfc_expr *kind) { if (a->ts.type == BT_BOZ) { - if (gfc_invalid_boz ("BOZ literal constant at %L cannot appear in " - "ACHAR intrinsic subprogram", &a->where)) + if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in " + "ACHAR intrinsic subprogram"), &a->where)) return false; if (!gfc_boz2int (a, gfc_default_integer_kind)) @@ -1431,6 +1433,18 @@ gfc_check_x_yd (gfc_expr *x, gfc_expr *y) return true; } +bool +gfc_invalid_null_arg (gfc_expr *x) +{ + if (x->expr_type == EXPR_NULL) + { + gfc_error ("NULL at %L is not permitted as actual argument " + "to %qs intrinsic function", &x->where, + gfc_current_intrinsic); + return true; + } + return false; +} bool gfc_check_associated (gfc_expr *pointer, gfc_expr *target) @@ -1438,12 +1452,9 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target) symbol_attribute attr1, attr2; int i; bool t; - locus *where; - where = &pointer->where; - - if (pointer->expr_type == EXPR_NULL) - goto null_arg; + if (gfc_invalid_null_arg (pointer)) + return false; attr1 = gfc_expr_attr (pointer); @@ -1468,9 +1479,8 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target) if (target == NULL) return true; - where = &target->where; - if (target->expr_type == EXPR_NULL) - goto null_arg; + if (gfc_invalid_null_arg (target)) + return false; if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION) attr2 = gfc_expr_attr (target); @@ -1518,13 +1528,6 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target) } } return t; - -null_arg: - - gfc_error ("NULL pointer at %L is not permitted as actual argument " - "of %qs intrinsic function", where, gfc_current_intrinsic); - return false; - } @@ -1972,8 +1975,8 @@ gfc_check_char (gfc_expr *i, gfc_expr *kind) { if (i->ts.type == BT_BOZ) { - if (gfc_invalid_boz ("BOZ literal constant at %L cannot appear in " - "CHAR intrinsic subprogram", &i->where)) + if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in " + "CHAR intrinsic subprogram"), &i->where)) return false; if (!gfc_boz2int (i, gfc_default_integer_kind)) @@ -2423,8 +2426,8 @@ gfc_check_complex (gfc_expr *x, gfc_expr *y) if (x->ts.type == BT_BOZ) { - if (gfc_invalid_boz ("BOZ constant at %L cannot appear in the COMPLEX " - "intrinsic subprogram", &x->where)) + if (gfc_invalid_boz (G_("BOZ constant at %L cannot appear in the COMPLEX" + " intrinsic subprogram"), &x->where)) { reset_boz (x); return false; @@ -2437,8 +2440,8 @@ gfc_check_complex (gfc_expr *x, gfc_expr *y) if (y->ts.type == BT_BOZ) { - if (gfc_invalid_boz ("BOZ constant at %L cannot appear in the COMPLEX " - "intrinsic subprogram", &y->where)) + if (gfc_invalid_boz (G_("BOZ constant at %L cannot appear in the COMPLEX" + " intrinsic subprogram"), &y->where)) { reset_boz (y); return false; @@ -2902,8 +2905,8 @@ gfc_check_float (gfc_expr *a) { if (a->ts.type == BT_BOZ) { - if (gfc_invalid_boz ("BOZ literal constant at %L cannot appear in the " - "FLOAT intrinsic subprogram", &a->where)) + if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in the" + " FLOAT intrinsic subprogram"), &a->where)) { reset_boz (a); return false; @@ -3373,6 +3376,9 @@ gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status) bool gfc_check_kind (gfc_expr *x) { + if (gfc_invalid_null_arg (x)) + return false; + if (gfc_bt_struct (x->ts.type) || x->ts.type == BT_CLASS) { gfc_error ("%qs argument of %qs intrinsic at %L must be of " @@ -3449,6 +3455,9 @@ gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind) if (!type_check (s, 0, BT_CHARACTER)) return false; + if (gfc_invalid_null_arg (s)) + return false; + if (!kind_check (kind, 1, BT_INTEGER)) return false; if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic " @@ -3699,8 +3708,8 @@ check_rest (bt type, int kind, gfc_actual_arglist *arglist) for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++) if (!gfc_check_conformance (tmp->expr, x, - "arguments 'a%d' and 'a%d' for " - "intrinsic '%s'", m, n, + _("arguments 'a%d' and 'a%d' for " + "intrinsic '%s'"), m, n, gfc_current_intrinsic)) return false; } @@ -3907,7 +3916,7 @@ gfc_check_minloc_maxloc (gfc_actual_arglist *ap) if (m != NULL && !gfc_check_conformance (a, m, - "arguments '%s' and '%s' for intrinsic %s", + _("arguments '%s' and '%s' for intrinsic %s"), gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic)) @@ -3988,7 +3997,7 @@ gfc_check_findloc (gfc_actual_arglist *ap) if (m != NULL && !gfc_check_conformance (a, m, - "arguments '%s' and '%s' for intrinsic %s", + _("arguments '%s' and '%s' for intrinsic %s"), gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic_arg[3]->name, gfc_current_intrinsic)) @@ -4053,7 +4062,7 @@ check_reduction (gfc_actual_arglist *ap) if (m != NULL && !gfc_check_conformance (a, m, - "arguments '%s' and '%s' for intrinsic %s", + _("arguments '%s' and '%s' for intrinsic %s"), gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic)) @@ -4134,6 +4143,12 @@ gfc_check_transf_bit_intrins (gfc_actual_arglist *ap) bool gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask) { + if (gfc_invalid_null_arg (tsource)) + return false; + + if (gfc_invalid_null_arg (fsource)) + return false; + if (!same_type_check (tsource, 0, fsource, 1)) return false; @@ -4385,7 +4400,7 @@ gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) return false; if (!gfc_check_conformance (array, mask, - "arguments '%s' and '%s' for intrinsic '%s'", + _("arguments '%s' and '%s' for intrinsic '%s'"), gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic)) @@ -4729,7 +4744,8 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, && shape->ref->u.ar.as->lower[0]->ts.type == BT_INTEGER && shape->ref->u.ar.as->upper[0]->expr_type == EXPR_CONSTANT && shape->ref->u.ar.as->upper[0]->ts.type == BT_INTEGER - && shape->symtree->n.sym->attr.flavor == FL_PARAMETER) + && shape->symtree->n.sym->attr.flavor == FL_PARAMETER + && shape->symtree->n.sym->value) { int i, extent; gfc_expr *e, *v; @@ -5051,6 +5067,9 @@ gfc_check_shape (gfc_expr *source, gfc_expr *kind) { gfc_array_ref *ar; + if (gfc_invalid_null_arg (source)) + return false; + if (source->rank == 0 || source->expr_type != EXPR_VARIABLE) return true; @@ -5133,6 +5152,9 @@ gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) bool gfc_check_sizeof (gfc_expr *arg) { + if (gfc_invalid_null_arg (arg)) + return false; + if (arg->ts.type == BT_PROCEDURE) { gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure", @@ -5618,6 +5640,9 @@ gfc_check_sngl (gfc_expr *a) bool gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies) { + if (gfc_invalid_null_arg (source)) + return false; + if (source->rank >= GFC_MAX_DIMENSIONS) { gfc_error ("%qs argument of %qs intrinsic at %L must be less " @@ -6148,6 +6173,9 @@ gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) size_t source_size; size_t result_size; + if (gfc_invalid_null_arg (source)) + return false; + /* SOURCE shall be a scalar or array of any type. */ if (source->ts.type == BT_PROCEDURE && source->symtree->n.sym->attr.subroutine == 1) @@ -6164,6 +6192,9 @@ gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) if (mold->ts.type == BT_BOZ && illegal_boz_arg (mold)) return false; + if (gfc_invalid_null_arg (mold)) + return false; + /* MOLD shall be a scalar or array of any type. */ if (mold->ts.type == BT_PROCEDURE && mold->symtree->n.sym->attr.subroutine == 1) @@ -6387,6 +6418,9 @@ gfc_check_trim (gfc_expr *x) if (!type_check (x, 0, BT_CHARACTER)) return false; + if (gfc_invalid_null_arg (x)) + return false; + if (!scalar_check (x, 0)) return false; @@ -6612,7 +6646,7 @@ gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get) gfc_error ("Size of %qs argument of %qs intrinsic at %L " "too small (%i/%i)", gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, - where, (int) mpz_get_ui (put_size), seed_size); + &put->where, (int) mpz_get_ui (put_size), seed_size); } if (get != NULL) @@ -6644,7 +6678,7 @@ gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get) gfc_error ("Size of %qs argument of %qs intrinsic at %L " "too small (%i/%i)", gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic, - where, (int) mpz_get_ui (get_size), seed_size); + &get->where, (int) mpz_get_ui (get_size), seed_size); } /* RANDOM_SEED may not have more than one non-optional argument. */ diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index 9aa3eb7..dfa4840 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -228,7 +228,7 @@ gfc_add_component_ref (gfc_expr *e, const char *name) break; tail = &((*tail)->next); } - if (derived->components && derived->components->next && + if (derived && derived->components && derived->components->next && derived->components->next->ts.type == BT_DERIVED && derived->components->next->ts.u.derived == NULL) { @@ -476,22 +476,38 @@ gfc_class_initializer (gfc_typespec *ts, gfc_expr *init_expr) and module name. This is used to construct unique names for the class containers and vtab symbols. */ -static void -get_unique_type_string (char *string, gfc_symbol *derived) +static char * +get_unique_type_string (gfc_symbol *derived) { - char dt_name[GFC_MAX_SYMBOL_LEN+1]; + const char *dt_name; + char *string; + size_t len; if (derived->attr.unlimited_polymorphic) - strcpy (dt_name, "STAR"); + dt_name = "STAR"; else - strcpy (dt_name, gfc_dt_upper_string (derived->name)); + dt_name = gfc_dt_upper_string (derived->name); + len = strlen (dt_name) + 2; if (derived->attr.unlimited_polymorphic) - sprintf (string, "_%s", dt_name); + { + string = XNEWVEC (char, len); + sprintf (string, "_%s", dt_name); + } else if (derived->module) - sprintf (string, "%s_%s", derived->module, dt_name); + { + string = XNEWVEC (char, strlen (derived->module) + len); + sprintf (string, "%s_%s", derived->module, dt_name); + } else if (derived->ns->proc_name) - sprintf (string, "%s_%s", derived->ns->proc_name->name, dt_name); + { + string = XNEWVEC (char, strlen (derived->ns->proc_name->name) + len); + sprintf (string, "%s_%s", derived->ns->proc_name->name, dt_name); + } else - sprintf (string, "_%s", dt_name); + { + string = XNEWVEC (char, len); + sprintf (string, "_%s", dt_name); + } + return string; } @@ -501,8 +517,9 @@ get_unique_type_string (char *string, gfc_symbol *derived) static void get_unique_hashed_string (char *string, gfc_symbol *derived) { - char tmp[2*GFC_MAX_SYMBOL_LEN+2]; - get_unique_type_string (&tmp[0], derived); + /* Provide sufficient space to hold "symbol.symbol_symbol". */ + char *tmp; + tmp = get_unique_type_string (derived); /* If string is too long, use hash value in hex representation (allow for extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab). We need space to for 15 characters "__class_" + symbol name + "_%d_%da", @@ -514,6 +531,7 @@ get_unique_hashed_string (char *string, gfc_symbol *derived) } else strcpy (string, tmp); + free (tmp); } @@ -523,15 +541,17 @@ unsigned int gfc_hash_value (gfc_symbol *sym) { unsigned int hash = 0; - char c[2*(GFC_MAX_SYMBOL_LEN+1)]; + /* Provide sufficient space to hold "symbol.symbol_symbol". */ + char *c; int i, len; - get_unique_type_string (&c[0], sym); + c = get_unique_type_string (sym); len = strlen (c); for (i = 0; i < len; i++) hash = (hash << 6) + (hash << 16) - hash + c[i]; + free (c); /* Return the hash but take the modulus for the sake of module read, even though this slightly increases the chance of collision. */ return (hash % 100000000); @@ -544,7 +564,7 @@ unsigned int gfc_intrinsic_hash_value (gfc_typespec *ts) { unsigned int hash = 0; - const char *c = gfc_typename (ts); + const char *c = gfc_typename (ts, true); int i, len; len = strlen (c); @@ -643,6 +663,10 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, /* Determine the name of the encapsulating type. */ rank = !(*as) || (*as)->rank == -1 ? GFC_MAX_DIMENSIONS : (*as)->rank; + + if (!ts->u.derived) + return false; + get_unique_hashed_string (tname, ts->u.derived); if ((*as) && attr->allocatable) name = xasprintf ("__class_%s_%d_%da", tname, rank, (*as)->corank); @@ -907,12 +931,18 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp, { gfc_expr *e; gfc_ref *ref; + gfc_was_finalized *f; if (!comp_is_finalizable (comp)) return; - if (comp->finalized) - return; + /* If this expression with this component has been finalized + already in this namespace, there is nothing to do. */ + for (f = sub_ns->was_finalized; f; f = f->next) + { + if (f->e == expr && f->c == comp) + return; + } e = gfc_copy_expr (expr); if (!e->ref) @@ -1002,6 +1032,7 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp, } else (*code) = cond; + } else if (comp->ts.type == BT_DERIVED && comp->ts.u.derived->f2k_derived @@ -1041,7 +1072,13 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp, sub_ns); gfc_free_expr (e); } - comp->finalized = true; + + /* Record that this was finalized already in this namespace. */ + f = sub_ns->was_finalized; + sub_ns->was_finalized = XCNEW (gfc_was_finalized); + sub_ns->was_finalized->e = expr; + sub_ns->was_finalized->c = comp; + sub_ns->was_finalized->next = f; } @@ -2244,6 +2281,9 @@ gfc_find_derived_vtab (gfc_symbol *derived) if (!derived) return NULL; + if (!derived->name) + return NULL; + /* Find the gsymbol for the module of use associated derived types. */ if ((derived->attr.use_assoc || derived->attr.used_in_submodule) && !derived->attr.vtype && !derived->attr.is_class) diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index d650407..d854b2a 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -576,16 +576,16 @@ match_old_style_init (const char *name) for (nd = newdata; nd; nd = nd->next) { if (nd->value->expr->ts.type == BT_BOZ - && gfc_invalid_boz ("BOZ at %L cannot appear in an old-style " - "initialization", &nd->value->expr->where)) + && gfc_invalid_boz (G_("BOZ at %L cannot appear in an old-style " + "initialization"), &nd->value->expr->where)) return MATCH_ERROR; if (nd->var->expr->ts.type != BT_INTEGER && nd->var->expr->ts.type != BT_REAL && nd->value->expr->ts.type == BT_BOZ) { - gfc_error ("BOZ literal constant near %L cannot be assigned to " - "a %qs variable in an old-style initialization", + gfc_error (G_("BOZ literal constant near %L cannot be assigned to " + "a %qs variable in an old-style initialization"), &nd->value->expr->where, gfc_typename (&nd->value->expr->ts)); return MATCH_ERROR; @@ -728,7 +728,7 @@ gfc_match_data (void) gfc_constructor *c; c = gfc_constructor_first (new_data->value->expr->value.constructor); for (; c; c = gfc_constructor_next (c)) - if (c->expr->ts.type == BT_BOZ) + if (c->expr && c->expr->ts.type == BT_BOZ) { gfc_error ("BOZ literal constant at %L cannot appear in a " "structure constructor", &c->expr->where); @@ -1077,6 +1077,11 @@ 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); + if ((*expr)->expr_type == EXPR_FUNCTION) { if ((*expr)->ts.type == BT_INTEGER @@ -1884,13 +1889,16 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) /* If this symbol is confirming an implicit parameter type, then an initialization expression is not allowed. */ - if (attr.flavor == FL_PARAMETER - && sym->value != NULL - && *initp != NULL) + if (attr.flavor == FL_PARAMETER && sym->value != NULL) { - gfc_error ("Initializer not allowed for PARAMETER %qs at %C", - sym->name); - return false; + if (*initp != NULL) + { + gfc_error ("Initializer not allowed for PARAMETER %qs at %C", + sym->name); + return false; + } + else + return true; } if (init == NULL) @@ -2602,6 +2610,14 @@ variable_decl (int elem) gfc_free_expr (e); } + if (not_constant && e->ts.type != BT_INTEGER) + { + gfc_error ("Explicit array shape at %C must be constant of " + "INTEGER type and not %s type", + gfc_basic_typename (e->ts.type)); + m = MATCH_ERROR; + goto cleanup; + } if (not_constant) { gfc_error ("Explicit shaped array with nonconstant bounds at %C"); @@ -3736,8 +3752,9 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, if (kind_expr) { /* Try simplification even for LEN expressions. */ + bool ok; gfc_resolve_expr (kind_expr); - gfc_simplify_expr (kind_expr, 1); + ok = gfc_simplify_expr (kind_expr, 1); /* Variable expressions seem to default to BT_PROCEDURE. TODO find out why this is and fix it. */ if (kind_expr->ts.type != BT_INTEGER @@ -3748,6 +3765,12 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, gfc_basic_typename (kind_expr->ts.type)); goto error_return; } + if (kind_expr->ts.type == BT_INTEGER && !ok) + { + gfc_error ("The parameter expression at %C does not " + "simplify to an INTEGER constant"); + goto error_return; + } tail->expr = gfc_copy_expr (kind_expr); } @@ -4074,7 +4097,8 @@ match_byte_typespec (gfc_typespec *ts) match gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) { - char name[GFC_MAX_SYMBOL_LEN + 1]; + /* Provide sufficient space to hold "pdtsymbol". */ + char *name = XALLOCAVEC (char, GFC_MAX_SYMBOL_LEN + 1); gfc_symbol *sym, *dt_sym; match m; char c; @@ -4107,7 +4131,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) gfc_gobble_whitespace (); if (gfc_peek_ascii_char () == '*') { - if ((m = gfc_match ("*)")) != MATCH_YES) + if ((m = gfc_match ("* ) ")) != MATCH_YES) return m; if (gfc_comp_struct (gfc_current_state ())) { @@ -4264,7 +4288,13 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) return m; gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type); ts->u.derived = sym; - strcpy (name, gfc_dt_lower_string (sym->name)); + const char* lower = gfc_dt_lower_string (sym->name); + size_t len = strlen (lower); + /* Reallocate with sufficient size. */ + if (len > GFC_MAX_SYMBOL_LEN) + name = XALLOCAVEC (char, len + 1); + memcpy (name, lower, len); + name[len] = '\0'; } if (sym && sym->attr.flavor == FL_STRUCT) @@ -4802,7 +4832,7 @@ gfc_match_implicit (void) /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */ if (ts.type == BT_CHARACTER) m = gfc_match_char_spec (&ts); - else + else if (ts.type != BT_DERIVED) { m = gfc_match_kind_spec (&ts, false); if (m == MATCH_NO) @@ -9048,7 +9078,7 @@ access_attr_decl (gfc_statement st) else { gfc_error ("Access specification of the .%s. operator at %C " - "has already been specified", sym->name); + "has already been specified", uop->name); goto done; } diff --git a/gcc/fortran/dependency.c b/gcc/fortran/dependency.c index f6c6840..7edd5d9 100644 --- a/gcc/fortran/dependency.c +++ b/gcc/fortran/dependency.c @@ -2033,6 +2033,8 @@ ref_same_as_full_array (gfc_ref *full_ref, gfc_ref *ref) return false; if (ref->type != REF_ARRAY) return false; + if (ref->u.ar.type == AR_FULL) + return true; if (ref->u.ar.type != AR_SECTION) return false; diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index f323306..6e265f4 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -1552,6 +1552,8 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses) fputs (" SEQ", dumpfile); if (omp_clauses->independent) fputs (" INDEPENDENT", dumpfile); + if (omp_clauses->order_concurrent) + fputs (" ORDER(CONCURRENT)", dumpfile); if (omp_clauses->ordered) { if (omp_clauses->orderedc) @@ -1593,6 +1595,7 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses) case OMP_LIST_IS_DEVICE_PTR: type = "IS_DEVICE_PTR"; break; case OMP_LIST_USE_DEVICE_PTR: type = "USE_DEVICE_PTR"; break; case OMP_LIST_USE_DEVICE_ADDR: type = "USE_DEVICE_ADDR"; break; + case OMP_LIST_NONTEMPORAL: type = "NONTEMPORAL"; break; default: gcc_unreachable (); } @@ -1693,7 +1696,9 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses) if (omp_clauses->if_exprs[i]) { static const char *ifs[] = { + "CANCEL", "PARALLEL", + "SIMD", "TASK", "TASKLOOP", "TARGET", @@ -3257,45 +3262,28 @@ get_c_type_name (gfc_typespec *ts, gfc_array_spec *as, const char **pre, if (ts->type == BT_REAL || ts->type == BT_INTEGER || ts->type == BT_COMPLEX) { if (ts->is_c_interop && ts->interop_kind) - { - *type_name = ts->interop_kind->name + 2; - if (strcmp (*type_name, "signed_char") == 0) - *type_name = "signed char"; - else if (strcmp (*type_name, "size_t") == 0) - *type_name = "ssize_t"; - else if (strcmp (*type_name, "float_complex") == 0) - *type_name = "__GFORTRAN_FLOAT_COMPLEX"; - else if (strcmp (*type_name, "double_complex") == 0) - *type_name = "__GFORTRAN_DOUBLE_COMPLEX"; - else if (strcmp (*type_name, "long_double_complex") == 0) - *type_name = "__GFORTRAN_LONG_DOUBLE_COMPLEX"; - - ret = T_OK; - } + ret = T_OK; else + ret = T_WARN; + + for (int i = 0; i < ISOCBINDING_NUMBER; i++) { - /* The user did not specify a C interop type. Let's look through - the available table and use the first one, but warn. */ - for (int i = 0; i < ISOCBINDING_NUMBER; i++) + if (c_interop_kinds_table[i].f90_type == ts->type + && c_interop_kinds_table[i].value == ts->kind) { - if (c_interop_kinds_table[i].f90_type == ts->type - && c_interop_kinds_table[i].value == ts->kind) - { - *type_name = c_interop_kinds_table[i].name + 2; - if (strcmp (*type_name, "signed_char") == 0) - *type_name = "signed char"; - else if (strcmp (*type_name, "size_t") == 0) - *type_name = "ssize_t"; - else if (strcmp (*type_name, "float_complex") == 0) - *type_name = "__GFORTRAN_FLOAT_COMPLEX"; - else if (strcmp (*type_name, "double_complex") == 0) - *type_name = "__GFORTRAN_DOUBLE_COMPLEX"; - else if (strcmp (*type_name, "long_double_complex") == 0) - *type_name = "__GFORTRAN_LONG_DOUBLE_COMPLEX"; - - ret = T_WARN; - break; - } + *type_name = c_interop_kinds_table[i].name + 2; + if (strcmp (*type_name, "signed_char") == 0) + *type_name = "signed char"; + else if (strcmp (*type_name, "size_t") == 0) + *type_name = "ssize_t"; + else if (strcmp (*type_name, "float_complex") == 0) + *type_name = "__GFORTRAN_FLOAT_COMPLEX"; + else if (strcmp (*type_name, "double_complex") == 0) + *type_name = "__GFORTRAN_DOUBLE_COMPLEX"; + else if (strcmp (*type_name, "long_double_complex") == 0) + *type_name = "__GFORTRAN_LONG_DOUBLE_COMPLEX"; + + break; } } } @@ -3595,5 +3583,8 @@ show_global_symbol (gfc_gsymbol *gsym, void *f_data) void gfc_dump_global_symbols (FILE *f) { - gfc_traverse_gsymbol (gfc_gsym_root, show_global_symbol, (void *) f); + if (gfc_gsym_root == NULL) + fprintf (f, "empty\n"); + else + gfc_traverse_gsymbol (gfc_gsym_root, show_global_symbol, (void *) f); } diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index a9fa03a..6707ca5 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3693,7 +3693,7 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform, /* Check size of array assignments. */ if (lvalue->rank != 0 && rvalue->rank != 0 - && !gfc_check_conformance (lvalue, rvalue, "array assignment")) + && !gfc_check_conformance (lvalue, rvalue, _("array assignment"))) return false; /* Handle the case of a BOZ literal on the RHS. */ @@ -4271,7 +4271,20 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue, gfc_symbol *sym; bool target; - gcc_assert (rvalue->symtree); + if (gfc_is_size_zero_array (rvalue)) + { + gfc_error ("Zero-sized array detected at %L where an entity with " + "the TARGET attribute is expected", &rvalue->where); + return false; + } + else if (!rvalue->symtree) + { + gfc_error ("Pointer assignment target in initialization expression " + "does not have the TARGET attribute at %L", + &rvalue->where); + return false; + } + sym = rvalue->symtree->n.sym; if (sym->ts.type == BT_CLASS && sym->attr.class_ok) @@ -4346,7 +4359,9 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue, contiguous. Be lenient in the definition of what counts as contiguous. */ - if (lhs_attr.contiguous && !gfc_is_simply_contiguous (rvalue, false, true)) + if (lhs_attr.contiguous + && lhs_attr.dimension > 0 + && !gfc_is_simply_contiguous (rvalue, false, true)) gfc_warning (OPT_Wextra, "Assignment to contiguous pointer from " "non-contiguous target at %L", &rvalue->where); diff --git a/gcc/fortran/f95-lang.c b/gcc/fortran/f95-lang.c index 44ebe3e..e3288d7 100644 --- a/gcc/fortran/f95-lang.c +++ b/gcc/fortran/f95-lang.c @@ -118,6 +118,7 @@ static const struct attribute_spec gfc_attribute_table[] = #undef LANG_HOOKS_OMP_CHECK_OPTIONAL_ARGUMENT #undef LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE #undef LANG_HOOKS_OMP_PREDETERMINED_SHARING +#undef LANG_HOOKS_OMP_PREDETERMINED_MAPPING #undef LANG_HOOKS_OMP_REPORT_DECL #undef LANG_HOOKS_OMP_CLAUSE_DEFAULT_CTOR #undef LANG_HOOKS_OMP_CLAUSE_COPY_CTOR @@ -153,6 +154,7 @@ static const struct attribute_spec gfc_attribute_table[] = #define LANG_HOOKS_OMP_CHECK_OPTIONAL_ARGUMENT gfc_omp_check_optional_argument #define LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE gfc_omp_privatize_by_reference #define LANG_HOOKS_OMP_PREDETERMINED_SHARING gfc_omp_predetermined_sharing +#define LANG_HOOKS_OMP_PREDETERMINED_MAPPING gfc_omp_predetermined_mapping #define LANG_HOOKS_OMP_REPORT_DECL gfc_omp_report_decl #define LANG_HOOKS_OMP_CLAUSE_DEFAULT_CTOR gfc_omp_clause_default_ctor #define LANG_HOOKS_OMP_CLAUSE_COPY_CTOR gfc_omp_clause_copy_ctor @@ -1236,17 +1238,6 @@ gfc_init_builtin_functions (void) #undef DEF_GOMP_BUILTIN } -#ifdef ENABLE_HSA - if (!flag_disable_hsa) - { -#undef DEF_HSA_BUILTIN -#define DEF_HSA_BUILTIN(code, name, type, attr) \ - gfc_define_builtin ("__builtin_" name, builtin_types[type], \ - code, name, attr); -#include "../hsa-builtins.def" - } -#endif - gfc_define_builtin ("__builtin_trap", builtin_types[BT_FN_VOID], BUILT_IN_TRAP, NULL, ATTR_NOTHROW_LEAF_LIST); TREE_THIS_VOLATILE (builtin_decl_explicit (BUILT_IN_TRAP)) = 1; diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c index d5d71b5..83f6fd8 100644 --- a/gcc/fortran/frontend-passes.c +++ b/gcc/fortran/frontend-passes.c @@ -2305,6 +2305,213 @@ optimize_minmaxloc (gfc_expr **e) mpz_set_ui (a->expr->value.integer, 1); } +/* Data package to hand down for DO loop checks in a contained + procedure. */ +typedef struct contained_info +{ + gfc_symbol *do_var; + gfc_symbol *procedure; + locus where_do; +} contained_info; + +static enum gfc_exec_op last_io_op; + +/* Callback function to check for INTENT(OUT) and INTENT(INOUT) in a + contained function call. */ + +static int +doloop_contained_function_call (gfc_expr **e, + int *walk_subtrees ATTRIBUTE_UNUSED, void *data) +{ + gfc_expr *expr = *e; + gfc_formal_arglist *f; + gfc_actual_arglist *a; + gfc_symbol *sym, *do_var; + contained_info *info; + + if (expr->expr_type != EXPR_FUNCTION || expr->value.function.isym + || expr->value.function.esym == NULL) + return 0; + + sym = expr->value.function.esym; + f = gfc_sym_get_dummy_args (sym); + if (f == NULL) + return 0; + + info = (contained_info *) data; + do_var = info->do_var; + a = expr->value.function.actual; + + while (a && f) + { + if (a->expr && a->expr->symtree && a->expr->symtree->n.sym == do_var) + { + if (f->sym->attr.intent == INTENT_OUT) + { + gfc_error_now ("Index variable %qs set to undefined as " + "INTENT(OUT) argument at %L in procedure %qs " + "called from within DO loop at %L", do_var->name, + &a->expr->where, info->procedure->name, + &info->where_do); + return 1; + } + else if (f->sym->attr.intent == INTENT_INOUT) + { + gfc_error_now ("Index variable %qs not definable as " + "INTENT(INOUT) argument at %L in procedure %qs " + "called from within DO loop at %L", do_var->name, + &a->expr->where, info->procedure->name, + &info->where_do); + return 1; + } + } + a = a->next; + f = f->next; + } + return 0; +} + +/* Callback function that goes through the code in a contained + procedure to make sure it does not change a variable in a DO + loop. */ + +static int +doloop_contained_procedure_code (gfc_code **c, + int *walk_subtrees ATTRIBUTE_UNUSED, + void *data) +{ + gfc_code *co = *c; + contained_info *info = (contained_info *) data; + gfc_symbol *do_var = info->do_var; + const char *errmsg = _("Index variable %qs redefined at %L in procedure %qs " + "called from within DO loop at %L"); + static enum gfc_exec_op saved_io_op; + + switch (co->op) + { + case EXEC_ASSIGN: + if (co->expr1->symtree->n.sym == do_var) + gfc_error_now (errmsg, do_var->name, &co->loc, info->procedure->name, + &info->where_do); + break; + + case EXEC_DO: + if (co->ext.iterator && co->ext.iterator->var + && co->ext.iterator->var->symtree->n.sym == do_var) + gfc_error (errmsg, do_var->name, &co->loc, info->procedure->name, + &info->where_do); + break; + + case EXEC_READ: + case EXEC_WRITE: + case EXEC_INQUIRE: + saved_io_op = last_io_op; + last_io_op = co->op; + break; + + case EXEC_OPEN: + if (co->ext.open->iostat + && co->ext.open->iostat->symtree->n.sym == do_var) + gfc_error_now (errmsg, do_var->name, &co->ext.open->iostat->where, + info->procedure->name, &info->where_do); + break; + + case EXEC_CLOSE: + if (co->ext.close->iostat + && co->ext.close->iostat->symtree->n.sym == do_var) + gfc_error_now (errmsg, do_var->name, &co->ext.close->iostat->where, + info->procedure->name, &info->where_do); + break; + + case EXEC_TRANSFER: + switch (last_io_op) + { + + case EXEC_INQUIRE: +#define CHECK_INQ(a) do { if (co->ext.inquire->a && \ + co->ext.inquire->a->symtree->n.sym == do_var) \ + gfc_error_now (errmsg, do_var->name, \ + &co->ext.inquire->a->where, \ + info->procedure->name, \ + &info->where_do); \ + } while (0) + + CHECK_INQ(iostat); + CHECK_INQ(number); + CHECK_INQ(position); + CHECK_INQ(recl); + CHECK_INQ(position); + CHECK_INQ(iolength); + CHECK_INQ(strm_pos); + break; +#undef CHECK_INQ + + case EXEC_READ: + if (co->expr1 && co->expr1->symtree->n.sym == do_var) + gfc_error_now (errmsg, do_var->name, &co->expr1->where, + info->procedure->name, &info->where_do); + + /* Fallthrough. */ + + case EXEC_WRITE: + if (co->ext.dt->iostat + && co->ext.dt->iostat->symtree->n.sym == do_var) + gfc_error_now (errmsg, do_var->name, &co->ext.dt->iostat->where, + info->procedure->name, &info->where_do); + break; + + default: + gcc_unreachable (); + } + break; + + case EXEC_DT_END: + last_io_op = saved_io_op; + break; + + case EXEC_CALL: + gfc_formal_arglist *f; + gfc_actual_arglist *a; + + f = gfc_sym_get_dummy_args (co->resolved_sym); + if (f == NULL) + break; + a = co->ext.actual; + /* Slightly different error message here. If there is an error, + return 1 to avoid an infinite loop. */ + while (a && f) + { + if (a->expr && a->expr->symtree && a->expr->symtree->n.sym == do_var) + { + if (f->sym->attr.intent == INTENT_OUT) + { + gfc_error_now ("Index variable %qs set to undefined as " + "INTENT(OUT) argument at %L in subroutine %qs " + "called from within DO loop at %L", + do_var->name, &a->expr->where, + info->procedure->name, &info->where_do); + return 1; + } + else if (f->sym->attr.intent == INTENT_INOUT) + { + gfc_error_now ("Index variable %qs not definable as " + "INTENT(INOUT) argument at %L in subroutine %qs " + "called from within DO loop at %L", do_var->name, + &a->expr->where, info->procedure->name, + &info->where_do); + return 1; + } + } + a = a->next; + f = f->next; + } + break; + default: + break; + } + return 0; +} + /* Callback function for code checking that we do not pass a DO variable to an INTENT(OUT) or INTENT(INOUT) dummy variable. */ @@ -2389,10 +2596,32 @@ doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, break; case EXEC_CALL: - if (co->resolved_sym == NULL) break; + /* Test if somebody stealthily changes the DO variable from + under us by changing it in a host-associated procedure. */ + if (co->resolved_sym->attr.contained) + { + FOR_EACH_VEC_ELT (doloop_list, i, lp) + { + gfc_symbol *sym = co->resolved_sym; + contained_info info; + gfc_namespace *ns; + + cl = lp->c; + info.do_var = cl->ext.iterator->var->symtree->n.sym; + info.procedure = co->resolved_sym; /* sym? */ + info.where_do = co->loc; + /* Look contained procedures under the namespace of the + variable. */ + for (ns = info.do_var->ns->contained; ns; ns = ns->sibling) + if (ns->proc_name && ns->proc_name == sym) + gfc_code_walker (&ns->code, doloop_contained_procedure_code, + doloop_contained_function_call, &info); + } + } + f = gfc_sym_get_dummy_args (co->resolved_sym); /* Withot a formal arglist, there is only unknown INTENT, @@ -2436,6 +2665,7 @@ doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, a = a->next; f = f->next; } + break; default: @@ -2737,6 +2967,7 @@ do_intent (gfc_expr **e) gfc_code *dl; do_t *lp; int i; + gfc_symbol *sym; expr = *e; if (expr->expr_type != EXPR_FUNCTION) @@ -2747,7 +2978,31 @@ do_intent (gfc_expr **e) if (expr->value.function.isym) return 0; - f = gfc_sym_get_dummy_args (expr->symtree->n.sym); + sym = expr->value.function.esym; + if (sym == NULL) + return 0; + + if (sym->attr.contained) + { + FOR_EACH_VEC_ELT (doloop_list, i, lp) + { + contained_info info; + gfc_namespace *ns; + + dl = lp->c; + info.do_var = dl->ext.iterator->var->symtree->n.sym; + info.procedure = sym; + info.where_do = expr->where; + /* Look contained procedures under the namespace of the + variable. */ + for (ns = info.do_var->ns->contained; ns; ns = ns->sibling) + if (ns->proc_name && ns->proc_name == sym) + gfc_code_walker (&ns->code, doloop_contained_procedure_code, + dummy_expr_callback, &info); + } + } + + f = gfc_sym_get_dummy_args (sym); /* Without a formal arglist, there is only unknown INTENT, which we don't check for. */ @@ -5441,6 +5696,7 @@ check_externals_procedure (gfc_symbol *sym, locus *loc, gfc_current_ns = gsym->ns; gfc_get_formal_from_actual_arglist (new_sym, actual); + new_sym->declared_at = *loc; gfc_current_ns = save_ns; return 0; @@ -5493,12 +5749,66 @@ check_externals_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED, return check_externals_procedure (sym, loc, actual); } +/* Function to check if any interface clashes with a global + identifier, to be invoked via gfc_traverse_ns. */ + +static void +check_against_globals (gfc_symbol *sym) +{ + gfc_gsymbol *gsym; + gfc_symbol *def_sym = NULL; + const char *sym_name; + char buf [200]; + + if (sym->attr.if_source != IFSRC_IFBODY || sym->attr.flavor != FL_PROCEDURE + || sym->attr.generic || sym->error) + return; + + if (sym->binding_label) + sym_name = sym->binding_label; + else + sym_name = sym->name; + + gsym = gfc_find_gsymbol (gfc_gsym_root, sym_name); + if (gsym && gsym->ns) + gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym); + + if (!def_sym || def_sym->error || def_sym->attr.generic) + return; + + buf[0] = 0; + gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1, buf, sizeof(buf), + NULL, NULL, NULL); + if (buf[0] != 0) + { + gfc_warning (0, "%s between %L and %L", buf, &def_sym->declared_at, + &sym->declared_at); + sym->error = 1; + def_sym->error = 1; + } + +} + +/* Do the code-walkling part for gfc_check_externals. */ + +static void +gfc_check_externals0 (gfc_namespace *ns) +{ + gfc_code_walker (&ns->code, check_externals_code, check_externals_expr, NULL); + + for (ns = ns->contained; ns; ns = ns->sibling) + { + if (ns->code == NULL || ns->code->op != EXEC_BLOCK) + gfc_check_externals0 (ns); + } + +} + /* Called routine. */ void gfc_check_externals (gfc_namespace *ns) { - gfc_clear_error (); /* Turn errors into warnings if the user indicated this. */ @@ -5506,13 +5816,82 @@ gfc_check_externals (gfc_namespace *ns) if (!pedantic && flag_allow_argument_mismatch) gfc_errors_to_warnings (true); - gfc_code_walker (&ns->code, check_externals_code, check_externals_expr, NULL); + gfc_check_externals0 (ns); + gfc_traverse_ns (ns, check_against_globals); + + gfc_errors_to_warnings (false); +} + +/* Callback function. If there is a call to a subroutine which is + neither pure nor implicit_pure, unset the implicit_pure flag for + the caller and return -1. */ + +static int +implicit_pure_call (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, + void *sym_data) +{ + gfc_code *co = *c; + gfc_symbol *caller_sym; + symbol_attribute *a; + + if (co->op != EXEC_CALL || co->resolved_sym == NULL) + return 0; + + a = &co->resolved_sym->attr; + if (a->intrinsic || a->pure || a->implicit_pure) + return 0; + + caller_sym = (gfc_symbol *) sym_data; + gfc_unset_implicit_pure (caller_sym); + return 1; +} + +/* Callback function. If there is a call to a function which is + neither pure nor implicit_pure, unset the implicit_pure flag for + the caller and return 1. */ + +static int +implicit_pure_expr (gfc_expr **e, int *walk ATTRIBUTE_UNUSED, void *sym_data) +{ + gfc_expr *expr = *e; + gfc_symbol *caller_sym; + gfc_symbol *sym; + symbol_attribute *a; + + if (expr->expr_type != EXPR_FUNCTION || expr->value.function.isym) + return 0; + + sym = expr->symtree->n.sym; + a = &sym->attr; + if (a->pure || a->implicit_pure) + return 0; + + caller_sym = (gfc_symbol *) sym_data; + gfc_unset_implicit_pure (caller_sym); + return 1; +} + +/* Go through all procedures in the namespace and unset the + implicit_pure attribute for any procedure that calls something not + pure or implicit pure. */ + +bool +gfc_fix_implicit_pure (gfc_namespace *ns) +{ + bool changed = false; + gfc_symbol *proc = ns->proc_name; + + if (proc && proc->attr.flavor == FL_PROCEDURE && proc->attr.implicit_pure + && ns->code + && gfc_code_walker (&ns->code, implicit_pure_call, implicit_pure_expr, + (void *) ns->proc_name)) + changed = true; for (ns = ns->contained; ns; ns = ns->sibling) { - if (ns->code == NULL || ns->code->op != EXEC_BLOCK) - gfc_check_externals (ns); + if (gfc_fix_implicit_pure (ns)) + changed = true; } - gfc_errors_to_warnings (false); + return changed; } diff --git a/gcc/fortran/gfc-internals.texi b/gcc/fortran/gfc-internals.texi index e74d5d6..6c72043 100644 --- a/gcc/fortran/gfc-internals.texi +++ b/gcc/fortran/gfc-internals.texi @@ -810,7 +810,7 @@ gfc_add_modify (block, var, build_int_cst (integer_type_node, 42)); @end smallexample @node Converting Expressions -@section Converting Expressons to tree +@section Converting Expressions to tree Converting expressions to @code{tree} is done by functions called @code{gfc_conv_*}. diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 4e1da8c..559d3c6 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -263,7 +263,7 @@ enum gfc_statement ST_OMP_TARGET_SIMD, ST_OMP_END_TARGET_SIMD, ST_OMP_TASKLOOP, ST_OMP_END_TASKLOOP, ST_OMP_TASKLOOP_SIMD, ST_OMP_END_TASKLOOP_SIMD, ST_OMP_ORDERED_DEPEND, - ST_PROCEDURE, ST_GENERIC, ST_CRITICAL, ST_END_CRITICAL, + ST_OMP_REQUIRES, ST_PROCEDURE, ST_GENERIC, ST_CRITICAL, ST_END_CRITICAL, ST_GET_FCN_CHARACTERISTICS, ST_LOCK, ST_UNLOCK, ST_EVENT_POST, ST_EVENT_WAIT, ST_FAIL_IMAGE, ST_FORM_TEAM, ST_CHANGE_TEAM, ST_END_TEAM, ST_SYNC_TEAM, ST_NONE @@ -1107,7 +1107,6 @@ typedef struct gfc_component struct gfc_typebound_proc *tb; /* When allocatable/pointer and in a coarray the associated token. */ tree caf_token; - bool finalized; } gfc_component; @@ -1243,6 +1242,7 @@ typedef struct gfc_omp_namelist gfc_omp_map_op map_op; gfc_omp_linear_op linear_op; struct gfc_common_head *common; + bool lastprivate_conditional; } u; struct gfc_omp_namelist_udr *udr; struct gfc_omp_namelist *next; @@ -1276,6 +1276,7 @@ enum OMP_LIST_IS_DEVICE_PTR, OMP_LIST_USE_DEVICE_PTR, OMP_LIST_USE_DEVICE_ADDR, + OMP_LIST_NONTEMPORAL, OMP_LIST_NUM }; @@ -1321,7 +1322,9 @@ enum gfc_omp_cancel_kind enum gfc_omp_if_kind { + OMP_IF_CANCEL, OMP_IF_PARALLEL, + OMP_IF_SIMD, OMP_IF_TASK, OMP_IF_TASKLOOP, OMP_IF_TARGET, @@ -1332,6 +1335,24 @@ enum gfc_omp_if_kind OMP_IF_LAST }; +enum gfc_omp_requires_kind +{ + /* Keep in sync with gfc_namespace, esp. with omp_req_mem_order. */ + OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST = 1, /* 01 */ + OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL = 2, /* 10 */ + OMP_REQ_ATOMIC_MEM_ORDER_RELAXED = 3, /* 11 */ + OMP_REQ_REVERSE_OFFLOAD = (1 << 2), + OMP_REQ_UNIFIED_ADDRESS = (1 << 3), + OMP_REQ_UNIFIED_SHARED_MEMORY = (1 << 4), + OMP_REQ_DYNAMIC_ALLOCATORS = (1 << 5), + OMP_REQ_TARGET_MASK = (OMP_REQ_REVERSE_OFFLOAD + | OMP_REQ_UNIFIED_ADDRESS + | OMP_REQ_UNIFIED_SHARED_MEMORY), + OMP_REQ_ATOMIC_MEM_ORDER_MASK = (OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST + | OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL + | OMP_REQ_ATOMIC_MEM_ORDER_RELAXED) +}; + typedef struct gfc_omp_clauses { struct gfc_expr *if_expr; @@ -1345,7 +1366,7 @@ typedef struct gfc_omp_clauses bool nowait, ordered, untied, mergeable; bool inbranch, notinbranch, defaultmap, nogroup; bool sched_simd, sched_monotonic, sched_nonmonotonic; - bool simd, threads, depend_source; + bool simd, threads, depend_source, order_concurrent; enum gfc_omp_cancel_kind cancel; enum gfc_omp_proc_bind_kind proc_bind; struct gfc_expr *safelen_expr; @@ -1621,7 +1642,10 @@ typedef struct gfc_symbol /* Set if the symbol is used in a function result specification . */ unsigned fn_result_spec:1; /* Used to avoid multiple resolutions of a single symbol. */ - unsigned resolved:1; + /* = 2 if this has already been resolved as an intrinsic, + in gfc_resolve_intrinsic, + = 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. */ unsigned abr_modproc_decl:1; @@ -1675,7 +1699,8 @@ typedef struct gfc_common_head char use_assoc, saved, threadprivate; unsigned char omp_declare_target : 1; unsigned char omp_declare_target_link : 1; - char name[GFC_MAX_SYMBOL_LEN + 1]; + /* Provide sufficient space to hold "symbol.symbol.eq.1234567890". */ + char name[2*GFC_MAX_SYMBOL_LEN + 1 + 14 + 1]; struct gfc_symbol *head; const char* binding_label; int is_bind_c; @@ -1771,6 +1796,16 @@ gfc_oacc_routine_name; #define gfc_get_oacc_routine_name() XCNEW (gfc_oacc_routine_name) +/* Node in linked list to see what has already been finalized + earlier. */ + +typedef struct gfc_was_finalized { + gfc_expr *e; + gfc_component *c; + struct gfc_was_finalized *next; +} +gfc_was_finalized; + /* A namespace describes the contents of procedure, module, interface block or BLOCK construct. */ /* ??? Anything else use these? */ @@ -1863,6 +1898,11 @@ typedef struct gfc_namespace /* Linked list of !$omp declare simd constructs. */ struct gfc_omp_declare_simd *omp_declare_simd; + /* A hash set for the the gfc expressions that have already + been finalized in this namespace. */ + + gfc_was_finalized *was_finalized; + /* Set to 1 if namespace is a BLOCK DATA program unit. */ unsigned is_block_data:1; @@ -1894,6 +1934,10 @@ typedef struct gfc_namespace /* Set to 1 if there are any calls to procedures with implicit interface. */ unsigned implicit_interface_calls:1; + + /* OpenMP requires. */ + unsigned omp_requires:6; + unsigned omp_target_seen:1; } gfc_namespace; @@ -2624,7 +2668,8 @@ enum gfc_omp_atomic_op GFC_OMP_ATOMIC_CAPTURE = 3, GFC_OMP_ATOMIC_MASK = 3, GFC_OMP_ATOMIC_SEQ_CST = 4, - GFC_OMP_ATOMIC_SWAP = 8 + GFC_OMP_ATOMIC_ACQ_REL = 8, + GFC_OMP_ATOMIC_SWAP = 16 }; typedef struct gfc_code @@ -2913,7 +2958,7 @@ void gfc_clear_ts (gfc_typespec *); FILE *gfc_open_file (const char *); const char *gfc_basic_typename (bt); const char *gfc_dummy_typename (gfc_typespec *); -const char *gfc_typename (gfc_typespec *); +const char *gfc_typename (gfc_typespec *, bool for_hash = false); const char *gfc_typename (gfc_expr *); const char *gfc_op2string (gfc_intrinsic_op); const char *gfc_code2string (const mstring *, int); @@ -3249,6 +3294,9 @@ gfc_expr *gfc_get_parentheses (gfc_expr *); /* openmp.c */ struct gfc_omp_saved_state { void *ptrs[2]; int ints[1]; }; +bool gfc_omp_requires_add_clause (gfc_omp_requires_kind, const char *, + locus *, const char *); +void gfc_check_omp_requires (gfc_namespace *, int); void gfc_free_omp_clauses (gfc_omp_clauses *); void gfc_free_oacc_declare_clauses (struct gfc_oacc_declare *); void gfc_free_omp_declare_simd (gfc_omp_declare_simd *); @@ -3547,6 +3595,7 @@ bool gfc_calculate_transfer_sizes (gfc_expr*, gfc_expr*, gfc_expr*, bool gfc_boz2int (gfc_expr *, int); bool gfc_boz2real (gfc_expr *, int); bool gfc_invalid_boz (const char *, locus *); +bool gfc_invalid_null_arg (gfc_expr *); /* class.c */ @@ -3604,6 +3653,7 @@ int gfc_expr_walker (gfc_expr **, walk_expr_fn_t, void *); int gfc_code_walker (gfc_code **, walk_code_fn_t, walk_expr_fn_t, void *); bool gfc_has_dimen_vector_ref (gfc_expr *e); void gfc_check_externals (gfc_namespace *); +bool gfc_fix_implicit_pure (gfc_namespace *); /* simplify.c */ diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi index 20fe385..151e3d7 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -541,8 +541,8 @@ can be found in the @ref{Fortran 2003 status}, @ref{Fortran 2008 status} and @ref{Fortran 2018 status} sections of the documentation. Additionally, the GNU Fortran compilers supports the OpenMP specification -(version 4.0 and most of the features of the 4.5 version, -@url{http://openmp.org/@/wp/@/openmp-specifications/}). +(version 4.5 and partial support of the features of the 5.0 version, +@url{http://openmp.org/@/openmp-specifications/}). There also is support for the OpenACC specification (targeting version 2.6, @uref{http://www.openacc.org/}). See @uref{https://gcc.gnu.org/wiki/OpenACC} for more information. @@ -862,7 +862,7 @@ deferred character length left-hand sides are correctly handled but arrays are not yet fully implemented. @item Deferred-length character variables and scalar deferred-length character -components of derived types are supported. (Note that array-valued compoents +components of derived types are supported. (Note that array-valued components are not yet implemented.) @item Transferring of allocations via @code{MOVE_ALLOC}. @@ -4168,7 +4168,7 @@ an array descriptor. All other arrays pass the address of the first element of the array. With @option{-fcoarray=lib}, the token and the offset belonging to nonallocatable coarrays dummy arguments are passed as hidden argument along the character length hidden -arguments. The token is an oparque pointer identifying the coarray +arguments. The token is an opaque pointer identifying the coarray and the offset is a passed-by-value integer of kind @code{C_PTRDIFF_T}, denoting the byte offset between the base address of the coarray and the passed scalar or first element of the passed array. @@ -4362,7 +4362,7 @@ typedef struct caf_reference_t { The references make up a single linked list of reference operations. The @code{NEXT} member links to the next reference or NULL to indicate the end of -the chain. Component and array refs can be arbitrarly mixed as long as they +the chain. Component and array refs can be arbitrarily mixed as long as they comply to the Fortran standard. @emph{NOTES} @@ -4683,7 +4683,7 @@ status. Note that for critical blocks, the locking is only required on one image; in the locking statement, the processor shall always pass an image index of one for critical-block lock variables (@code{CAF_REGTYPE_CRITICAL}). For lock types and critical-block variables, -the initial value shall be unlocked (or, respecitively, not in critical +the initial value shall be unlocked (or, respectively, not in critical section) such as the value false; for event types, the initial state should be no event, e.g. zero. @end table @@ -5134,7 +5134,7 @@ error message why the operation is not permitted. @table @asis @item @emph{Description}: Acquire a lock on the given image on a scalar locking variable or for the -given array element for an array-valued variable. If the @var{aquired_lock} +given array element for an array-valued variable. If the @var{acquired_lock} is @code{NULL}, the function returns after having obtained the lock. If it is non-@code{NULL}, then @var{acquired_lock} is assigned the value true (one) when the lock could be obtained and false (zero) otherwise. Locking a lock variable @@ -5142,7 +5142,7 @@ which has already been locked by the same image is an error. @item @emph{Syntax}: @code{void _gfortran_caf_lock (caf_token_t token, size_t index, int image_index, -int *aquired_lock, int *stat, char *errmsg, size_t errmsg_len)} +int *acquired_lock, int *stat, char *errmsg, size_t errmsg_len)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -5151,7 +5151,7 @@ int *aquired_lock, int *stat, char *errmsg, size_t errmsg_len)} scalars, it is always 0. @item @var{image_index} @tab intent(in) The ID of the remote image; must be a positive number. -@item @var{aquired_lock} @tab intent(out) If not NULL, it returns whether lock +@item @var{acquired_lock} @tab intent(out) If not NULL, it returns whether lock could be obtained. @item @var{stat} @tab intent(out) Stores the STAT=; may be NULL. @item @var{errmsg} @tab intent(out) When an error occurs, this will be set to diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index ba1c8bc..7985fc7 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1257,7 +1257,7 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2, while (f1) { - if (f1->sym->attr.optional) + if (!f1->sym || f1->sym->attr.optional) goto next; if (p1 && strcmp (f1->sym->name, p1) == 0) @@ -1343,7 +1343,8 @@ gfc_check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2, } /* Check INTENT. */ - if (s1->attr.intent != s2->attr.intent) + if (s1->attr.intent != s2->attr.intent && !s1->attr.artificial + && !s2->attr.artificial) { snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'", s1->name); @@ -1465,6 +1466,19 @@ gfc_check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2, int i, compval; gfc_expr *shape1, *shape2; + /* Sometimes the ambiguity between deferred shape and assumed shape + does not get resolved in module procedures, where the only explicit + declaration of the dummy is in the interface. */ + if (s1->ns->proc_name && s1->ns->proc_name->attr.module_procedure + && s1->as->type == AS_ASSUMED_SHAPE + && s2->as->type == AS_DEFERRED) + { + s2->as->type = AS_ASSUMED_SHAPE; + for (i = 0; i < s2->as->rank; i++) + if (s1->as->lower[i] != NULL) + s2->as->lower[i] = gfc_copy_expr (s1->as->lower[i]); + } + if (s1->as->type != s2->as->type) { snprintf (errmsg, err_len, "Shape mismatch in argument '%s'", @@ -1981,7 +1995,8 @@ check_interface1 (gfc_interface *p, gfc_interface *q0, static void check_sym_interfaces (gfc_symbol *sym) { - char interface_name[GFC_MAX_SYMBOL_LEN + sizeof("generic interface ''")]; + /* Provide sufficient space to hold "generic interface 'symbol.symbol'". */ + char interface_name[2*GFC_MAX_SYMBOL_LEN+2 + sizeof("generic interface ''")]; gfc_interface *p; if (sym->ns != gfc_current_ns) @@ -1989,6 +2004,8 @@ check_sym_interfaces (gfc_symbol *sym) if (sym->generic != NULL) { + size_t len = strlen (sym->name) + sizeof("generic interface ''"); + gcc_assert (len < sizeof (interface_name)); sprintf (interface_name, "generic interface '%s'", sym->name); if (check_interface0 (sym->generic, interface_name)) return; @@ -2613,7 +2630,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, || (actual->rank == 0 && formal->attr.dimension && gfc_is_coindexed (actual))) { - if (where + if (where && (!formal->attr.artificial || (!formal->maybe_array && !maybe_dummy_array_arg (actual)))) { @@ -2704,7 +2721,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, if (ref == NULL && actual->expr_type != EXPR_NULL) { - if (where + if (where && (!formal->attr.artificial || (!formal->maybe_array && !maybe_dummy_array_arg (actual)))) { @@ -3961,7 +3978,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) if (!gfc_compare_actual_formal (ap, dummy_args, 0, sym->attr.elemental, sym->attr.proc == PROC_ST_FUNCTION, where)) return false; - + if (!check_intents (dummy_args, *ap)) return false; @@ -5015,7 +5032,7 @@ check_dtio_interface1 (gfc_symbol *derived, gfc_symtree *tb_io_st, gfc_error ("DTIO procedure %qs at %L must be a subroutine", dtio_sub->name, &dtio_sub->declared_at); - if (!dtio_sub->resolved) + if (!dtio_sub->resolve_symbol_called) gfc_resolve_formal_arglist (dtio_sub); arg_num = 0; @@ -5149,7 +5166,8 @@ gfc_find_typebound_dtio_proc (gfc_symbol *derived, bool write, bool formatted) gfc_symtree *tb_io_st = NULL; bool t = false; - if (!derived || !derived->resolved || derived->attr.flavor != FL_DERIVED) + if (!derived || !derived->resolve_symbol_called + || derived->attr.flavor != FL_DERIVED) return NULL; /* Try to find a typebound DTIO binding. */ diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 17f5efc..ef33587 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -2733,8 +2733,8 @@ add_functions (void) make_generic ("null", GFC_ISYM_NULL, GFC_STD_F95); - add_sym_2 ("num_images", GFC_ISYM_NUM_IMAGES, CLASS_INQUIRY, ACTUAL_NO, - BT_INTEGER, di, GFC_STD_F2008, + add_sym_2 ("num_images", GFC_ISYM_NUM_IMAGES, CLASS_TRANSFORMATIONAL, + ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, gfc_check_num_images, gfc_simplify_num_images, NULL, dist, BT_INTEGER, di, OPTIONAL, failed, BT_LOGICAL, dl, OPTIONAL); @@ -3174,7 +3174,7 @@ add_functions (void) make_generic ("tanh", GFC_ISYM_TANH, GFC_STD_F77); add_sym_1 ("team_number", GFC_ISYM_TEAM_NUMBER, CLASS_TRANSFORMATIONAL, - ACTUAL_YES, BT_INTEGER, di, GFC_STD_F2018, + ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2018, gfc_check_team_number, NULL, gfc_resolve_team_number, team, BT_DERIVED, di, OPTIONAL); @@ -4442,6 +4442,18 @@ check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym, return false; } + /* F2018, p. 328: An argument to an intrinsic procedure other than + ASSOCIATED, NULL, or PRESENT shall be a data object. An EXPR_NULL + is not a data object. */ + if (actual->expr->expr_type == EXPR_NULL + && (!(sym->id == GFC_ISYM_ASSOCIATED + || sym->id == GFC_ISYM_NULL + || sym->id == GFC_ISYM_PRESENT))) + { + gfc_invalid_null_arg (actual->expr); + return false; + } + /* If the formal argument is INTENT([IN]OUT), check for definability. */ if (formal->intent == INTENT_INOUT || formal->intent == INTENT_OUT) { @@ -4763,8 +4775,8 @@ check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag) for ( ; arg && arg->expr; arg = arg->next, n++) if (!gfc_check_conformance (first_expr, arg->expr, - "arguments '%s' and '%s' for " - "intrinsic '%s'", + _("arguments '%s' and '%s' for " + "intrinsic '%s'"), gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic)) @@ -4800,39 +4812,39 @@ gfc_check_intrinsic_standard (const gfc_intrinsic_sym* isym, switch (isym->standard) { case GFC_STD_F77: - symstd_msg = "available since Fortran 77"; + symstd_msg = _("available since Fortran 77"); break; case GFC_STD_F95_OBS: - symstd_msg = "obsolescent in Fortran 95"; + symstd_msg = _("obsolescent in Fortran 95"); break; case GFC_STD_F95_DEL: - symstd_msg = "deleted in Fortran 95"; + symstd_msg = _("deleted in Fortran 95"); break; case GFC_STD_F95: - symstd_msg = "new in Fortran 95"; + symstd_msg = _("new in Fortran 95"); break; case GFC_STD_F2003: - symstd_msg = "new in Fortran 2003"; + symstd_msg = _("new in Fortran 2003"); break; case GFC_STD_F2008: - symstd_msg = "new in Fortran 2008"; + symstd_msg = _("new in Fortran 2008"); break; case GFC_STD_F2018: - symstd_msg = "new in Fortran 2018"; + symstd_msg = _("new in Fortran 2018"); break; case GFC_STD_GNU: - symstd_msg = "a GNU Fortran extension"; + symstd_msg = _("a GNU Fortran extension"); break; case GFC_STD_LEGACY: - symstd_msg = "for backward compatibility"; + symstd_msg = _("for backward compatibility"); break; default: @@ -4845,8 +4857,8 @@ gfc_check_intrinsic_standard (const gfc_intrinsic_sym* isym, { /* Do only print a warning if not a GNU extension. */ if (!silent && isym->standard != GFC_STD_GNU) - gfc_warning (0, "Intrinsic %qs (is %s) is used at %L", - isym->name, _(symstd_msg), &where); + gfc_warning (0, "Intrinsic %qs (%s) used at %L", + isym->name, symstd_msg, &where); return true; } @@ -4857,7 +4869,7 @@ gfc_check_intrinsic_standard (const gfc_intrinsic_sym* isym, /* Otherwise, fail. */ if (symstd) - *symstd = _(symstd_msg); + *symstd = symstd_msg; return false; } @@ -5233,8 +5245,10 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag, { /* Larger kinds can hold values of smaller kinds without problems. Hence, only warn if target kind is smaller than the source - kind - or if -Wconversion-extra is specified. */ - if (expr->expr_type != EXPR_CONSTANT) + kind - or if -Wconversion-extra is specified. LOGICAL values + will always fit regardless of kind so ignore conversion. */ + if (expr->expr_type != EXPR_CONSTANT + && ts->type != BT_LOGICAL) { if (warn_conversion && from_ts.kind > ts->kind) gfc_warning_now (OPT_Wconversion, "Possible change of value in " diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index a1ecf59..13325ed 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -8325,7 +8325,7 @@ Elemental function @item @emph{Arguments}: @multitable @columnfractions .15 .70 @item @var{A} @tab Shall be of type @code{INTEGER}, -@code{REAL}, or @code{COMPLEX} or or a boz-literal-constant. +@code{REAL}, or @code{COMPLEX} or a boz-literal-constant. @item @var{KIND} @tab (Optional) An @code{INTEGER} initialization expression indicating the kind parameter of the result. @end multitable @@ -10416,7 +10416,7 @@ Transformational function @item @var{DIM} @tab (Optional) Shall be a scalar of type @code{INTEGER}, with a value between one and the rank of @var{ARRAY}, inclusive. It may not be an optional dummy argument. -@item @var{MASK} @tab (Opional) Shall be an array of type @code{LOGICAL}, +@item @var{MASK} @tab (Optional) Shall be an array of type @code{LOGICAL}, and conformable with @var{ARRAY}. @end multitable @@ -15291,12 +15291,12 @@ with the following options: @code{-fno-unsafe-math-optimizations @section OpenMP Modules @code{OMP_LIB} and @code{OMP_LIB_KINDS} @table @asis @item @emph{Standard}: -OpenMP Application Program Interface v4.5 +OpenMP Application Program Interface v4.5 and +OpenMP Application Program Interface v5.0 (partially supported). @end table - The OpenMP Fortran runtime library routines are provided both in -a form of two Fortran 90 modules, named @code{OMP_LIB} and +a form of two Fortran modules, named @code{OMP_LIB} and @code{OMP_LIB_KINDS}, and in a form of a Fortran @code{include} file named @file{omp_lib.h}. The procedures provided by @code{OMP_LIB} can be found in the @ref{Top,,Introduction,libgomp,GNU Offloading and Multi @@ -15306,19 +15306,26 @@ below. For details refer to the actual @uref{http://www.openmp.org/wp-content/uploads/openmp-4.5.pdf, -OpenMP Application Program Interface v4.5}. -And for the @code{pause}-related constants to the OpenMP 5.0 specification. +OpenMP Application Program Interface v4.5} and +@uref{https://www.openmp.org/wp-content/uploads/OpenMP-API-Specification-5.0.pdf, +OpenMP Application Program Interface v5.0}. @code{OMP_LIB_KINDS} provides the following scalar default-integer named constants: @table @asis +@item @code{omp_allocator_handle_kind} +@item @code{omp_alloctrait_key_kind} +@item @code{omp_alloctrait_val_kind} +@item @code{omp_depend_kind} @item @code{omp_lock_kind} @item @code{omp_lock_hint_kind} @item @code{omp_nest_lock_kind} @item @code{omp_pause_resource_kind} +@item @code{omp_memspace_handle_kind} @item @code{omp_proc_bind_kind} @item @code{omp_sched_kind} +@item @code{omp_sync_hint_kind} @end table @code{OMP_LIB} provides the scalar default-integer @@ -15326,6 +15333,12 @@ named constant @code{openmp_version} with a value of the form @var{yyyymm}, where @code{yyyy} is the year and @var{mm} the month of the OpenMP version; for OpenMP v4.5 the value is @code{201511}. +The following derived type: + +@table @asis +@item @code{omp_alloctrait} +@end table + The following scalar integer named constants of the kind @code{omp_sched_kind}: @@ -15336,7 +15349,7 @@ kind @code{omp_sched_kind}: @item @code{omp_sched_auto} @end table -And the following scalar integer named constants of the +And the following scalar integer named constants of the kind @code{omp_proc_bind_kind}: @table @asis @@ -15356,6 +15369,11 @@ kind @code{omp_lock_hint_kind}: @item @code{omp_lock_hint_contended} @item @code{omp_lock_hint_nonspeculative} @item @code{omp_lock_hint_speculative} +@item @code{omp_sync_hint_none} +@item @code{omp_sync_hint_uncontended} +@item @code{omp_sync_hint_contended} +@item @code{omp_sync_hint_nonspeculative} +@item @code{omp_sync_hint_speculative} @end table And the following two scalar integer named constants are of the @@ -15366,6 +15384,73 @@ kind @code{omp_pause_resource_kind}: @item @code{omp_pause_hard} @end table +The following scalar integer named constants are of the kind +@code{omp_alloctrait_key_kind}: + +@table @asis +@item @code{omp_atk_sync_hint} +@item @code{omp_atk_alignment} +@item @code{omp_atk_access} +@item @code{omp_atk_pool_size} +@item @code{omp_atk_fallback} +@item @code{omp_atk_fb_data} +@item @code{omp_atk_pinned} +@item @code{omp_atk_partition} +@end table + +The following scalar integer named constants are of the kind +@code{omp_alloctrait_val_kind}: + +@table @asis +@code{omp_alloctrait_key_kind}: +@item @code{omp_atv_default} +@item @code{omp_atv_false} +@item @code{omp_atv_true} +@item @code{omp_atv_contended} +@item @code{omp_atv_uncontended} +@item @code{omp_atv_serialized} +@item @code{omp_atv_sequential} +@item @code{omp_atv_private} +@item @code{omp_atv_all} +@item @code{omp_atv_thread} +@item @code{omp_atv_pteam} +@item @code{omp_atv_cgroup} +@item @code{omp_atv_default_mem_fb} +@item @code{omp_atv_null_fb} +@item @code{omp_atv_abort_fb} +@item @code{omp_atv_allocator_fb} +@item @code{omp_atv_environment} +@item @code{omp_atv_nearest} +@item @code{omp_atv_blocked} +@end table + +The following scalar integer named constants are of the kind +@code{omp_allocator_handle_kind}: + +@table @asis +@item @code{omp_null_allocator} +@item @code{omp_default_mem_alloc} +@item @code{omp_large_cap_mem_alloc} +@item @code{omp_const_mem_alloc} +@item @code{omp_high_bw_mem_alloc} +@item @code{omp_low_lat_mem_alloc} +@item @code{omp_cgroup_mem_alloc} +@item @code{omp_pteam_mem_alloc} +@item @code{omp_thread_mem_alloc} +@end table + +The following scalar integer named constants are of the kind +@code{omp_memspace_handle_kind}: + +@table @asis +@item @code{omp_default_mem_space} +@item @code{omp_large_cap_mem_space} +@item @code{omp_const_mem_space} +@item @code{omp_high_bw_mem_space} +@item @code{omp_low_lat_mem_space} +@end table + + @node OpenACC Module OPENACC @section OpenACC Module @code{OPENACC} diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi index 052d317..8bdc8a6 100644 --- a/gcc/fortran/invoke.texi +++ b/gcc/fortran/invoke.texi @@ -235,11 +235,11 @@ intrinsic will be called except when it is explicitly declared @code{EXTERNAL}. @item -fallow-argument-mismatch @opindex @code{fallow-argument-mismatch} -Some code contains calls to external procedures whith mismatches +Some code contains calls to external procedures with mismatches between the calls and the procedure definition, or with mismatches between different calls. Such code is non-conforming, and will usually -be flagged wi1th an error. This options degrades the error to a -warning, which can only be disabled by disabling all warnings vial +be flagged with an error. This options degrades the error to a +warning, which can only be disabled by disabling all warnings via @option{-w}. Only a single occurrence per argument is flagged by this warning. @option{-fallow-argument-mismatch} is implied by @option{-std=legacy}. @@ -1826,7 +1826,7 @@ The default value for @var{n} is 30. @item -finline-matmul-limit=@var{n} @opindex @code{finline-matmul-limit} -When front-end optimiztion is active, some calls to the @code{MATMUL} +When front-end optimization is active, some calls to the @code{MATMUL} intrinsic function will be inlined. This may result in code size increase if the size of the matrix cannot be determined at compile time, as code for both cases is generated. Setting diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c index 981cf9e..b350cd9 100644 --- a/gcc/fortran/io.c +++ b/gcc/fortran/io.c @@ -2406,7 +2406,7 @@ check_open_constraints (gfc_open *open, locus *where) && open->recl->ts.type == BT_INTEGER && mpz_sgn (open->recl->value.integer) != 1) { - warn_or_error ("RECL in OPEN statement at %L must be positive", + warn_or_error (G_("RECL in OPEN statement at %L must be positive"), &open->recl->where); } @@ -2431,8 +2431,8 @@ check_open_constraints (gfc_open *open, locus *where) { char *s = gfc_widechar_to_char (open->status->value.character.string, -1); - warn_or_error ("The STATUS specified in OPEN statement at %L is " - "%qs and no FILE specifier is present", + warn_or_error (G_("The STATUS specified in OPEN statement at %L is " + "%qs and no FILE specifier is present"), &open->status->where, s); free (s); } @@ -2442,9 +2442,9 @@ check_open_constraints (gfc_open *open, locus *where) if (gfc_wide_strncasecmp (open->status->value.character.string, "scratch", 7) == 0 && open->file) { - warn_or_error ("The STATUS specified in OPEN statement at %L " + warn_or_error (G_("The STATUS specified in OPEN statement at %L " "cannot have the value SCRATCH if a FILE specifier " - "is present", &open->status->where); + "is present"), &open->status->where); } } @@ -2506,16 +2506,16 @@ check_open_constraints (gfc_open *open, locus *where) spec = ""; } - warn_or_error ("%s specifier at %L not allowed in OPEN statement for " - "unformatted I/O", spec, loc); + warn_or_error (G_("%s specifier at %L not allowed in OPEN statement for " + "unformatted I/O"), spec, loc); } if (open->recl && open->access && open->access->expr_type == EXPR_CONSTANT && gfc_wide_strncasecmp (open->access->value.character.string, "stream", 6) == 0) { - warn_or_error ("RECL specifier not allowed in OPEN statement at %L for " - "stream I/O", &open->recl->where); + warn_or_error (G_("RECL specifier not allowed in OPEN statement at %L for " + "stream I/O"), &open->recl->where); } if (open->position @@ -2527,8 +2527,8 @@ check_open_constraints (gfc_open *open, locus *where) || gfc_wide_strncasecmp (open->access->value.character.string, "append", 6) == 0)) { - warn_or_error ("POSITION specifier in OPEN statement at %L only allowed " - "for stream or sequential ACCESS", &open->position->where); + warn_or_error (G_("POSITION specifier in OPEN statement at %L only allowed " + "for stream or sequential ACCESS"), &open->position->where); } return true; @@ -3665,8 +3665,8 @@ match_io_element (io_kind k, gfc_code **cpp) if (m == MATCH_YES && expr->ts.type == BT_BOZ) { - if (gfc_invalid_boz ("BOZ literal constant at %L cannot appear in " - "an output IO list", &gfc_current_locus)) + if (gfc_invalid_boz (G_("BOZ literal constant at %L cannot appear in" + " an output IO list"), &gfc_current_locus)) return MATCH_ERROR; if (!gfc_boz2int (expr, gfc_max_integer_kind)) return MATCH_ERROR; diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 7ecb659..7376961 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -47,7 +47,8 @@ along with GCC; see the file COPYING3. If not see const char * gfc_get_string (const char *format, ...) { - char temp_name[128]; + /* Provide sufficient space for "_F.caf_token__symbol.symbol_MOD_symbol". */ + char temp_name[15 + 2*GFC_MAX_SYMBOL_LEN + 5 + GFC_MAX_SYMBOL_LEN + 1]; const char *str; va_list ap; tree ident; diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h index d097caa..6a9139c 100644 --- a/gcc/fortran/libgfortran.h +++ b/gcc/fortran/libgfortran.h @@ -124,6 +124,7 @@ typedef enum LIBERROR_SHORT_RECORD, LIBERROR_CORRUPT_FILE, LIBERROR_INQUIRE_INTERNAL_UNIT, /* Must be different from STAT_STOPPED_IMAGE. */ + LIBERROR_BAD_WAIT_ID, LIBERROR_LAST /* Not a real error, the last error # + 1. */ } libgfortran_error_codes; diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 8ae34a9..cb09c5f 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -2265,7 +2265,10 @@ found: a scalar integer initialization-expr and valid kind parameter. */ if (c == ')') { - if (e->ts.type != BT_INTEGER || e->rank > 0) + bool ok = true; + if (e->expr_type != EXPR_CONSTANT && e->expr_type != EXPR_VARIABLE) + ok = gfc_reduce_init_expr (e); + if (!ok || e->ts.type != BT_INTEGER || e->rank > 0) { gfc_free_expr (e); return MATCH_NO; @@ -5697,6 +5700,11 @@ gfc_match_equivalence (void) if (!gfc_add_in_equivalence (&sym->attr, sym->name, NULL)) goto cleanup; + if (sym->ts.type == BT_CLASS + && CLASS_DATA (sym) + && !gfc_add_in_equivalence (&CLASS_DATA (sym)->attr, + sym->name, NULL)) + goto cleanup; if (sym->attr.in_common) { @@ -6151,14 +6159,18 @@ copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector) while (ref && ref->next) ref = ref->next; - if (selector->ts.type == BT_CLASS && CLASS_DATA (selector)->as + if (selector->ts.type == BT_CLASS + && CLASS_DATA (selector) + && CLASS_DATA (selector)->as && CLASS_DATA (selector)->as->type == AS_ASSUMED_RANK) { assoc_sym->attr.dimension = 1; assoc_sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as); goto build_class_sym; } - else if (selector->ts.type == BT_CLASS && CLASS_DATA (selector)->as + else if (selector->ts.type == BT_CLASS + && CLASS_DATA (selector) + && CLASS_DATA (selector)->as && ref && ref->type == REF_ARRAY) { /* Ensure that the array reference type is set. We cannot use @@ -6215,7 +6227,8 @@ build_class_sym: { /* The correct class container has to be available. */ assoc_sym->ts.type = BT_CLASS; - assoc_sym->ts.u.derived = CLASS_DATA (selector)->ts.u.derived; + assoc_sym->ts.u.derived = CLASS_DATA (selector) + ? CLASS_DATA (selector)->ts.u.derived : selector->ts.u.derived; assoc_sym->attr.pointer = 1; gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr, &assoc_sym->as); } @@ -6488,7 +6501,7 @@ static void select_rank_set_tmp (gfc_typespec *ts, int *case_value) { char name[2 * GFC_MAX_SYMBOL_LEN]; - char tname[GFC_MAX_SYMBOL_LEN]; + char tname[GFC_MAX_SYMBOL_LEN + 7]; gfc_symtree *tmp; gfc_symbol *selector = select_type_stack->selector; gfc_symbol *sym; @@ -6634,7 +6647,8 @@ gfc_match_select_rank (void) if (expr2->symtree) { sym2 = expr2->symtree->n.sym; - as = sym2->ts.type == BT_CLASS ? CLASS_DATA (sym2)->as : sym2->as; + as = (sym2->ts.type == BT_CLASS + && CLASS_DATA (sym2)) ? CLASS_DATA (sym2)->as : sym2->as; } if (expr2->expr_type != EXPR_VARIABLE @@ -6646,7 +6660,7 @@ gfc_match_select_rank (void) goto cleanup; } - if (expr2->ts.type == BT_CLASS) + if (expr2->ts.type == BT_CLASS && CLASS_DATA (sym2)) { copy_ts_from_selector_to_associate (expr1, expr2); @@ -6687,7 +6701,8 @@ gfc_match_select_rank (void) if (expr1->symtree) { sym = expr1->symtree->n.sym; - as = sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->as : sym->as; + as = (sym->ts.type == BT_CLASS + && CLASS_DATA (sym)) ? CLASS_DATA (sym)->as : sym->as; } if (expr1->expr_type != EXPR_VARIABLE diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index b3fb703..7bf70d7 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -177,6 +177,7 @@ match gfc_match_omp_parallel_do (void); match gfc_match_omp_parallel_do_simd (void); match gfc_match_omp_parallel_sections (void); match gfc_match_omp_parallel_workshare (void); +match gfc_match_omp_requires (void); match gfc_match_omp_sections (void); match gfc_match_omp_simd (void); match gfc_match_omp_single (void); diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c index 0fc25df..65bcfa6 100644 --- a/gcc/fortran/misc.c +++ b/gcc/fortran/misc.c @@ -122,7 +122,7 @@ gfc_basic_typename (bt type) the argument list of a single statement. */ const char * -gfc_typename (gfc_typespec *ts) +gfc_typename (gfc_typespec *ts, bool for_hash) { static char buffer1[GFC_MAX_SYMBOL_LEN + 7]; /* 7 for "TYPE()" + '\0'. */ static char buffer2[GFC_MAX_SYMBOL_LEN + 7]; @@ -149,6 +149,12 @@ gfc_typename (gfc_typespec *ts) sprintf (buffer, "LOGICAL(%d)", ts->kind); break; case BT_CHARACTER: + if (for_hash) + { + sprintf (buffer, "CHARACTER(%d)", ts->kind); + break; + } + if (ts->u.cl && ts->u.cl->length) length = gfc_mpz_get_hwi (ts->u.cl->length->value.integer); if (ts->kind == gfc_default_character_kind) @@ -397,7 +403,7 @@ gfc_closest_fuzzy_match (const char *typo, char **candidates) likely to be meaningless. */ if (best) { - unsigned int cutoff = MAX (tl, strlen (best)) / 2; + unsigned int cutoff = MAX (tl, strlen (best)); if (best_distance > cutoff) { diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index eccf92b..5114d55 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -2047,7 +2047,11 @@ enum ab_attribute AB_OMP_DECLARE_TARGET_LINK, AB_PDT_KIND, AB_PDT_LEN, AB_PDT_TYPE, AB_PDT_TEMPLATE, AB_PDT_ARRAY, AB_PDT_STRING, AB_OACC_ROUTINE_LOP_GANG, AB_OACC_ROUTINE_LOP_WORKER, - AB_OACC_ROUTINE_LOP_VECTOR, AB_OACC_ROUTINE_LOP_SEQ + AB_OACC_ROUTINE_LOP_VECTOR, AB_OACC_ROUTINE_LOP_SEQ, + AB_OMP_REQ_REVERSE_OFFLOAD, AB_OMP_REQ_UNIFIED_ADDRESS, + AB_OMP_REQ_UNIFIED_SHARED_MEMORY, AB_OMP_REQ_DYNAMIC_ALLOCATORS, + AB_OMP_REQ_MEM_ORDER_SEQ_CST, AB_OMP_REQ_MEM_ORDER_ACQ_REL, + AB_OMP_REQ_MEM_ORDER_RELAXED }; static const mstring attr_bits[] = @@ -2121,6 +2125,13 @@ static const mstring attr_bits[] = minit ("OACC_ROUTINE_LOP_WORKER", AB_OACC_ROUTINE_LOP_WORKER), minit ("OACC_ROUTINE_LOP_VECTOR", AB_OACC_ROUTINE_LOP_VECTOR), minit ("OACC_ROUTINE_LOP_SEQ", AB_OACC_ROUTINE_LOP_SEQ), + minit ("OMP_REQ_REVERSE_OFFLOAD", AB_OMP_REQ_REVERSE_OFFLOAD), + minit ("OMP_REQ_UNIFIED_ADDRESS", AB_OMP_REQ_UNIFIED_ADDRESS), + minit ("OMP_REQ_UNIFIED_SHARED_MEMORY", AB_OMP_REQ_UNIFIED_SHARED_MEMORY), + minit ("OMP_REQ_DYNAMIC_ALLOCATORS", AB_OMP_REQ_DYNAMIC_ALLOCATORS), + minit ("OMP_REQ_MEM_ORDER_SEQ_CST", AB_OMP_REQ_MEM_ORDER_SEQ_CST), + minit ("OMP_REQ_MEM_ORDER_ACQ_REL", AB_OMP_REQ_MEM_ORDER_ACQ_REL), + minit ("OMP_REQ_MEM_ORDER_RELAXED", AB_OMP_REQ_MEM_ORDER_RELAXED), minit (NULL, -1) }; @@ -2366,8 +2377,27 @@ mio_symbol_attribute (symbol_attribute *attr) gcc_unreachable (); } + if (attr->flavor == FL_MODULE && gfc_current_ns->omp_requires) + { + if (gfc_current_ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD) + MIO_NAME (ab_attribute) (AB_OMP_REQ_REVERSE_OFFLOAD, attr_bits); + if (gfc_current_ns->omp_requires & OMP_REQ_UNIFIED_ADDRESS) + MIO_NAME (ab_attribute) (AB_OMP_REQ_UNIFIED_ADDRESS, attr_bits); + if (gfc_current_ns->omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY) + MIO_NAME (ab_attribute) (AB_OMP_REQ_UNIFIED_SHARED_MEMORY, attr_bits); + if (gfc_current_ns->omp_requires & OMP_REQ_DYNAMIC_ALLOCATORS) + MIO_NAME (ab_attribute) (AB_OMP_REQ_DYNAMIC_ALLOCATORS, attr_bits); + if ((gfc_current_ns->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK) + == OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST) + MIO_NAME (ab_attribute) (AB_OMP_REQ_MEM_ORDER_SEQ_CST, attr_bits); + if ((gfc_current_ns->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK) + == OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL) + MIO_NAME (ab_attribute) (AB_OMP_REQ_MEM_ORDER_ACQ_REL, attr_bits); + if ((gfc_current_ns->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK) + == OMP_REQ_ATOMIC_MEM_ORDER_RELAXED) + MIO_NAME (ab_attribute) (AB_OMP_REQ_MEM_ORDER_RELAXED, attr_bits); + } mio_rparen (); - } else { @@ -2592,6 +2622,45 @@ mio_symbol_attribute (symbol_attribute *attr) verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop); attr->oacc_routine_lop = OACC_ROUTINE_LOP_SEQ; break; + case AB_OMP_REQ_REVERSE_OFFLOAD: + gfc_omp_requires_add_clause (OMP_REQ_REVERSE_OFFLOAD, + "reverse_offload", + &gfc_current_locus, + module_name); + break; + case AB_OMP_REQ_UNIFIED_ADDRESS: + gfc_omp_requires_add_clause (OMP_REQ_UNIFIED_ADDRESS, + "unified_address", + &gfc_current_locus, + module_name); + break; + case AB_OMP_REQ_UNIFIED_SHARED_MEMORY: + gfc_omp_requires_add_clause (OMP_REQ_UNIFIED_SHARED_MEMORY, + "unified_shared_memory", + &gfc_current_locus, + module_name); + break; + case AB_OMP_REQ_DYNAMIC_ALLOCATORS: + gfc_omp_requires_add_clause (OMP_REQ_DYNAMIC_ALLOCATORS, + "dynamic_allocators", + &gfc_current_locus, + module_name); + break; + case AB_OMP_REQ_MEM_ORDER_SEQ_CST: + gfc_omp_requires_add_clause (OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST, + "seq_cst", &gfc_current_locus, + module_name); + break; + case AB_OMP_REQ_MEM_ORDER_ACQ_REL: + gfc_omp_requires_add_clause (OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL, + "acq_rel", &gfc_current_locus, + module_name); + break; + case AB_OMP_REQ_MEM_ORDER_RELAXED: + gfc_omp_requires_add_clause (OMP_REQ_ATOMIC_MEM_ORDER_RELAXED, + "relaxed", &gfc_current_locus, + module_name); + break; } } } diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c index 930bca5..4d33a45 100644 --- a/gcc/fortran/openmp.c +++ b/gcc/fortran/openmp.c @@ -766,6 +766,7 @@ enum omp_mask1 OMP_CLAUSE_NUM_THREADS, OMP_CLAUSE_SCHEDULE, OMP_CLAUSE_DEFAULT, + OMP_CLAUSE_ORDER, OMP_CLAUSE_ORDERED, OMP_CLAUSE_COLLAPSE, OMP_CLAUSE_UNTIED, @@ -793,6 +794,7 @@ enum omp_mask1 OMP_CLAUSE_IS_DEVICE_PTR, OMP_CLAUSE_LINK, OMP_CLAUSE_NOGROUP, + OMP_CLAUSE_NOTEMPORAL, OMP_CLAUSE_NUM_TASKS, OMP_CLAUSE_PRIORITY, OMP_CLAUSE_SIMD, @@ -1303,7 +1305,9 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, { /* This should match the enum gfc_omp_if_kind order. */ static const char *ifs[OMP_IF_LAST] = { + " cancel : %e )", " parallel : %e )", + " simd : %e )", " task : %e )", " taskloop : %e )", " target : %e )", @@ -1353,10 +1357,22 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, break; case 'l': if ((mask & OMP_CLAUSE_LASTPRIVATE) - && gfc_match_omp_variable_list ("lastprivate (", - &c->lists[OMP_LIST_LASTPRIVATE], - true) == MATCH_YES) - continue; + && gfc_match ("lastprivate ( ") == MATCH_YES) + { + bool conditional = gfc_match ("conditional : ") == MATCH_YES; + head = NULL; + if (gfc_match_omp_variable_list ("", + &c->lists[OMP_LIST_LASTPRIVATE], + false, NULL, &head) == MATCH_YES) + { + gfc_omp_namelist *n; + for (n = *head; n; n = n->next) + n->u.lastprivate_conditional = conditional; + continue; + } + gfc_current_locus = old_loc; + break; + } end_colon = false; head = NULL; if ((mask & OMP_CLAUSE_LINEAR) @@ -1464,7 +1480,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, head = NULL; if (gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_MAP], false, NULL, &head, - true) == MATCH_YES) + true, true) == MATCH_YES) { gfc_omp_namelist *n; for (n = *head; n; n = n->next) @@ -1495,6 +1511,11 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, c->nogroup = needs_space = true; continue; } + if ((mask & OMP_CLAUSE_NOTEMPORAL) + && gfc_match_omp_variable_list ("nontemporal (", + &c->lists[OMP_LIST_NONTEMPORAL], + true) == MATCH_YES) + continue; if ((mask & OMP_CLAUSE_NOTINBRANCH) && !c->notinbranch && !c->inbranch @@ -1535,6 +1556,13 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, continue; break; case 'o': + if ((mask & OMP_CLAUSE_ORDER) + && !c->order_concurrent + && gfc_match ("order ( concurrent )") == MATCH_YES) + { + c->order_concurrent = true; + continue; + } if ((mask & OMP_CLAUSE_ORDERED) && !c->ordered && gfc_match ("ordered") == MATCH_YES) @@ -2525,6 +2553,14 @@ gfc_match_oacc_routine (void) /* Something has gone wrong, possibly a syntax error. */ goto cleanup; + if (gfc_pure (NULL) && c && (c->gang || c->worker || c->vector)) + { + gfc_error ("!$ACC ROUTINE with GANG, WORKER, or VECTOR clause is not " + "permitted in PURE procedure at %C"); + goto cleanup; + } + + if (n) n->clauses = c; else if (gfc_current_ns->oacc_routine) @@ -2553,14 +2589,15 @@ cleanup: (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \ | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE \ - | OMP_CLAUSE_LINEAR) + | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ORDER) #define OMP_SECTIONS_CLAUSES \ (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION) #define OMP_SIMD_CLAUSES \ (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_LASTPRIVATE \ | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_SAFELEN \ - | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_SIMDLEN) + | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_SIMDLEN \ + | OMP_CLAUSE_IF | OMP_CLAUSE_ORDER | OMP_CLAUSE_NOTEMPORAL) #define OMP_TASK_CLAUSES \ (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT \ @@ -2595,7 +2632,7 @@ cleanup: | OMP_CLAUSE_SHARED | OMP_CLAUSE_REDUCTION) #define OMP_DISTRIBUTE_CLAUSES \ (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ - | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_DIST_SCHEDULE) + | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_DIST_SCHEDULE) #define OMP_SINGLE_CLAUSES \ (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE) #define OMP_ORDERED_CLAUSES \ @@ -2623,15 +2660,10 @@ gfc_match_omp_critical (void) gfc_omp_clauses *c = NULL; if (gfc_match (" ( %n )", n) != MATCH_YES) - { - n[0] = '\0'; - if (gfc_match_omp_eos () != MATCH_YES) - { - gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C"); - return MATCH_ERROR; - } - } - else if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_HINT)) != MATCH_YES) + n[0] = '\0'; + + if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_HINT), + /* first = */ n[0] == '\0') != MATCH_YES) return MATCH_ERROR; new_st.op = EXEC_OMP_CRITICAL; @@ -3406,6 +3438,230 @@ gfc_match_omp_parallel_workshare (void) return match_omp (EXEC_OMP_PARALLEL_WORKSHARE, OMP_PARALLEL_CLAUSES); } +void +gfc_check_omp_requires (gfc_namespace *ns, int ref_omp_requires) +{ + if (ns->omp_target_seen + && (ns->omp_requires & OMP_REQ_TARGET_MASK) + != (ref_omp_requires & OMP_REQ_TARGET_MASK)) + { + gcc_assert (ns->proc_name); + if ((ref_omp_requires & OMP_REQ_REVERSE_OFFLOAD) + && !(ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD)) + gfc_error ("Program unit at %L has OpenMP device constructs/routines " + "but does not set !$OMP REQUIRES REVERSE_OFFSET but other " + "program units do", &ns->proc_name->declared_at); + if ((ref_omp_requires & OMP_REQ_UNIFIED_ADDRESS) + && !(ns->omp_requires & OMP_REQ_UNIFIED_ADDRESS)) + gfc_error ("Program unit at %L has OpenMP device constructs/routines " + "but does not set !$OMP REQUIRES UNIFIED_ADDRESS but other " + "program units do", &ns->proc_name->declared_at); + if ((ref_omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY) + && !(ns->omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY)) + gfc_error ("Program unit at %L has OpenMP device constructs/routines " + "but does not set !$OMP REQUIRES UNIFIED_SHARED_MEMORY but " + "other program units do", &ns->proc_name->declared_at); + } +} + +bool +gfc_omp_requires_add_clause (gfc_omp_requires_kind clause, + const char *clause_name, locus *loc, + const char *module_name) +{ + gfc_namespace *prog_unit = gfc_current_ns; + while (prog_unit->parent) + { + if (gfc_state_stack->previous + && gfc_state_stack->previous->state == COMP_INTERFACE) + break; + prog_unit = prog_unit->parent; + } + + /* Requires added after use. */ + if (prog_unit->omp_target_seen + && (clause & OMP_REQ_TARGET_MASK) + && !(prog_unit->omp_requires & clause)) + { + if (module_name) + gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use " + "at %L comes after using a device construct/routine", + clause_name, module_name, loc); + else + gfc_error ("!$OMP REQUIRES clause %qs specified at %L comes after " + "using a device construct/routine", clause_name, loc); + return false; + } + + /* Overriding atomic_default_mem_order clause value. */ + if ((clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK) + && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK) + && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK) + != (int) clause) + { + const char *other; + if (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST) + other = "seq_cst"; + else if (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL) + other = "acq_rel"; + else if (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_RELAXED) + other = "relaxed"; + else + gcc_unreachable (); + + if (module_name) + gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> " + "specified via module %qs use at %L overrides a previous " + "%<atomic_default_mem_order(%s)%> (which might be through " + "using a module)", clause_name, module_name, loc, other); + else + gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> " + "specified at %L overrides a previous " + "%<atomic_default_mem_order(%s)%> (which might be through " + "using a module)", clause_name, loc, other); + return false; + } + + /* Requires via module not at program-unit level and not repeating clause. */ + if (prog_unit != gfc_current_ns && !(prog_unit->omp_requires & clause)) + { + if (clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK) + gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> " + "specified via module %qs use at %L but same clause is " + "not set at for the program unit", clause_name, module_name, + loc); + else + gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use at " + "%L but same clause is not set at for the program unit", + clause_name, module_name, loc); + return false; + } + + if (!gfc_state_stack->previous + || gfc_state_stack->previous->state != COMP_INTERFACE) + prog_unit->omp_requires |= clause; + return true; +} + +match +gfc_match_omp_requires (void) +{ + static const char *clauses[] = {"reverse_offload", + "unified_address", + "unified_shared_memory", + "dynamic_allocators", + "atomic_default"}; + const char *clause = NULL; + int requires_clauses = 0; + bool first = true; + locus old_loc; + + if (gfc_current_ns->parent + && (!gfc_state_stack->previous + || gfc_state_stack->previous->state != COMP_INTERFACE)) + { + gfc_error ("!$OMP REQUIRES at %C must appear in the specification part " + "of a program unit"); + return MATCH_ERROR; + } + + while (true) + { + old_loc = gfc_current_locus; + gfc_omp_requires_kind requires_clause; + if ((first || gfc_match_char (',') != MATCH_YES) + && (first && gfc_match_space () != MATCH_YES)) + goto error; + first = false; + gfc_gobble_whitespace (); + old_loc = gfc_current_locus; + + if (gfc_match_omp_eos () != MATCH_NO) + break; + if (gfc_match (clauses[0]) == MATCH_YES) + { + clause = clauses[0]; + requires_clause = OMP_REQ_REVERSE_OFFLOAD; + if (requires_clauses & OMP_REQ_REVERSE_OFFLOAD) + goto duplicate_clause; + } + else if (gfc_match (clauses[1]) == MATCH_YES) + { + clause = clauses[1]; + requires_clause = OMP_REQ_UNIFIED_ADDRESS; + if (requires_clauses & OMP_REQ_UNIFIED_ADDRESS) + goto duplicate_clause; + } + else if (gfc_match (clauses[2]) == MATCH_YES) + { + clause = clauses[2]; + requires_clause = OMP_REQ_UNIFIED_SHARED_MEMORY; + if (requires_clauses & OMP_REQ_UNIFIED_SHARED_MEMORY) + goto duplicate_clause; + } + else if (gfc_match (clauses[3]) == MATCH_YES) + { + clause = clauses[3]; + requires_clause = OMP_REQ_DYNAMIC_ALLOCATORS; + if (requires_clauses & OMP_REQ_DYNAMIC_ALLOCATORS) + goto duplicate_clause; + } + else if (gfc_match ("atomic_default_mem_order (") == MATCH_YES) + { + clause = clauses[4]; + if (requires_clauses & OMP_REQ_ATOMIC_MEM_ORDER_MASK) + goto duplicate_clause; + if (gfc_match (" seq_cst )") == MATCH_YES) + { + clause = "seq_cst"; + requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST; + } + else if (gfc_match (" acq_rel )") == MATCH_YES) + { + clause = "acq_rel"; + requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL; + } + else if (gfc_match (" relaxed )") == MATCH_YES) + { + clause = "relaxed"; + requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_RELAXED; + } + else + { + gfc_error ("Expected SEQ_CST, ACQ_REL or RELAXED for " + "ATOMIC_DEFAULT_MEM_ORDER clause at %C"); + goto error; + } + } + else + goto error; + + if (requires_clause & ~OMP_REQ_ATOMIC_MEM_ORDER_MASK) + gfc_error_now ("Sorry, %qs clause at %L on REQUIRES directive is not " + "yet supported", clause, &old_loc); + if (!gfc_omp_requires_add_clause (requires_clause, clause, &old_loc, NULL)) + goto error; + requires_clauses |= requires_clause; + } + + if (requires_clauses == 0) + { + if (!gfc_error_flag_test ()) + gfc_error ("Clause expected at %C"); + goto error; + } + return MATCH_YES; + +duplicate_clause: + gfc_error ("%qs clause at %L specified more than once", clause, &old_loc); +error: + if (!gfc_error_flag_test ()) + gfc_error ("Expected UNIFIED_ADDRESS, UNIFIED_SHARED_MEMORY, " + "DYNAMIC_ALLOCATORS, REVERSE_OFFLOAD, or " + "ATOMIC_DEFAULT_MEM_ORDER clause at %L", &old_loc); + return MATCH_ERROR; +} + match gfc_match_omp_sections (void) @@ -3727,6 +3983,26 @@ gfc_match_omp_oacc_atomic (bool omp_p) new_st.op = (omp_p ? EXEC_OMP_ATOMIC : EXEC_OACC_ATOMIC); if (seq_cst) op = (gfc_omp_atomic_op) (op | GFC_OMP_ATOMIC_SEQ_CST); + else if (omp_p) + { + gfc_namespace *prog_unit = gfc_current_ns; + while (prog_unit->parent) + prog_unit = prog_unit->parent; + switch (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK) + { + case 0: + case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED: + break; + case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST: + op = (gfc_omp_atomic_op) (op | GFC_OMP_ATOMIC_SEQ_CST); + break; + case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL: + op = (gfc_omp_atomic_op) (op | GFC_OMP_ATOMIC_ACQ_REL); + break; + default: + gcc_unreachable (); + } + } new_st.ext.omp_atomic = op; return MATCH_YES; } @@ -4093,7 +4369,9 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED", "COPYIN", "UNIFORM", "ALIGNED", "LINEAR", "DEPEND", "MAP", "TO", "FROM", "REDUCTION", "DEVICE_RESIDENT", "LINK", "USE_DEVICE", - "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR" }; + "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR", + "NONTEMPORAL" }; + STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM); if (omp_clauses == NULL) return; @@ -4130,33 +4408,53 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, else switch (code->op) { + case EXEC_OMP_CANCEL: + ok = ifc == OMP_IF_CANCEL; + break; + case EXEC_OMP_PARALLEL: case EXEC_OMP_PARALLEL_DO: case EXEC_OMP_PARALLEL_SECTIONS: case EXEC_OMP_PARALLEL_WORKSHARE: - case EXEC_OMP_PARALLEL_DO_SIMD: case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: ok = ifc == OMP_IF_PARALLEL; break; + case EXEC_OMP_PARALLEL_DO_SIMD: + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_SIMD; + break; + + case EXEC_OMP_SIMD: + case EXEC_OMP_DO_SIMD: + case EXEC_OMP_DISTRIBUTE_SIMD: + case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: + ok = ifc == OMP_IF_SIMD; + break; + case EXEC_OMP_TASK: ok = ifc == OMP_IF_TASK; break; case EXEC_OMP_TASKLOOP: - case EXEC_OMP_TASKLOOP_SIMD: ok = ifc == OMP_IF_TASKLOOP; break; + case EXEC_OMP_TASKLOOP_SIMD: + ok = ifc == OMP_IF_TASKLOOP || ifc == OMP_IF_SIMD; + break; + case EXEC_OMP_TARGET: case EXEC_OMP_TARGET_TEAMS: case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: + ok = ifc == OMP_IF_TARGET; + break; + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: case EXEC_OMP_TARGET_SIMD: - ok = ifc == OMP_IF_TARGET; + ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_SIMD; break; case EXEC_OMP_TARGET_DATA: @@ -4176,13 +4474,18 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, break; case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: - case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case EXEC_OMP_TARGET_PARALLEL: case EXEC_OMP_TARGET_PARALLEL_DO: - case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_PARALLEL; break; + case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + ok = (ifc == OMP_IF_TARGET + || ifc == OMP_IF_PARALLEL + || ifc == OMP_IF_SIMD); + break; + default: ok = false; break; @@ -4190,7 +4493,9 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, if (!ok) { static const char *ifs[] = { + "CANCEL", "PARALLEL", + "SIMD", "TASK", "TASKLOOP", "TARGET", @@ -4428,12 +4733,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, for (list = 0; list < OMP_LIST_NUM; list++) if ((n = omp_clauses->lists[list]) != NULL) { - const char *name; - - if (list < OMP_LIST_NUM) - name = clause_names[list]; - else - gcc_unreachable (); + const char *name = clause_names[list]; switch (list) { @@ -4545,7 +4845,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, /* Look through component refs to find last array reference. */ - if (openacc && resolved) + if (resolved) { /* The "!$acc cache" directive allows rectangular subarrays to be specified, with some restrictions @@ -4555,6 +4855,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, arr(-n:n,-n:n) could be contiguous even if it looks like it may not be. */ if (list != OMP_LIST_CACHE + && list != OMP_LIST_DEPEND && !gfc_is_simply_contiguous (n->expr, false, true) && gfc_is_not_contiguous (n->expr)) gfc_error ("Array is not contiguous at %L", @@ -4628,6 +4929,13 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, && n->sym->as->type == AS_ASSUMED_SIZE) gfc_error ("Assumed size array %qs in %s clause at %L", n->sym->name, name, &n->where); + if (!openacc + && list == OMP_LIST_MAP + && n->sym->ts.type == BT_DERIVED + && n->sym->ts.u.derived->attr.alloc_comp) + gfc_error ("List item %qs with allocatable components is not " + "permitted in map clause at %L", n->sym->name, + &n->where); if (list == OMP_LIST_MAP && !openacc) switch (code->op) { @@ -4984,7 +5292,14 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, if (omp_clauses->device) resolve_nonnegative_int_expr (omp_clauses->device, "DEVICE"); if (omp_clauses->hint) - resolve_scalar_int_expr (omp_clauses->hint, "HINT"); + { + resolve_scalar_int_expr (omp_clauses->hint, "HINT"); + if (omp_clauses->hint->ts.type != BT_INTEGER + || omp_clauses->hint->expr_type != EXPR_CONSTANT + || mpz_sgn (omp_clauses->hint->value.integer) < 0) + gfc_error ("Value of HINT clause at %L shall be a valid " + "constant hint expression", &omp_clauses->hint->where); + } if (omp_clauses->priority) resolve_nonnegative_int_expr (omp_clauses->priority, "PRIORITY"); if (omp_clauses->dist_chunk_size) @@ -5026,17 +5341,23 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, if (omp_clauses->depend_source && code->op != EXEC_OMP_ORDERED) gfc_error ("SOURCE dependence type only allowed " "on ORDERED directive at %L", &code->loc); - if (!openacc && code && omp_clauses->lists[OMP_LIST_MAP] == NULL) + if (!openacc + && code + && omp_clauses->lists[OMP_LIST_MAP] == NULL + && omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] == NULL + && omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] == NULL) { const char *p = NULL; switch (code->op) { - case EXEC_OMP_TARGET_DATA: p = "TARGET DATA"; break; case EXEC_OMP_TARGET_ENTER_DATA: p = "TARGET ENTER DATA"; break; case EXEC_OMP_TARGET_EXIT_DATA: p = "TARGET EXIT DATA"; break; default: break; } - if (p) + if (code->op == EXEC_OMP_TARGET_DATA) + gfc_error ("TARGET DATA must contain at least one MAP, USE_DEVICE_PTR, " + "or USE_DEVICE_ADDR clause at %L", &code->loc); + else if (p) gfc_error ("%s must contain at least one MAP clause at %L", p, &code->loc); } @@ -5682,6 +6003,31 @@ gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym, bool add_clause) if (omp_current_ctx->sharing_clauses->contains (sym)) return; + if (omp_current_ctx->is_openmp && omp_current_ctx->code->block) + { + /* SIMD is handled differently and, hence, ignored here. */ + gfc_code *omp_code = omp_current_ctx->code->block; + for ( ; omp_code->next; omp_code = omp_code->next) + switch (omp_code->op) + { + case EXEC_OMP_SIMD: + case EXEC_OMP_DO_SIMD: + case EXEC_OMP_PARALLEL_DO_SIMD: + case EXEC_OMP_DISTRIBUTE_SIMD: + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_SIMD: + case EXEC_OMP_TASKLOOP_SIMD: + return; + default: + break; + } + } + if (! omp_current_ctx->private_iterators->add (sym) && add_clause) { gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses; @@ -5822,26 +6168,21 @@ resolve_omp_do (gfc_code *code) "at %L", name, &do_code->loc); if (code->ext.omp_clauses) for (list = 0; list < OMP_LIST_NUM; list++) - if (!is_simd + if (!is_simd || code->ext.omp_clauses->collapse > 1 ? (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE) - : code->ext.omp_clauses->collapse > 1 - ? (list != OMP_LIST_LASTPRIVATE) - : (list != OMP_LIST_LINEAR)) + : (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE + && list != OMP_LIST_LINEAR)) for (n = code->ext.omp_clauses->lists[list]; n; n = n->next) if (dovar == n->sym) { - if (!is_simd) + if (!is_simd || code->ext.omp_clauses->collapse > 1) gfc_error ("%s iteration variable present on clause " "other than PRIVATE or LASTPRIVATE at %L", name, &do_code->loc); - else if (code->ext.omp_clauses->collapse > 1) - gfc_error ("%s iteration variable present on clause " - "other than LASTPRIVATE at %L", - name, &do_code->loc); else gfc_error ("%s iteration variable present on clause " - "other than LINEAR at %L", - name, &do_code->loc); + "other than PRIVATE, LASTPRIVATE or " + "LINEAR at %L", name, &do_code->loc); break; } if (i > 1) @@ -5864,8 +6205,6 @@ resolve_omp_do (gfc_code *code) do_code2 = do_code2->block->next; } } - if (i == collapse) - break; for (c = do_code->next; c; c = c->next) if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE) { @@ -5873,7 +6212,7 @@ resolve_omp_do (gfc_code *code) name, &c->loc); break; } - if (c) + if (i == collapse || c) break; do_code = do_code->block; if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE) @@ -6479,6 +6818,16 @@ gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED) case EXEC_OMP_ATOMIC: resolve_omp_atomic (code); break; + case EXEC_OMP_CRITICAL: + resolve_omp_clauses (code, code->ext.omp_clauses, NULL); + if (!code->ext.omp_clauses->critical_name + && code->ext.omp_clauses->hint + && code->ext.omp_clauses->hint->ts.type == BT_INTEGER + && code->ext.omp_clauses->hint->expr_type == EXPR_CONSTANT + && mpz_sgn (code->ext.omp_clauses->hint->value.integer) != 0) + gfc_error ("OMP CRITICAL at %L with HINT clause requires a NAME, " + "except when omp_sync_hint_none is used", &code->loc); + break; default: break; } diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c index 4cc8a90..d844fa9 100644 --- a/gcc/fortran/options.c +++ b/gcc/fortran/options.c @@ -838,8 +838,8 @@ gfc_get_option_string (void) case OPT_o: case OPT_d: case OPT_dumpbase: + case OPT_dumpbase_ext: case OPT_dumpdir: - case OPT_auxbase: case OPT_quiet: case OPT_version: case OPT_fintrinsic_modules_path: @@ -864,8 +864,8 @@ gfc_get_option_string (void) case OPT_o: case OPT_d: case OPT_dumpbase: + case OPT_dumpbase_ext: case OPT_dumpdir: - case OPT_auxbase: case OPT_quiet: case OPT_version: case OPT_fintrinsic_modules_path: diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index f71a95d..6669621 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -639,20 +639,10 @@ decode_oacc_directive (void) gfc_matching_function = false; - if (gfc_pure (NULL)) - { - gfc_error_now ("OpenACC directives at %C may not appear in PURE " - "procedures"); - gfc_error_recovery (); - return ST_NONE; - } - if (gfc_current_state () == COMP_FUNCTION && gfc_current_block ()->result->ts.kind == -1) spec_only = true; - gfc_unset_implicit_pure (NULL); - old_locus = gfc_current_locus; /* General OpenACC directive matching: Instead of testing every possible @@ -663,6 +653,21 @@ decode_oacc_directive (void) switch (c) { + case 'r': + matcha ("routine", gfc_match_oacc_routine, ST_OACC_ROUTINE); + break; + } + + gfc_unset_implicit_pure (NULL); + if (gfc_pure (NULL)) + { + gfc_error_now ("OpenACC directives other than ROUTINE may not appear in PURE " + "procedures at %C"); + goto error_handling; + } + + switch (c) + { case 'a': matcha ("atomic", gfc_match_oacc_atomic, ST_OACC_ATOMIC); break; @@ -705,9 +710,6 @@ decode_oacc_directive (void) case 'l': matcha ("loop", gfc_match_oacc_loop, ST_OACC_LOOP); break; - case 'r': - match ("routine", gfc_match_oacc_routine, ST_OACC_ROUTINE); - break; case 's': matcha ("serial loop", gfc_match_oacc_serial_loop, ST_OACC_SERIAL_LOOP); matcha ("serial", gfc_match_oacc_serial, ST_OACC_SERIAL); @@ -849,7 +851,7 @@ decode_omp_directive (void) /* match is for directives that should be recognized only if -fopenmp, matchs for directives that should be recognized if either -fopenmp or -fopenmp-simd. - Handle only the directives allowed in PURE/ELEMENTAL procedures + Handle only the directives allowed in PURE procedures first (those also shall not turn off implicit pure). */ switch (c) { @@ -868,7 +870,7 @@ decode_omp_directive (void) if (flag_openmp && gfc_pure (NULL)) { gfc_error_now ("OpenMP directives other than SIMD or DECLARE TARGET " - "at %C may not appear in PURE or ELEMENTAL procedures"); + "at %C may not appear in PURE procedures"); gfc_error_recovery (); return ST_NONE; } @@ -993,6 +995,9 @@ decode_omp_directive (void) ST_OMP_PARALLEL_WORKSHARE); matcho ("parallel", gfc_match_omp_parallel, ST_OMP_PARALLEL); break; + case 'r': + matcho ("requires", gfc_match_omp_requires, ST_OMP_REQUIRES); + break; case 's': matcho ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS); matcho ("section", gfc_match_omp_eos_error, ST_OMP_SECTION); @@ -1078,13 +1083,44 @@ decode_omp_directive (void) if (!flag_openmp && gfc_pure (NULL)) { gfc_error_now ("OpenMP directives other than SIMD or DECLARE TARGET " - "at %C may not appear in PURE or ELEMENTAL " - "procedures"); + "at %C may not appear in PURE procedures"); reject_statement (); gfc_error_recovery (); return ST_NONE; } } + switch (ret) + { + case ST_OMP_DECLARE_TARGET: + case ST_OMP_TARGET: + case ST_OMP_TARGET_DATA: + case ST_OMP_TARGET_ENTER_DATA: + case ST_OMP_TARGET_EXIT_DATA: + case ST_OMP_TARGET_TEAMS: + case ST_OMP_TARGET_TEAMS_DISTRIBUTE: + case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: + case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case ST_OMP_TARGET_PARALLEL: + case ST_OMP_TARGET_PARALLEL_DO: + case ST_OMP_TARGET_PARALLEL_DO_SIMD: + case ST_OMP_TARGET_SIMD: + case ST_OMP_TARGET_UPDATE: + { + gfc_namespace *prog_unit = gfc_current_ns; + while (prog_unit->parent) + { + if (gfc_state_stack->previous + && gfc_state_stack->previous->state == COMP_INTERFACE) + break; + prog_unit = prog_unit->parent; + } + prog_unit->omp_target_seen = true; + break; + } + default: + break; + } return ret; do_spec_only: @@ -1603,7 +1639,8 @@ next_statement (void) /* OpenMP declaration statements. */ #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_TARGET: case ST_OMP_DECLARE_REDUCTION: \ + case ST_OMP_REQUIRES /* Block end statements. Errors associated with interchanging these are detected in gfc_match_end(). */ @@ -2406,6 +2443,9 @@ gfc_ascii_statement (gfc_statement st) case ST_OMP_PARALLEL_WORKSHARE: p = "!$OMP PARALLEL WORKSHARE"; break; + case ST_OMP_REQUIRES: + p = "!$OMP REQUIRES"; + break; case ST_OMP_SECTIONS: p = "!$OMP SECTIONS"; break; @@ -5383,7 +5423,8 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only) cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool; break; case EXEC_OMP_END_CRITICAL: - if (((cp->ext.omp_clauses == NULL) ^ (new_st.ext.omp_name == NULL)) + if (((cp->ext.omp_clauses->critical_name == NULL) + ^ (new_st.ext.omp_name == NULL)) || (new_st.ext.omp_name != NULL && strcmp (cp->ext.omp_clauses->critical_name, new_st.ext.omp_name) != 0)) @@ -6446,6 +6487,11 @@ loop: gfc_resolve (gfc_current_ns); + /* Fix the implicit_pure attribute for those procedures who should + not have it. */ + while (gfc_fix_implicit_pure (gfc_current_ns)) + ; + /* Dump the parse tree if requested. */ if (flag_dump_fortran_original) gfc_dump_parse_tree (gfc_current_ns, stdout); @@ -6491,11 +6537,36 @@ done: /* Do the resolution. */ resolve_all_program_units (gfc_global_ns_list); + /* Go through all top-level namespaces and unset the implicit_pure + attribute for any procedures that call something not pure or + implicit_pure. Because the a procedure marked as not implicit_pure + in one sweep may be called by another routine, we repeat this + process until there are no more changes. */ + bool changed; + do + { + changed = false; + for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns; + gfc_current_ns = gfc_current_ns->sibling) + { + if (gfc_fix_implicit_pure (gfc_current_ns)) + changed = true; + } + } + while (changed); - /* Fixup for external procedures. */ + /* Fixup for external procedures and resolve 'omp requires'. */ + int omp_requires; + omp_requires = 0; + for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns; + gfc_current_ns = gfc_current_ns->sibling) + { + omp_requires |= gfc_current_ns->omp_requires; + gfc_check_externals (gfc_current_ns); + } for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling) - gfc_check_externals (gfc_current_ns); + gfc_check_omp_requires (gfc_current_ns, omp_requires); /* Do the parse tree dump. */ gfc_current_ns = flag_dump_fortran_original ? gfc_global_ns_list : NULL; diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index d738984..a58a259 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -432,8 +432,8 @@ match_boz_constant (gfc_expr **result) goto backup; if (x_hex - && gfc_invalid_boz ("Hexadecimal constant at %L uses " - "nonstandard X instead of Z", &gfc_current_locus)) + && gfc_invalid_boz (G_("Hexadecimal constant at %L uses " + "nonstandard X instead of Z"), &gfc_current_locus)) return MATCH_ERROR; old_loc = gfc_current_locus; @@ -470,8 +470,8 @@ match_boz_constant (gfc_expr **result) goto backup; } - if (gfc_invalid_boz ("BOZ constant at %C uses nonstandard postfix " - "syntax", &gfc_current_locus)) + if (gfc_invalid_boz (G_("BOZ constant at %C uses nonstandard postfix " + "syntax"), &gfc_current_locus)) return MATCH_ERROR; } @@ -2023,7 +2023,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, { char name[GFC_MAX_SYMBOL_LEN + 1]; gfc_ref *substring, *tail, *tmp; - gfc_component *component; + gfc_component *component = NULL; + gfc_component *previous = NULL; gfc_symbol *sym = primary->symtree->n.sym; gfc_expr *tgt_expr = NULL; match m; @@ -2245,6 +2246,27 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, { if (tmp) { + switch (tmp->u.i) + { + case INQUIRY_RE: + case INQUIRY_IM: + if (!gfc_notify_std (GFC_STD_F2008, + "RE or IM part_ref at %C")) + return MATCH_ERROR; + break; + + case INQUIRY_KIND: + if (!gfc_notify_std (GFC_STD_F2003, + "KIND part_ref at %C")) + return MATCH_ERROR; + break; + + case INQUIRY_LEN: + if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C")) + return MATCH_ERROR; + break; + } + if ((tmp->u.i == INQUIRY_RE || tmp->u.i == INQUIRY_IM) && primary->ts.type != BT_COMPLEX) { @@ -2322,15 +2344,19 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, break; } + previous = component; + if (!inquiry && !intrinsic) component = gfc_find_component (sym, name, false, false, &tmp); else component = NULL; - /* In some cases, returning MATCH_NO gives a better error message. Most - cases return "Unclassifiable statement at..." */ if (intrinsic && !inquiry) - return MATCH_NO; + { + gfc_error ("%qs at %C is not an inquiry reference to an intrinsic " + "type component %qs", name, previous->name); + return MATCH_ERROR; + } else if (component == NULL && !inquiry) return MATCH_ERROR; @@ -2576,7 +2602,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) sym = expr->symtree->n.sym; attr = sym->attr; - if (sym->ts.type == BT_CLASS && sym->attr.class_ok) + if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived) { dimension = CLASS_DATA (sym)->attr.dimension; codimension = CLASS_DATA (sym)->attr.codimension; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index fd3b025..6caddcf 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1753,9 +1753,11 @@ gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc) gfc_intrinsic_sym* isym = NULL; const char* symstd; - if (sym->formal) + if (sym->resolve_symbol_called >= 2) return true; + sym->resolve_symbol_called = 2; + /* Already resolved. */ if (sym->from_intmod && sym->ts.type != BT_UNKNOWN) return true; @@ -2275,12 +2277,28 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c) && (set_by_optional || arg->expr->rank != rank) && !(isym && isym->id == GFC_ISYM_CONVERSION)) { - gfc_warning (OPT_Wpedantic, - "%qs at %L is an array and OPTIONAL; IF IT IS " - "MISSING, it cannot be the actual argument of an " - "ELEMENTAL procedure unless there is a non-optional " - "argument with the same rank (12.4.1.5)", - arg->expr->symtree->n.sym->name, &arg->expr->where); + bool t = false; + gfc_actual_arglist *a; + + /* Scan the argument list for a non-optional argument with the + same rank as arg. */ + for (a = arg0; a; a = a->next) + if (a != arg + && a->expr->rank == arg->expr->rank + && !a->expr->symtree->n.sym->attr.optional) + { + t = true; + break; + } + + if (!t) + gfc_warning (OPT_Wpedantic, + "%qs at %L is an array and OPTIONAL; If it is not " + "present, then it cannot be the actual argument of " + "an ELEMENTAL procedure unless there is a non-optional" + " argument with the same rank " + "(Fortran 2018, 15.5.2.12)", + arg->expr->symtree->n.sym->name, &arg->expr->where); } } @@ -2297,7 +2315,7 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c) /* Elemental procedure's array actual arguments must conform. */ if (e != NULL) { - if (!gfc_check_conformance (arg->expr, e, "elemental procedure")) + if (!gfc_check_conformance (arg->expr, e, _("elemental procedure"))) return false; } else @@ -2616,6 +2634,7 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, int sub) gfc_error ("Interface mismatch in global procedure %qs at %L: %s", sym->name, &sym->declared_at, reason); + sym->error = 1; gfc_errors_to_warnings (false); goto done; } @@ -4172,9 +4191,9 @@ resolve_operator (gfc_expr *e) /* If op1 is BOZ, then op2 is not!. Try to convert to type of op2. */ if (op1->ts.type == BT_BOZ) { - if (gfc_invalid_boz ("BOZ literal constant near %L cannot appear as " - "an operand of a relational operator", - &op1->where)) + if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear " + "as an operand of a relational operator"), + &op1->where)) return false; if (op2->ts.type == BT_INTEGER && !gfc_boz2int (op1, op2->ts.kind)) @@ -4187,8 +4206,8 @@ resolve_operator (gfc_expr *e) /* If op2 is BOZ, then op1 is not!. Try to convert to type of op2. */ if (op2->ts.type == BT_BOZ) { - if (gfc_invalid_boz ("BOZ literal constant near %L cannot appear as " - "an operand of a relational operator", + if (gfc_invalid_boz (G_("BOZ literal constant near %L cannot appear" + " as an operand of a relational operator"), &op2->where)) return false; @@ -4226,9 +4245,9 @@ resolve_operator (gfc_expr *e) const char *msg; if (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS) - msg = "Equality comparison for %s at %L"; + msg = G_("Equality comparison for %s at %L"); else - msg = "Inequality comparison for %s at %L"; + msg = G_("Inequality comparison for %s at %L"); gfc_warning (OPT_Wcompare_reals, msg, gfc_typename (op1), &op1->where); @@ -5138,9 +5157,6 @@ gfc_resolve_substring_charlen (gfc_expr *e) return; } - e->ts.type = BT_CHARACTER; - e->ts.kind = gfc_default_character_kind; - if (!e->ts.u.cl) e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); @@ -5555,6 +5571,7 @@ resolve_variable (gfc_expr *e) } /* TS 29113, C535b. */ else if (((sym->ts.type == BT_CLASS && sym->attr.class_ok + && sym->ts.u.derived && CLASS_DATA (sym) && CLASS_DATA (sym)->as && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK) || (sym->ts.type != BT_CLASS && sym->as @@ -5602,6 +5619,7 @@ resolve_variable (gfc_expr *e) /* TS 29113, C535b. */ if (((sym->ts.type == BT_CLASS && sym->attr.class_ok + && sym->ts.u.derived && CLASS_DATA (sym) && CLASS_DATA (sym)->as && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK) || (sym->ts.type != BT_CLASS && sym->as @@ -5975,6 +5993,16 @@ check_host_association (gfc_expr *e) if (ref->type == REF_ARRAY && ref->next == NULL) break; + if ((ref == NULL || ref->type != REF_ARRAY) + && sym->attr.proc == PROC_INTERNAL) + { + gfc_error ("%qs at %L is host associated at %L into " + "a contained procedure with an internal " + "procedure of the same name", sym->name, + &old_sym->declared_at, &e->where); + return false; + } + gcc_assert (ref->type == REF_ARRAY); /* Grab the start expressions from the array ref and @@ -8996,7 +9024,9 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) if (as->corank != 0) sym->attr.codimension = 1; } - else if (sym->ts.type == BT_CLASS && (!CLASS_DATA (sym)->as || sym->assoc->rankguessed)) + else if (sym->ts.type == BT_CLASS + && CLASS_DATA (sym) + && (!CLASS_DATA (sym)->as || sym->assoc->rankguessed)) { if (!CLASS_DATA (sym)->as) CLASS_DATA (sym)->as = gfc_get_array_spec (); @@ -9013,7 +9043,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) { /* target's rank is 0, but the type of the sym is still array valued, which has to be corrected. */ - if (sym->ts.type == BT_CLASS + if (sym->ts.type == BT_CLASS && sym->ts.u.derived && CLASS_DATA (sym) && CLASS_DATA (sym)->as) { gfc_array_spec *as; @@ -9046,7 +9076,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) as = NULL; sym->ts = *ts; sym->ts.type = BT_CLASS; - attr = CLASS_DATA (sym)->attr; + attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr; attr.class_ok = 0; attr.associate_var = 1; attr.dimension = attr.codimension = 0; @@ -9225,7 +9255,8 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) { if (code->expr1->symtree->n.sym->attr.untyped) code->expr1->symtree->n.sym->ts = code->expr2->ts; - selector_type = CLASS_DATA (code->expr2)->ts.u.derived; + selector_type = CLASS_DATA (code->expr2) + ? CLASS_DATA (code->expr2)->ts.u.derived : code->expr2->ts.u.derived; } if (code->expr2->rank && CLASS_DATA (code->expr1)->as) @@ -9636,7 +9667,7 @@ resolve_select_rank (gfc_code *code, gfc_namespace *old_ns) gfc_namespace *ns; gfc_code *body, *new_st, *tail; gfc_case *c; - char tname[GFC_MAX_SYMBOL_LEN]; + char tname[GFC_MAX_SYMBOL_LEN + 7]; char name[2 * GFC_MAX_SYMBOL_LEN]; gfc_symtree *st; gfc_expr *selector_expr = NULL; @@ -11799,10 +11830,18 @@ start: case EXEC_GOTO: if (code->expr1 != NULL) { - if (code->expr1->ts.type != BT_INTEGER) - gfc_error ("ASSIGNED GOTO statement at %L requires an " - "INTEGER variable", &code->expr1->where); - else if (code->expr1->symtree->n.sym->attr.assign != 1) + if (code->expr1->expr_type != EXPR_VARIABLE + || code->expr1->ts.type != BT_INTEGER + || (code->expr1->ref + && code->expr1->ref->type == REF_ARRAY) + || code->expr1->symtree == NULL + || (code->expr1->symtree->n.sym + && (code->expr1->symtree->n.sym->attr.flavor + == FL_PARAMETER))) + gfc_error ("ASSIGNED GOTO statement at %L requires a " + "scalar INTEGER variable", &code->expr1->where); + else if (code->expr1->symtree->n.sym + && code->expr1->symtree->n.sym->attr.assign != 1) gfc_error ("Variable %qs has not been assigned a target " "label at %L", code->expr1->symtree->n.sym->name, &code->expr1->where); @@ -11875,6 +11914,7 @@ start: || code->expr1->symtree->n.sym->ts.type != BT_INTEGER || code->expr1->symtree->n.sym->ts.kind != gfc_default_integer_kind + || code->expr1->symtree->n.sym->attr.flavor == FL_PARAMETER || code->expr1->symtree->n.sym->as != NULL)) gfc_error ("ASSIGN statement at %L requires a scalar " "default INTEGER variable", &code->expr1->where); @@ -12356,7 +12396,7 @@ resolve_charlen (gfc_charlen *cl) } /* cl->length has been resolved. It should have an integer type. */ - if (cl->length->ts.type != BT_INTEGER) + if (cl->length->ts.type != BT_INTEGER || cl->length->rank != 0) { gfc_error ("Scalar INTEGER expression expected at %L", &cl->length->where); @@ -12590,7 +12630,8 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) { gfc_array_spec *as; - if (sym->ts.type == BT_CLASS && sym->attr.class_ok) + if (sym->ts.type == BT_CLASS && sym->attr.class_ok + && sym->ts.u.derived && CLASS_DATA (sym)) as = CLASS_DATA (sym)->as; else as = sym->as; @@ -12600,7 +12641,8 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) { bool pointer, allocatable, dimension; - if (sym->ts.type == BT_CLASS && sym->attr.class_ok) + if (sym->ts.type == BT_CLASS && sym->attr.class_ok + && sym->ts.u.derived && CLASS_DATA (sym)) { pointer = CLASS_DATA (sym)->attr.class_pointer; allocatable = CLASS_DATA (sym)->attr.allocatable; @@ -12651,6 +12693,7 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) { /* F03:C502. */ if (sym->attr.class_ok + && sym->ts.u.derived && !sym->attr.select_type_temporary && !UNLIMITED_POLY (sym) && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived)) @@ -12689,7 +12732,8 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) associated by the presence of another class I symbol in the same namespace. 14.6.1.3 of the standard and the discussion on comp.lang.fortran. */ - if (sym->ns != sym->ts.u.derived->ns + if (sym->ts.u.derived + && sym->ns != sym->ts.u.derived->ns && !sym->ts.u.derived->attr.use_assoc && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY) { @@ -12893,8 +12937,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag) else if (sym->attr.external) gfc_error ("External %qs at %L cannot have an initializer", sym->name, &sym->declared_at); - else if (sym->attr.dummy - && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT)) + else if (sym->attr.dummy) gfc_error ("Dummy %qs at %L cannot have an initializer", sym->name, &sym->declared_at); else if (sym->attr.intrinsic) @@ -12997,6 +13040,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) { if (arg->sym && arg->sym->ts.type == BT_DERIVED + && arg->sym->ts.u.derived && !arg->sym->ts.u.derived->attr.use_assoc && !gfc_check_symbol_access (arg->sym->ts.u.derived) && !gfc_notify_std (GFC_STD_F2003, "%qs is of a PRIVATE type " @@ -13123,8 +13167,10 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) { if (sym->attr.proc_pointer) { + const char* name = (sym->attr.result ? sym->ns->proc_name->name + : sym->name); gfc_error ("Procedure pointer %qs at %L shall not be elemental", - sym->name, &sym->declared_at); + name, &sym->declared_at); return false; } if (sym->attr.dummy) @@ -13211,7 +13257,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) if (sym->attr.subroutine && sym->attr.result) { gfc_error ("PROCEDURE attribute conflicts with RESULT attribute " - "in %qs at %L", sym->name, &sym->declared_at); + "in %qs at %L", sym->ns->proc_name->name, &sym->declared_at); return false; } if (sym->attr.external && sym->attr.function && !sym->attr.module_procedure @@ -13909,7 +13955,7 @@ resolve_typebound_procedure (gfc_symtree* stree) { /* If proc has not been resolved at this point, proc->name may actually be a USE associated entity. See PR fortran/89647. */ - if (!proc->resolved + if (!proc->resolve_symbol_called && proc->attr.function == 0 && proc->attr.subroutine == 0) { gfc_symbol *tmp; @@ -15154,9 +15200,9 @@ resolve_symbol (gfc_symbol *sym) gfc_array_spec *as; bool saved_specification_expr; - if (sym->resolved) + if (sym->resolve_symbol_called >= 1) return; - sym->resolved = 1; + sym->resolve_symbol_called = 1; /* No symbol will ever have union type; only components can be unions. Union type declaration symbols have type BT_UNKNOWN but flavor FL_UNION @@ -15168,6 +15214,7 @@ resolve_symbol (gfc_symbol *sym) if (flag_coarray == GFC_FCOARRAY_LIB && sym->ts.type == BT_CLASS && sym->ts.u.derived && CLASS_DATA (sym) && CLASS_DATA (sym)->attr.codimension + && CLASS_DATA (sym)->ts.u.derived && (CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp || CLASS_DATA (sym)->ts.u.derived->attr.pointer_comp)) { @@ -15316,7 +15363,7 @@ resolve_symbol (gfc_symbol *sym) specification_expr = saved_specification_expr; } - if (sym->ts.type == BT_CLASS && sym->attr.class_ok) + if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived) { as = CLASS_DATA (sym)->as; class_attr = CLASS_DATA (sym)->attr; @@ -15717,6 +15764,7 @@ resolve_symbol (gfc_symbol *sym) /* F2008, C525. */ if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp) || (sym->ts.type == BT_CLASS && sym->attr.class_ok + && sym->ts.u.derived && CLASS_DATA (sym) && CLASS_DATA (sym)->attr.coarray_comp)) || class_attr.codimension) && (sym->attr.result || sym->result == sym)) @@ -15738,6 +15786,7 @@ resolve_symbol (gfc_symbol *sym) /* F2008, C525. */ if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp) || (sym->ts.type == BT_CLASS && sym->attr.class_ok + && sym->ts.u.derived && CLASS_DATA (sym) && CLASS_DATA (sym)->attr.coarray_comp)) && (class_attr.codimension || class_attr.pointer || class_attr.dimension || class_attr.allocatable)) @@ -15781,6 +15830,7 @@ resolve_symbol (gfc_symbol *sym) /* F2008, C541. */ if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp) || (sym->ts.type == BT_CLASS && sym->attr.class_ok + && sym->ts.u.derived && CLASS_DATA (sym) && CLASS_DATA (sym)->attr.coarray_comp)) || (class_attr.codimension && class_attr.allocatable)) && sym->attr.dummy && sym->attr.intent == INTENT_OUT) @@ -15899,7 +15949,7 @@ resolve_symbol (gfc_symbol *sym) if (formal) { sym->formal_ns = formal->sym->ns; - if (sym->ns != formal->sym->ns) + if (sym->formal_ns && sym->ns != formal->sym->ns) sym->formal_ns->refs++; } } diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 59f602d..abd3b5c 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -2004,9 +2004,12 @@ gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where) gfc_error ("Symbol %qs at %L conflicts with symbol from module %qs, " "use-associated at %L", sym->name, where, sym->module, &sym->declared_at); + else if (sym->attr.function && sym->attr.result) + gfc_error ("Symbol %qs at %L already has basic type of %s", + sym->ns->proc_name->name, where, gfc_basic_typename (type)); else gfc_error ("Symbol %qs at %L already has basic type of %s", sym->name, - where, gfc_basic_typename (type)); + where, gfc_basic_typename (type)); return false; } @@ -2024,7 +2027,9 @@ gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where) || (flavor == FL_PROCEDURE && sym->attr.subroutine) || flavor == FL_DERIVED || flavor == FL_NAMELIST) { - gfc_error ("Symbol %qs at %L cannot have a type", sym->name, where); + gfc_error ("Symbol %qs at %L cannot have a type", + sym->ns->proc_name ? sym->ns->proc_name->name : sym->name, + where); return false; } @@ -3140,18 +3145,24 @@ gfc_new_symbol (const char *name, gfc_namespace *ns) } -/* Generate an error if a symbol is ambiguous. */ +/* Generate an error if a symbol is ambiguous, and set the error flag + on it. */ static void ambiguous_symbol (const char *name, gfc_symtree *st) { + if (st->n.sym->error) + return; + if (st->n.sym->module) gfc_error ("Name %qs at %C is an ambiguous reference to %qs " "from module %qs", name, st->n.sym->name, st->n.sym->module); else gfc_error ("Name %qs at %C is an ambiguous reference to %qs " "from current program unit", name, st->n.sym->name); + + st->n.sym->error = 1; } @@ -4014,6 +4025,7 @@ gfc_free_namespace (gfc_namespace *ns) { gfc_namespace *p, *q; int i; + gfc_was_finalized *f; if (ns == NULL) return; @@ -4046,6 +4058,17 @@ gfc_free_namespace (gfc_namespace *ns) gfc_free_interface (ns->op[i]); gfc_free_data (ns->data); + + /* Free all the expr + component combinations that have been + finalized. */ + f = ns->was_finalized; + while (f) + { + gfc_was_finalized* current = f; + f = f->next; + free (current); + } + p = ns->contained; free (ns); diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 9c928d0..7a1b2fc 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -3672,8 +3672,12 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr, } } + decl = se->expr; + if (IS_CLASS_ARRAY (sym) && sym->attr.dummy && ar->as->type != AS_DEFERRED) + decl = sym->backend_decl; + cst_offset = offset = gfc_index_zero_node; - add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (se->expr)); + add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (decl)); /* Calculate the offsets from all the dimensions. Make sure to associate the final offset so that we form a chain of loop invariant summands. */ @@ -3694,7 +3698,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr, indexse.expr = save_expr (indexse.expr); /* Lower bound. */ - tmp = gfc_conv_array_lbound (se->expr, n); + tmp = gfc_conv_array_lbound (decl, n); if (sym->attr.temporary) { gfc_init_se (&tmpse, se); @@ -3718,7 +3722,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr, arrays. */ if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE) { - tmp = gfc_conv_array_ubound (se->expr, n); + tmp = gfc_conv_array_ubound (decl, n); if (sym->attr.temporary) { gfc_init_se (&tmpse, se); @@ -3741,7 +3745,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr, } /* Multiply the index by the stride. */ - stride = gfc_conv_array_stride (se->expr, n); + stride = gfc_conv_array_stride (decl, n); tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, indexse.expr, stride); @@ -3756,6 +3760,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr, /* A pointer array component can be detected from its field decl. Fix the descriptor, mark the resulting variable decl and pass it to build_array_ref. */ + decl = NULL_TREE; if (get_CFI_desc (sym, expr, &decl, ar)) decl = build_fold_indirect_ref_loc (input_location, decl); if (!expr->ts.deferred && !sym->attr.codimension @@ -6787,9 +6792,11 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, && sym->attr.dummy)); if (optional_arg) { - tmp = gfc_conv_expr_present (sym); - stmtInit = build3_v (COND_EXPR, tmp, stmtInit, - build_empty_stmt (input_location)); + tree zero_init = fold_convert (TREE_TYPE (tmpdesc), null_pointer_node); + zero_init = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, + tmpdesc, zero_init); + tmp = gfc_conv_expr_present (sym, true); + stmtInit = build3_v (COND_EXPR, tmp, stmtInit, zero_init); } /* Cleanup code. */ @@ -7199,7 +7206,6 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) tree desc; stmtblock_t block; tree start; - tree offset; int full; bool subref_array_target = false; bool deferred_array_component = false; @@ -7270,6 +7276,10 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) full = 1; else if (se->direct_byref) full = 0; + else if (info->ref->u.ar.dimen == 0 && !info->ref->next) + full = 1; + else if (info->ref->u.ar.type == AR_SECTION && se->want_pointer) + full = 0; else full = gfc_full_array_ref_p (info->ref, NULL); @@ -7506,10 +7516,9 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) tree from; tree to; tree base; - bool onebased = false, rank_remap; + tree offset; ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen; - rank_remap = ss->dimen < ndim; if (se->want_coarray) { @@ -7553,10 +7562,10 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, tmp); } - /* If we have an array section or are assigning make sure that - the lower bound is 1. References to the full - array should otherwise keep the original bounds. */ - if ((!info->ref || info->ref->u.ar.type != AR_FULL) && !se->want_pointer) + /* If we have an array section, are assigning or passing an array + section argument make sure that the lower bound is 1. References + to the full array should otherwise keep the original bounds. */ + if (!info->ref || info->ref->u.ar.type != AR_FULL) for (dim = 0; dim < loop.dimen; dim++) if (!integer_onep (loop.from[dim])) { @@ -7620,8 +7629,6 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) if (tmp != NULL_TREE) gfc_conv_descriptor_span_set (&loop.pre, parm, tmp); - offset = gfc_index_zero_node; - /* The following can be somewhat confusing. We have two descriptors, a new one and the original array. {parm, parmtype, dim} refer to the new one. @@ -7635,22 +7642,17 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) tmp = gfc_conv_descriptor_dtype (parm); gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype)); - /* Set offset for assignments to pointer only to zero if it is not - the full array. */ - if ((se->direct_byref || se->use_offset) - && ((info->ref && info->ref->u.ar.type != AR_FULL) - || (expr->expr_type == EXPR_ARRAY && se->use_offset))) - base = gfc_index_zero_node; - else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) - base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre); - else - base = NULL_TREE; + /* The 1st element in the section. */ + base = gfc_index_zero_node; + + /* The offset from the 1st element in the section. */ + offset = gfc_index_zero_node; for (n = 0; n < ndim; n++) { stride = gfc_conv_array_stride (desc, n); - /* Work out the offset. */ + /* Work out the 1st element in the section. */ if (info->ref && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT) { @@ -7670,13 +7672,14 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) start, tmp); tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp), tmp, stride); - offset = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp), - offset, tmp); + base = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp), + base, tmp); if (info->ref && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT) { - /* For elemental dimensions, we only need the offset. */ + /* For elemental dimensions, we only need the 1st + element in the section. */ continue; } @@ -7696,7 +7699,6 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) from = loop.from[dim]; to = loop.to[dim]; - onebased = integer_onep (from); gfc_conv_descriptor_lbound_set (&loop.pre, parm, gfc_rank_cst[dim], from); @@ -7710,35 +7712,10 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) gfc_array_index_type, stride, info->stride[n]); - if ((se->direct_byref || se->use_offset) - && ((info->ref && info->ref->u.ar.type != AR_FULL) - || (expr->expr_type == EXPR_ARRAY && se->use_offset))) - { - base = fold_build2_loc (input_location, MINUS_EXPR, - TREE_TYPE (base), base, stride); - } - else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)) || se->use_offset) - { - bool toonebased; - tmp = gfc_conv_array_lbound (desc, n); - toonebased = integer_onep (tmp); - // lb(arr) - from (- start + 1) - tmp = fold_build2_loc (input_location, MINUS_EXPR, - TREE_TYPE (base), tmp, from); - if (onebased && toonebased) - { - tmp = fold_build2_loc (input_location, MINUS_EXPR, - TREE_TYPE (base), tmp, start); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - TREE_TYPE (base), tmp, - gfc_index_one_node); - } - tmp = fold_build2_loc (input_location, MULT_EXPR, - TREE_TYPE (base), tmp, - gfc_conv_array_stride (desc, n)); - base = fold_build2_loc (input_location, PLUS_EXPR, - TREE_TYPE (base), tmp, base); - } + tmp = fold_build2_loc (input_location, MULT_EXPR, + TREE_TYPE (offset), stride, from); + offset = fold_build2_loc (input_location, MINUS_EXPR, + TREE_TYPE (offset), offset, tmp); /* Store the new stride. */ gfc_conv_descriptor_stride_set (&loop.pre, parm, @@ -7761,58 +7738,11 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) gfc_index_zero_node); else /* Point the data pointer at the 1st element in the section. */ - gfc_get_dataptr_offset (&loop.pre, parm, desc, offset, + gfc_get_dataptr_offset (&loop.pre, parm, desc, base, subref_array_target, expr); - /* Force the offset to be -1, when the lower bound of the highest - dimension is one and the symbol is present and is not a - pointer/allocatable or associated. */ - if (((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) - && !se->data_not_needed) - || (se->use_offset && base != NULL_TREE)) - { - /* Set the offset depending on base. */ - tmp = rank_remap && !se->direct_byref ? - fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, base, - offset) - : base; - gfc_conv_descriptor_offset_set (&loop.pre, parm, tmp); - } - else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)) - && !se->data_not_needed - && (!rank_remap || se->use_offset)) - { - gfc_conv_descriptor_offset_set (&loop.pre, parm, - gfc_conv_descriptor_offset_get (desc)); - } - else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)) - && !se->data_not_needed - && gfc_expr_attr (expr).select_rank_temporary) - { - gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node); - } - else if (onebased && (!rank_remap || se->use_offset) - && expr->symtree - && !(expr->symtree->n.sym && expr->symtree->n.sym->ts.type == BT_CLASS - && !CLASS_DATA (expr->symtree->n.sym)->attr.class_pointer) - && !expr->symtree->n.sym->attr.allocatable - && !expr->symtree->n.sym->attr.pointer - && !expr->symtree->n.sym->attr.host_assoc - && !expr->symtree->n.sym->attr.use_assoc) - { - /* Set the offset to -1. */ - mpz_t minus_one; - mpz_init_set_si (minus_one, -1); - tmp = gfc_conv_mpz_to_tree (minus_one, gfc_index_integer_kind); - gfc_conv_descriptor_offset_set (&loop.pre, parm, tmp); - } - else - { - /* Only the callee knows what the correct offset it, so just set - it to zero here. */ - gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node); - } + gfc_conv_descriptor_offset_set (&loop.pre, parm, offset); + desc = parm; } @@ -8697,14 +8627,13 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, vref = gfc_build_array_ref (var, index, NULL); - if ((purpose == COPY_ALLOC_COMP || purpose == COPY_ONLY_ALLOC_COMP) - && !caf_enabled (caf_mode)) + if (purpose == COPY_ALLOC_COMP || purpose == COPY_ONLY_ALLOC_COMP) { tmp = build_fold_indirect_ref_loc (input_location, gfc_conv_array_data (dest)); dref = gfc_build_array_ref (tmp, index, NULL); tmp = structure_alloc_comps (der_type, vref, dref, rank, - COPY_ALLOC_COMP, 0, args); + COPY_ALLOC_COMP, caf_mode, args); } else tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose, @@ -9445,12 +9374,21 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, else if (flag_coarray == GFC_FCOARRAY_LIB && caf_in_coarray (caf_mode)) { - tree dst_tok = c->as ? gfc_conv_descriptor_token (dcmp) - : fold_build3_loc (input_location, - COMPONENT_REF, - pvoid_type_node, dest, - c->caf_token, - NULL_TREE); + tree dst_tok; + if (c->as) + dst_tok = gfc_conv_descriptor_token (dcmp); + else + { + /* For a scalar allocatable component the caf_token is + the next component. */ + if (!c->caf_token) + c->caf_token = c->next->backend_decl; + dst_tok = fold_build3_loc (input_location, + COMPONENT_REF, + pvoid_type_node, dest, + c->caf_token, + NULL_TREE); + } tmp = duplicate_allocatable_coarray (dcmp, dst_tok, comp, ctype, rank); } @@ -10870,7 +10808,8 @@ gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref) if (ref->type == REF_SUBSTRING) { ss = gfc_get_scalar_ss (ss, ref->u.ss.start); - ss = gfc_get_scalar_ss (ss, ref->u.ss.end); + if (ref->u.ss.end) + ss = gfc_get_scalar_ss (ss, ref->u.ss.end); } /* We're only interested in array sections from now on. */ diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c index bf163bc..c6383fc 100644 --- a/gcc/fortran/trans-common.c +++ b/gcc/fortran/trans-common.c @@ -242,10 +242,13 @@ static tree gfc_sym_mangled_common_id (gfc_common_head *com) { int has_underscore; - char mangled_name[GFC_MAX_MANGLED_SYMBOL_LEN + 1]; - char name[GFC_MAX_SYMBOL_LEN + 1]; + /* Provide sufficient space to hold "symbol.symbol.eq.1234567890__". */ + char mangled_name[2*GFC_MAX_MANGLED_SYMBOL_LEN + 1 + 16 + 1]; + char name[sizeof (mangled_name) - 2]; /* Get the name out of the common block pointer. */ + size_t len = strlen (com->name); + gcc_assert (len < sizeof (name)); strcpy (name, com->name); /* If we're suppose to do a bind(c). */ @@ -1313,7 +1316,11 @@ finish_equivalences (gfc_namespace *ns) c->where = ns->proc_name->declared_at; else if (ns->is_block_data) c->where = ns->sym_root->n.sym->declared_at; - strcpy (c->name, z->module); + + size_t len = strlen (z->module); + gcc_assert (len < sizeof (c->name)); + memcpy (c->name, z->module, len); + c->name[len] = '\0'; } else c = NULL; diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 487e776..45a739a 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -1682,9 +1682,7 @@ gfc_get_symbol_decl (gfc_symbol * sym) TREE_USED (sym->backend_decl) = 1; if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0) - { - gfc_add_assign_aux_vars (sym); - } + gfc_add_assign_aux_vars (sym); if (sym->ts.type == BT_CLASS && sym->backend_decl) GFC_DECL_CLASS(sym->backend_decl) = 1; @@ -1692,6 +1690,10 @@ gfc_get_symbol_decl (gfc_symbol * sym) return sym->backend_decl; } + if (sym->result == sym && sym->attr.assign + && GFC_DECL_ASSIGN (sym->backend_decl) == 0) + gfc_add_assign_aux_vars (sym); + if (sym->backend_decl) return sym->backend_decl; @@ -2088,12 +2090,17 @@ gfc_get_extern_function_decl (gfc_symbol * sym, gfc_actual_arglist *actual_args) if (gsym && !gsym->bind_c) gsym = NULL; } - else + else if (sym->module == NULL) { gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name); if (gsym && gsym->bind_c) gsym = NULL; } + else + { + /* Procedure from a different module. */ + gsym = NULL; + } if (gsym && !gsym->defined) gsym = NULL; @@ -3196,6 +3203,9 @@ gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag) else current_fake_result_decl = build_tree_list (NULL, decl); + if (sym->attr.assign) + DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (sym->backend_decl); + return decl; } @@ -6784,7 +6794,7 @@ gfc_generate_function_code (gfc_namespace * ns) || (sym->attr.entry_master && sym->ns->entries->sym->attr.recursive); if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) - && !is_recursive && !flag_recursive) + && !is_recursive && !flag_recursive && !sym->attr.artificial) { char * msg; diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 030edc1..36ff9b5 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1712,12 +1712,12 @@ gfc_make_safe_expr (gfc_se * se) Also used for arguments to procedures with multiple entry points. */ tree -gfc_conv_expr_present (gfc_symbol * sym) +gfc_conv_expr_present (gfc_symbol * sym, bool use_saved_desc) { - tree decl, cond; + tree decl, orig_decl, cond; gcc_assert (sym->attr.dummy); - decl = gfc_get_symbol_decl (sym); + orig_decl = decl = gfc_get_symbol_decl (sym); /* Intrinsic scalars with VALUE attribute which are passed by value use a hidden argument to denote the present status. */ @@ -1744,10 +1744,13 @@ gfc_conv_expr_present (gfc_symbol * sym) return cond; } - if (TREE_CODE (decl) != PARM_DECL) + /* Assumed-shape arrays use a local variable for the array data; + the actual PARAM_DECL is in a saved decl. As the local variable + is NULL, it can be checked instead, unless use_saved_desc is + requested. */ + + if (use_saved_desc && TREE_CODE (decl) != PARM_DECL) { - /* Array parameters use a temporary descriptor, we want the real - parameter. */ gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)) || GFC_ARRAY_TYPE_P (TREE_TYPE (decl))); decl = GFC_DECL_SAVED_DESCRIPTOR (decl); @@ -1761,9 +1764,12 @@ gfc_conv_expr_present (gfc_symbol * sym) we thus also need to check the array descriptor. For BT_CLASS, it can also occur for scalars and F2003 due to type->class wrapping and class->class wrapping. Note further that BT_CLASS always uses an - array descriptor for arrays, also for explicit-shape/assumed-size. */ + array descriptor for arrays, also for explicit-shape/assumed-size. + For assumed-rank arrays, no local variable is generated, hence, + the following also applies with !use_saved_desc. */ - if (!sym->attr.allocatable + if ((use_saved_desc || TREE_CODE (orig_decl) == PARM_DECL) + && !sym->attr.allocatable && ((sym->ts.type != BT_CLASS && !sym->attr.pointer) || (sym->ts.type == BT_CLASS && !CLASS_DATA (sym)->attr.allocatable @@ -2607,7 +2613,8 @@ gfc_maybe_dereference_var (gfc_symbol *sym, tree var, bool descriptor_only_p, { /* Dereference character pointer dummy arguments or results. */ - if ((sym->attr.pointer || sym->attr.allocatable) + if ((sym->attr.pointer || sym->attr.allocatable + || (sym->as && sym->as->type == AS_ASSUMED_RANK)) && (sym->attr.dummy || sym->attr.function || sym->attr.result)) @@ -6237,6 +6244,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, || gfc_expr_attr (e).allocatable) set_dtype_for_unallocated (&parmse, e); else if (e->expr_type == EXPR_VARIABLE + && e->ref + && e->ref->u.ar.type == AR_FULL && e->symtree->n.sym->attr.dummy && e->symtree->n.sym->as && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE) @@ -8804,6 +8813,7 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr, bool add_clobber) if (expr->expr_type == EXPR_FUNCTION && ((expr->value.function.esym + && expr->value.function.esym->result && expr->value.function.esym->result->attr.pointer && !expr->value.function.esym->result->attr.dimension) || (!expr->value.function.esym && !expr->ref @@ -9926,6 +9936,8 @@ fcncall_realloc_result (gfc_se *se, int rank) tree tmp; tree offset; tree zero_cond; + tree not_same_shape; + stmtblock_t shape_block; int n; /* Use the allocation done by the library. Substitute the lhs @@ -9955,7 +9967,11 @@ fcncall_realloc_result (gfc_se *se, int rank) tmp = gfc_conv_descriptor_data_get (res_desc); gfc_conv_descriptor_data_set (&se->post, desc, tmp); - /* Check that the shapes are the same between lhs and expression. */ + /* Check that the shapes are the same between lhs and expression. + The evaluation of the shape is done in 'shape_block' to avoid + unitialized warnings from the lhs bounds. */ + not_same_shape = boolean_false_node; + gfc_start_block (&shape_block); for (n = 0 ; n < rank; n++) { tree tmp1; @@ -9972,15 +9988,24 @@ fcncall_realloc_result (gfc_se *se, int rank) tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp, gfc_index_zero_node); - tmp = gfc_evaluate_now (tmp, &se->post); - zero_cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, - logical_type_node, tmp, - zero_cond); + tmp = gfc_evaluate_now (tmp, &shape_block); + if (n == 0) + not_same_shape = tmp; + else + not_same_shape = fold_build2_loc (input_location, TRUTH_OR_EXPR, + logical_type_node, tmp, + not_same_shape); } /* 'zero_cond' being true is equal to lhs not being allocated or the shapes being different. */ - zero_cond = gfc_evaluate_now (zero_cond, &se->post); + tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node, + zero_cond, not_same_shape); + gfc_add_modify (&shape_block, zero_cond, tmp); + tmp = gfc_finish_block (&shape_block); + tmp = build3_v (COND_EXPR, zero_cond, + build_empty_stmt (input_location), tmp); + gfc_add_expr_to_block (&se->post, tmp); /* Now reset the bounds returned from the function call to bounds based on the lhs lbounds, except where the lhs is not allocated or the shapes diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index 6666955..063d4c1 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -44,6 +44,7 @@ along with GCC; see the file COPYING3. If not see #undef GCC_DIAG_STYLE #define GCC_DIAG_STYLE __gcc_gfc__ #include "attribs.h" +#include "function.h" int ompws_flags; @@ -90,16 +91,13 @@ gfc_omp_check_optional_argument (tree decl, bool for_present_check) if (!DECL_LANG_SPECIFIC (decl)) return NULL_TREE; - bool is_array_type = false; + tree orig_decl = decl; /* For assumed-shape arrays, a local decl with arg->data is used. */ if (TREE_CODE (decl) != PARM_DECL && (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)) || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)))) - { - is_array_type = true; - decl = GFC_DECL_SAVED_DESCRIPTOR (decl); - } + decl = GFC_DECL_SAVED_DESCRIPTOR (decl); if (decl == NULL_TREE || TREE_CODE (decl) != PARM_DECL @@ -132,23 +130,8 @@ gfc_omp_check_optional_argument (tree decl, bool for_present_check) return decl; } - tree cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, - decl, null_pointer_node); - - /* Fortran regards unallocated allocatables/disassociated pointer which - are passed to a nonallocatable, nonpointer argument as not associated; - cf. F2018, 15.5.2.12, Paragraph 1. */ - if (is_array_type) - { - tree cond2 = build_fold_indirect_ref_loc (input_location, decl); - cond2 = gfc_conv_array_data (cond2); - cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, - cond2, null_pointer_node); - cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, - boolean_type_node, cond, cond2); - } - - return cond; + return fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + orig_decl, null_pointer_node); } @@ -224,7 +207,8 @@ gfc_omp_privatize_by_reference (const_tree decl) return false; } -/* True if OpenMP sharing attribute of DECL is predetermined. */ +/* OMP_CLAUSE_DEFAULT_UNSPECIFIED unless OpenMP sharing attribute + of DECL is predetermined. */ enum omp_clause_default_kind gfc_omp_predetermined_sharing (tree decl) @@ -295,6 +279,28 @@ gfc_omp_predetermined_sharing (tree decl) return OMP_CLAUSE_DEFAULT_UNSPECIFIED; } + +/* OMP_CLAUSE_DEFAULTMAP_CATEGORY_UNSPECIFIED unless OpenMP mapping attribute + of DECL is predetermined. */ + +enum omp_clause_defaultmap_kind +gfc_omp_predetermined_mapping (tree decl) +{ + if (DECL_ARTIFICIAL (decl) + && ! GFC_DECL_RESULT (decl) + && ! (DECL_LANG_SPECIFIC (decl) + && GFC_DECL_SAVED_DESCRIPTOR (decl))) + return OMP_CLAUSE_DEFAULTMAP_TO; + + /* These are either array or derived parameters, or vtables. */ + if (VAR_P (decl) && TREE_READONLY (decl) + && (TREE_STATIC (decl) || DECL_EXTERNAL (decl))) + return OMP_CLAUSE_DEFAULTMAP_TO; + + return OMP_CLAUSE_DEFAULTMAP_CATEGORY_UNSPECIFIED; +} + + /* Return decl that should be used when reporting DEFAULT(NONE) diagnostics. */ @@ -324,6 +330,11 @@ gfc_has_alloc_comps (tree type, tree decl) return false; } + if (GFC_DESCRIPTOR_TYPE_P (type) + && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER + || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)) + return false; + if (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type)) type = gfc_get_element_type (type); @@ -602,10 +613,21 @@ gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer) tree type = TREE_TYPE (decl), size, ptr, cond, then_b, else_b; stmtblock_t block, cond_block; - gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_PRIVATE - || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LASTPRIVATE - || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR - || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_REDUCTION); + switch (OMP_CLAUSE_CODE (clause)) + { + case OMP_CLAUSE__LOOPTEMP_: + case OMP_CLAUSE__REDUCTEMP_: + case OMP_CLAUSE__CONDTEMP_: + case OMP_CLAUSE__SCANTEMP_: + return NULL; + case OMP_CLAUSE_PRIVATE: + case OMP_CLAUSE_LASTPRIVATE: + case OMP_CLAUSE_LINEAR: + case OMP_CLAUSE_REDUCTION: + break; + default: + gcc_unreachable (); + } if ((! GFC_DESCRIPTOR_TYPE_P (type) || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) @@ -1287,22 +1309,6 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p) return; tree orig_decl = decl; - /* For nonallocatable, nonpointer arrays, a temporary variable is - generated, but this one is only defined if the variable is present; - hence, we now set it to NULL to avoid accessing undefined variables. - We cannot use a temporary variable here as otherwise the replacement - of the variables in omp-low.c will not work. */ - if (present && GFC_ARRAY_TYPE_P (TREE_TYPE (decl))) - { - tree tmp = fold_build2_loc (input_location, MODIFY_EXPR, - void_type_node, decl, null_pointer_node); - tree cond = fold_build1_loc (input_location, TRUTH_NOT_EXPR, - boolean_type_node, present); - tmp = build3_loc (input_location, COND_EXPR, void_type_node, - cond, tmp, NULL_TREE); - gimplify_and_add (tmp, pre_p); - } - c4 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP); OMP_CLAUSE_SET_MAP_KIND (c4, GOMP_MAP_POINTER); OMP_CLAUSE_DECL (c4) = decl; @@ -1683,6 +1689,10 @@ gfc_trans_omp_variable_list (enum omp_clause_code code, tree node = build_omp_clause (input_location, code); OMP_CLAUSE_DECL (node) = t; list = gfc_trans_add_clause (node, list); + + if (code == OMP_CLAUSE_LASTPRIVATE + && namelist->u.lastprivate_conditional) + OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (node) = 1; } } return list; @@ -2097,10 +2107,11 @@ static vec<tree, va_heap, vl_embed> *doacross_steps; 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) + tree &node, tree &node2, tree &node3, tree &node4) { gfc_se se; tree ptr, ptr2; + tree elemsz = NULL_TREE; gfc_init_se (&se, NULL); @@ -2109,7 +2120,8 @@ gfc_trans_omp_array_section (stmtblock_t *block, gfc_omp_namelist *n, 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 (ptr)); + OMP_CLAUSE_SIZE (node) = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (ptr))); + elemsz = OMP_CLAUSE_SIZE (node); } else { @@ -2119,14 +2131,15 @@ gfc_trans_omp_array_section (stmtblock_t *block, gfc_omp_namelist *n, gfc_add_block_to_block (block, &se.pre); OMP_CLAUSE_SIZE (node) = gfc_full_array_size (block, se.expr, GFC_TYPE_ARRAY_RANK (type)); - tree elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + 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); } - gfc_add_block_to_block (block, &se.post); + gcc_assert (se.post.head == NULL_TREE); ptr = fold_convert (build_pointer_type (char_type_node), ptr); OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr); + ptr = fold_convert (ptrdiff_type_node, ptr); if (POINTER_TYPE_P (TREE_TYPE (decl)) && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl))) @@ -2139,28 +2152,71 @@ gfc_trans_omp_array_section (stmtblock_t *block, gfc_omp_namelist *n, OMP_CLAUSE_SIZE (node4) = size_int (0); decl = build_fold_indirect_ref (decl); } - ptr = fold_convert (sizetype, ptr); + else if (ptr_kind == GOMP_MAP_ALWAYS_POINTER + && n->expr->ts.type == BT_CHARACTER + && 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) + map_kind = OMP_CLAUSE_MAP_KIND (node); + else + map_kind = GOMP_MAP_ALLOC; + gcc_assert (se.string_length); + node4 = build_omp_clause (input_location, OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node4, map_kind); + OMP_CLAUSE_DECL (node4) = se.string_length; + OMP_CLAUSE_SIZE (node4) = TYPE_SIZE_UNIT (gfc_charlen_type_node); + } if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) { + tree desc_node; tree type = TREE_TYPE (decl); ptr2 = gfc_conv_descriptor_data_get (decl); - node2 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_TO_PSET); - OMP_CLAUSE_DECL (node2) = decl; - OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type); + 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) + { + OMP_CLAUSE_SET_MAP_KIND (desc_node, GOMP_MAP_TO); + node2 = node; + node = desc_node; /* Needs to come first. */ + } + else + { + OMP_CLAUSE_SET_MAP_KIND (desc_node, GOMP_MAP_TO_PSET); + node2 = desc_node; + } 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); + /* This purposely does not include GOMP_MAP_ALWAYS_POINTER. The extra + cast prevents gimplify.c from recognising it as being part of the + struct – and adding an 'alloc: for the 'desc.data' pointer, which + would break as the 'desc' (the descriptor) is also mapped + (see node4 above). */ if (ptr_kind == GOMP_MAP_ATTACH_DETACH) STRIP_NOPS (OMP_CLAUSE_DECL (node3)); } else { if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE) - ptr2 = build_fold_addr_expr (decl); + { + tree offset; + ptr2 = build_fold_addr_expr (decl); + offset = fold_build2 (MINUS_EXPR, ptrdiff_type_node, ptr, + fold_convert (ptrdiff_type_node, ptr2)); + offset = build2 (TRUNC_DIV_EXPR, ptrdiff_type_node, + offset, fold_convert (ptrdiff_type_node, elemsz)); + offset = build4_loc (input_location, ARRAY_REF, + TREE_TYPE (TREE_TYPE (decl)), + decl, offset, NULL_TREE, NULL_TREE); + OMP_CLAUSE_DECL (node) = offset; + } else { gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl))); @@ -2171,14 +2227,15 @@ gfc_trans_omp_array_section (stmtblock_t *block, gfc_omp_namelist *n, OMP_CLAUSE_SET_MAP_KIND (node3, ptr_kind); OMP_CLAUSE_DECL (node3) = decl; } - ptr2 = fold_convert (sizetype, ptr2); - OMP_CLAUSE_SIZE (node3) - = fold_build2 (MINUS_EXPR, sizetype, ptr, ptr2); + ptr2 = fold_convert (ptrdiff_type_node, ptr2); + OMP_CLAUSE_SIZE (node3) = fold_build2 (MINUS_EXPR, ptrdiff_type_node, + ptr, ptr2); } static tree gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, - locus where, bool declare_simd = false) + locus where, bool declare_simd = false, + bool openacc = false) { tree omp_clauses = NULL_TREE, chunk_size, c; int list, ifc; @@ -2233,6 +2290,9 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, case OMP_LIST_IS_DEVICE_PTR: clause_code = OMP_CLAUSE_IS_DEVICE_PTR; goto add_clause; + case OMP_LIST_NONTEMPORAL: + clause_code = OMP_CLAUSE_NONTEMPORAL; + goto add_clause; add_clause: omp_clauses @@ -2493,6 +2553,67 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, tree node2 = NULL_TREE; tree node3 = NULL_TREE; tree node4 = NULL_TREE; + + switch (n->u.map_op) + { + case OMP_MAP_ALLOC: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALLOC); + break; + case OMP_MAP_IF_PRESENT: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_IF_PRESENT); + break; + case OMP_MAP_ATTACH: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ATTACH); + break; + case OMP_MAP_TO: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_TO); + break; + case OMP_MAP_FROM: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FROM); + break; + case OMP_MAP_TOFROM: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_TOFROM); + break; + case OMP_MAP_ALWAYS_TO: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_TO); + break; + case OMP_MAP_ALWAYS_FROM: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_FROM); + break; + case OMP_MAP_ALWAYS_TOFROM: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_TOFROM); + break; + case OMP_MAP_RELEASE: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_RELEASE); + break; + case OMP_MAP_DELETE: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_DELETE); + break; + case OMP_MAP_DETACH: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_DETACH); + break; + case OMP_MAP_FORCE_ALLOC: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_ALLOC); + break; + case OMP_MAP_FORCE_TO: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_TO); + break; + case OMP_MAP_FORCE_FROM: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_FROM); + break; + case OMP_MAP_FORCE_TOFROM: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_TOFROM); + break; + case OMP_MAP_FORCE_PRESENT: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_PRESENT); + break; + case OMP_MAP_FORCE_DEVICEPTR: + OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_DEVICEPTR); + break; + default: + gcc_unreachable (); + } + tree decl = gfc_trans_omp_variable (n->sym, false); if (DECL_P (decl)) TREE_ADDRESSABLE (decl) = 1; @@ -2501,7 +2622,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, && n->expr->ref->u.ar.type == AR_FULL)) { tree present = gfc_omp_check_optional_argument (decl, true); - if (n->sym->ts.type == BT_CLASS) + if (openacc && n->sym->ts.type == BT_CLASS) { tree type = TREE_TYPE (decl); if (n->sym->attr.optional) @@ -2582,9 +2703,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, decl = build_fold_indirect_ref (decl); } } - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)) - && n->u.map_op != OMP_MAP_ATTACH - && n->u.map_op != OMP_MAP_DETACH) + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) { tree type = TREE_TYPE (decl); tree ptr = gfc_conv_descriptor_data_get (decl); @@ -2602,7 +2721,6 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type); node3 = build_omp_clause (input_location, OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_POINTER); if (present) { ptr = gfc_conv_descriptor_data_get (decl); @@ -2616,6 +2734,33 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, 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, GOMP_MAP_POINTER); /* We have to check for n->sym->attr.dimension because of scalar coarrays. */ @@ -2729,8 +2874,42 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, /* Last component is a scalar. */ gfc_conv_expr (&se, n->expr); gfc_add_block_to_block (block, &se.pre); - OMP_CLAUSE_DECL (node) = se.expr; + /* For BT_CHARACTER a pointer is returned. */ + OMP_CLAUSE_DECL (node) + = POINTER_TYPE_P (TREE_TYPE (se.expr)) + ? build_fold_indirect_ref (se.expr) : se.expr; gfc_add_block_to_block (block, &se.post); + if (sym_attr.pointer || sym_attr.allocatable) + { + node2 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node2, + openacc + ? GOMP_MAP_ATTACH_DETACH + : GOMP_MAP_ALWAYS_POINTER); + OMP_CLAUSE_DECL (node2) + = POINTER_TYPE_P (TREE_TYPE (se.expr)) + ? se.expr : gfc_build_addr_expr (NULL, se.expr); + OMP_CLAUSE_SIZE (node2) = size_int (0); + if (!openacc + && n->expr->ts.type == BT_CHARACTER + && n->expr->ts.deferred) + { + gcc_assert (se.string_length); + tree tmp = gfc_get_char_type (n->expr->ts.kind); + OMP_CLAUSE_SIZE (node) + = fold_build2 (MULT_EXPR, size_type_node, + fold_convert (size_type_node, + se.string_length), + TYPE_SIZE_UNIT (tmp)); + node3 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_TO); + OMP_CLAUSE_DECL (node3) = se.string_length; + OMP_CLAUSE_SIZE (node3) + = TYPE_SIZE_UNIT (gfc_charlen_type_node); + } + } goto finalize_map_clause; } @@ -2757,7 +2936,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, if (lastcomp->u.c.component->ts.type == BT_DERIVED || lastcomp->u.c.component->ts.type == BT_CLASS) { - if (sym_attr.allocatable || sym_attr.pointer) + if (sym_attr.pointer || (openacc && sym_attr.allocatable)) { tree data, size; @@ -2778,15 +2957,17 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, node2 = build_omp_clause (input_location, OMP_CLAUSE_MAP); OMP_CLAUSE_SET_MAP_KIND (node2, - GOMP_MAP_ATTACH_DETACH); + openacc + ? GOMP_MAP_ATTACH_DETACH + : GOMP_MAP_ALWAYS_POINTER); OMP_CLAUSE_DECL (node2) = data; OMP_CLAUSE_SIZE (node2) = size_int (0); } else { - OMP_CLAUSE_DECL (node) = decl; + OMP_CLAUSE_DECL (node) = inner; OMP_CLAUSE_SIZE (node) - = TYPE_SIZE_UNIT (TREE_TYPE (decl)); + = TYPE_SIZE_UNIT (TREE_TYPE (inner)); } } else if (lastcomp->next @@ -2805,32 +2986,82 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (inner))) { + gomp_map_kind map_kind; + tree desc_node; tree type = TREE_TYPE (inner); tree ptr = gfc_conv_descriptor_data_get (inner); 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); - OMP_CLAUSE_DECL (node2) = inner; - OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type); - node3 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (node3, - GOMP_MAP_ATTACH_DETACH); - OMP_CLAUSE_DECL (node3) - = gfc_conv_descriptor_data_get (inner); - STRIP_NOPS (OMP_CLAUSE_DECL (node3)); - OMP_CLAUSE_SIZE (node3) = size_int (0); int rank = GFC_TYPE_ARRAY_RANK (type); OMP_CLAUSE_SIZE (node) = 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; + else if (n->u.map_op == OMP_MAP_RELEASE + || n->u.map_op == OMP_MAP_DELETE) + map_kind = OMP_CLAUSE_MAP_KIND (node); + else + map_kind = GOMP_MAP_ALLOC; + if (!openacc + && n->expr->ts.type == BT_CHARACTER + && n->expr->ts.deferred) + { + gcc_assert (se.string_length); + tree len = fold_convert (size_type_node, + se.string_length); + elemsz = gfc_get_char_type (n->expr->ts.kind); + elemsz = TYPE_SIZE_UNIT (elemsz); + elemsz = fold_build2 (MULT_EXPR, size_type_node, + len, elemsz); + node4 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node4, map_kind); + OMP_CLAUSE_DECL (node4) = se.string_length; + OMP_CLAUSE_SIZE (node4) + = TYPE_SIZE_UNIT (gfc_charlen_type_node); + } 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); + desc_node = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + if (openacc) + OMP_CLAUSE_SET_MAP_KIND (desc_node, + GOMP_MAP_TO_PSET); + else + OMP_CLAUSE_SET_MAP_KIND (desc_node, map_kind); + OMP_CLAUSE_DECL (desc_node) = inner; + OMP_CLAUSE_SIZE (desc_node) = TYPE_SIZE_UNIT (type); + if (openacc) + node2 = desc_node; + else + { + node2 = node; + node = desc_node; /* Put first. */ + } + node3 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (node3, + openacc + ? GOMP_MAP_ATTACH_DETACH + : GOMP_MAP_ALWAYS_POINTER); + OMP_CLAUSE_DECL (node3) + = gfc_conv_descriptor_data_get (inner); + /* Similar to gfc_trans_omp_array_section (details + there), we add/keep the cast for OpenMP to prevent + that an 'alloc:' gets added for node3 ('desc.data') + as that is part of the whole descriptor (node3). + TODO: Remove once the ME handles this properly. */ + if (!openacc) + OMP_CLAUSE_DECL (node3) + = fold_convert (TREE_TYPE (TREE_OPERAND(ptr, 0)), + OMP_CLAUSE_DECL (node3)); + else + STRIP_NOPS (OMP_CLAUSE_DECL (node3)); + OMP_CLAUSE_SIZE (node3) = size_int (0); } else OMP_CLAUSE_DECL (node) = inner; @@ -2842,9 +3073,11 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, && lastcomp->next->type == REF_ARRAY && lastcomp->next->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, - GOMP_MAP_ATTACH_DETACH, - node, node2, node3, node4); + kind, node, node2, node3, + node4); } } else /* An array element or array section. */ @@ -2856,65 +3089,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, } finalize_map_clause: - switch (n->u.map_op) - { - case OMP_MAP_ALLOC: - OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALLOC); - break; - case OMP_MAP_IF_PRESENT: - OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_IF_PRESENT); - break; - case OMP_MAP_ATTACH: - OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ATTACH); - break; - case OMP_MAP_TO: - OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_TO); - break; - case OMP_MAP_FROM: - OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FROM); - break; - case OMP_MAP_TOFROM: - OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_TOFROM); - break; - case OMP_MAP_ALWAYS_TO: - OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_TO); - break; - case OMP_MAP_ALWAYS_FROM: - OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_FROM); - break; - case OMP_MAP_ALWAYS_TOFROM: - OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_ALWAYS_TOFROM); - break; - case OMP_MAP_RELEASE: - OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_RELEASE); - break; - case OMP_MAP_DELETE: - OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_DELETE); - break; - case OMP_MAP_DETACH: - OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_DETACH); - break; - case OMP_MAP_FORCE_ALLOC: - OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_ALLOC); - break; - case OMP_MAP_FORCE_TO: - OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_TO); - break; - case OMP_MAP_FORCE_FROM: - OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_FROM); - break; - case OMP_MAP_FORCE_TOFROM: - OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_TOFROM); - break; - case OMP_MAP_FORCE_PRESENT: - OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_PRESENT); - break; - case OMP_MAP_FORCE_DEVICEPTR: - OMP_CLAUSE_SET_MAP_KIND (node, GOMP_MAP_FORCE_DEVICEPTR); - break; - default: - gcc_unreachable (); - } + omp_clauses = gfc_trans_add_clause (node, omp_clauses); if (node2) omp_clauses = gfc_trans_add_clause (node2, omp_clauses); @@ -3054,9 +3229,15 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_IF); switch (ifc) { + case OMP_IF_CANCEL: + OMP_CLAUSE_IF_MODIFIER (c) = VOID_CST; + break; case OMP_IF_PARALLEL: OMP_CLAUSE_IF_MODIFIER (c) = OMP_PARALLEL; break; + case OMP_IF_SIMD: + OMP_CLAUSE_IF_MODIFIER (c) = OMP_SIMD; + break; case OMP_IF_TASK: OMP_CLAUSE_IF_MODIFIER (c) = OMP_TASK; break; @@ -3203,6 +3384,12 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, omp_clauses = gfc_trans_add_clause (c, omp_clauses); } + if (clauses->order_concurrent) + { + c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_ORDER); + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + if (clauses->untied) { c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_UNTIED); @@ -3666,7 +3853,7 @@ gfc_trans_oacc_construct (gfc_code *code) gfc_start_block (&block); oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, - code->loc); + code->loc, false, true); stmt = gfc_trans_omp_code (code->block->next, true); stmt = build2_loc (input_location, construct_code, void_type_node, stmt, oacc_clauses); @@ -3702,7 +3889,7 @@ gfc_trans_oacc_executable_directive (gfc_code *code) gfc_start_block (&block); oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, - code->loc); + code->loc, false, true); stmt = build1_loc (input_location, construct_code, void_type_node, oacc_clauses); gfc_add_expr_to_block (&block, stmt); @@ -3764,9 +3951,13 @@ gfc_trans_omp_atomic (gfc_code *code) enum tree_code op = ERROR_MARK; enum tree_code aop = OMP_ATOMIC; bool var_on_left = false; - enum omp_memory_order mo - = ((atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_SEQ_CST) - ? OMP_MEMORY_ORDER_SEQ_CST : OMP_MEMORY_ORDER_RELAXED); + enum omp_memory_order mo; + if (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_SEQ_CST) + mo = OMP_MEMORY_ORDER_SEQ_CST; + else if (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_ACQ_REL) + mo = OMP_MEMORY_ORDER_ACQ_REL; + else + mo = OMP_MEMORY_ORDER_RELAXED; code = code->block->next; gcc_assert (code->op == EXEC_ASSIGN); @@ -4050,13 +4241,18 @@ gfc_trans_omp_cancel (gfc_code *code) default: gcc_unreachable (); } gfc_start_block (&block); - if (code->ext.omp_clauses->if_expr) + if (code->ext.omp_clauses->if_expr + || code->ext.omp_clauses->if_exprs[OMP_IF_CANCEL]) { gfc_se se; tree if_var; + gcc_assert ((code->ext.omp_clauses->if_expr == NULL) + ^ (code->ext.omp_clauses->if_exprs[OMP_IF_CANCEL] == NULL)); gfc_init_se (&se, NULL); - gfc_conv_expr (&se, code->ext.omp_clauses->if_expr); + gfc_conv_expr (&se, code->ext.omp_clauses->if_expr != NULL + ? code->ext.omp_clauses->if_expr + : code->ext.omp_clauses->if_exprs[OMP_IF_CANCEL]); gfc_add_block_to_block (&block, &se.pre); if_var = gfc_evaluate_now (se.expr, &block); gfc_add_block_to_block (&block, &se.post); @@ -4095,12 +4291,20 @@ gfc_trans_omp_cancellation_point (gfc_code *code) static tree gfc_trans_omp_critical (gfc_code *code) { - tree name = NULL_TREE, stmt; - if (code->ext.omp_clauses != NULL) + stmtblock_t block; + tree stmt, name = NULL_TREE; + if (code->ext.omp_clauses->critical_name != NULL) name = get_identifier (code->ext.omp_clauses->critical_name); - stmt = gfc_trans_code (code->block->next); - return build3_loc (input_location, OMP_CRITICAL, void_type_node, stmt, - NULL_TREE, name); + gfc_start_block (&block); + stmt = make_node (OMP_CRITICAL); + TREE_TYPE (stmt) = void_type_node; + OMP_CRITICAL_BODY (stmt) = gfc_trans_code (code->block->next); + OMP_CRITICAL_NAME (stmt) = name; + OMP_CRITICAL_CLAUSES (stmt) = gfc_trans_omp_clauses (&block, + code->ext.omp_clauses, + code->loc); + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); } typedef struct dovar_init_d { @@ -4296,23 +4500,22 @@ gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock, break; } } - if (!dovar_found) + if (!dovar_found && op == EXEC_OMP_SIMD) { - if (op == EXEC_OMP_SIMD) + if (collapse == 1) { - if (collapse == 1) - { - tmp = build_omp_clause (input_location, OMP_CLAUSE_LINEAR); - OMP_CLAUSE_LINEAR_STEP (tmp) = step; - OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1; - } - else - tmp = build_omp_clause (input_location, OMP_CLAUSE_LASTPRIVATE); - if (!simple) - dovar_found = 2; + tmp = build_omp_clause (input_location, OMP_CLAUSE_LINEAR); + OMP_CLAUSE_LINEAR_STEP (tmp) = step; + OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1; + OMP_CLAUSE_DECL (tmp) = dovar_decl; + omp_clauses = gfc_trans_add_clause (tmp, omp_clauses); } - else - tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE); + if (!simple) + dovar_found = 2; + } + else if (!dovar_found && !simple) + { + tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE); OMP_CLAUSE_DECL (tmp) = dovar_decl; omp_clauses = gfc_trans_add_clause (tmp, omp_clauses); } @@ -4370,6 +4573,8 @@ gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock, { tree l = build_omp_clause (input_location, OMP_CLAUSE_LASTPRIVATE); + if (OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (c)) + OMP_CLAUSE_LASTPRIVATE_CONDITIONAL (l) = 1; OMP_CLAUSE_DECL (l) = dovar_decl; OMP_CLAUSE_CHAIN (l) = omp_clauses; OMP_CLAUSE_LASTPRIVATE_STMT (l) = tmp; @@ -4528,7 +4733,7 @@ gfc_trans_oacc_combined_directive (gfc_code *code) if (construct_code == OACC_KERNELS) construct_clauses.lists[OMP_LIST_REDUCTION] = NULL; oacc_clauses = gfc_trans_omp_clauses (&block, &construct_clauses, - code->loc); + code->loc, false, true); } if (!loop_clauses.seq) pblock = █ @@ -4759,7 +4964,7 @@ gfc_split_omp_clauses (gfc_code *code, clausesa[GFC_OMP_SPLIT_TARGET].if_exprs[OMP_IF_TARGET] = code->ext.omp_clauses->if_exprs[OMP_IF_TARGET]; /* And this is copied to all. */ - clausesa[GFC_OMP_SPLIT_PARALLEL].if_expr + clausesa[GFC_OMP_SPLIT_TARGET].if_expr = code->ext.omp_clauses->if_expr; } if (mask & GFC_OMP_MASK_TEAMS) @@ -4786,6 +4991,8 @@ gfc_split_omp_clauses (gfc_code *code, /* Duplicate collapse. */ clausesa[GFC_OMP_SPLIT_DISTRIBUTE].collapse = code->ext.omp_clauses->collapse; + clausesa[GFC_OMP_SPLIT_DISTRIBUTE].order_concurrent + = code->ext.omp_clauses->order_concurrent; } if (mask & GFC_OMP_MASK_PARALLEL) { @@ -4831,6 +5038,8 @@ gfc_split_omp_clauses (gfc_code *code, /* Duplicate collapse. */ clausesa[GFC_OMP_SPLIT_DO].collapse = code->ext.omp_clauses->collapse; + clausesa[GFC_OMP_SPLIT_DO].order_concurrent + = code->ext.omp_clauses->order_concurrent; } if (mask & GFC_OMP_MASK_SIMD) { @@ -4843,6 +5052,13 @@ gfc_split_omp_clauses (gfc_code *code, /* Duplicate collapse. */ clausesa[GFC_OMP_SPLIT_SIMD].collapse = code->ext.omp_clauses->collapse; + clausesa[GFC_OMP_SPLIT_SIMD].if_exprs[OMP_IF_SIMD] + = code->ext.omp_clauses->if_exprs[OMP_IF_SIMD]; + clausesa[GFC_OMP_SPLIT_SIMD].order_concurrent + = code->ext.omp_clauses->order_concurrent; + /* And this is copied to all. */ + clausesa[GFC_OMP_SPLIT_SIMD].if_expr + = code->ext.omp_clauses->if_expr; } if (mask & GFC_OMP_MASK_TASKLOOP) { @@ -5361,7 +5577,7 @@ gfc_trans_omp_target (gfc_code *code) pushlevel (); gfc_start_block (&iblock); tree inner_clauses - = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL], + = gfc_trans_omp_clauses (&iblock, &clausesa[GFC_OMP_SPLIT_PARALLEL], code->loc); stmt = gfc_trans_omp_code (code->block->next, true); stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt, @@ -5427,6 +5643,7 @@ gfc_trans_omp_target (gfc_code *code) omp_clauses); if (code->op != EXEC_OMP_TARGET) OMP_TARGET_COMBINED (stmt) = 1; + cfun->has_omp_target = true; } gfc_add_expr_to_block (&block, stmt); return gfc_finish_block (&block); @@ -5705,7 +5922,7 @@ gfc_trans_oacc_declare (gfc_code *code) gfc_start_block (&block); oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.oacc_declare->clauses, - code->loc); + code->loc, false, true); stmt = gfc_trans_omp_code (code->block->next, true); stmt = build2_loc (input_location, construct_code, void_type_node, stmt, oacc_clauses); diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 4e9b5ad..54b56c4 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -1228,6 +1228,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type) if (code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && code->expr1->rank == 0) { + tree images2 = fold_convert (integer_type_node, images); tree cond; if (flag_coarray != GFC_FCOARRAY_LIB) cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, @@ -1239,7 +1240,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type) 2, integer_zero_node, build_int_cst (integer_type_node, -1)); cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, - images, tmp); + images2, tmp); cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, images, build_int_cst (TREE_TYPE (images), 1)); @@ -1248,8 +1249,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type) } gfc_trans_runtime_check (true, false, cond, &se.pre, &code->expr1->where, "Invalid image number " - "%d in SYNC IMAGES", - fold_convert (integer_type_node, images)); + "%d in SYNC IMAGES", images2); } /* Per F2008, 8.5.1, a SYNC MEMORY is implied by calling the diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index b7712dc..9984481 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -2836,9 +2836,10 @@ copy_derived_types: && (c->attr.allocatable || c->attr.pointer) && !derived->attr.is_class) { - char caf_name[GFC_MAX_SYMBOL_LEN]; + /* Provide sufficient space to hold "_caf_symbol". */ + char caf_name[GFC_MAX_SYMBOL_LEN + 6]; gfc_component *token; - snprintf (caf_name, GFC_MAX_SYMBOL_LEN, "_caf_%s", c->name); + snprintf (caf_name, sizeof (caf_name), "_caf_%s", c->name); token = gfc_find_component (derived, caf_name, true, true, NULL); gcc_assert (token); c->caf_token = token->backend_decl; diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 69171f3..e126fe9 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -561,7 +561,7 @@ void gfc_trans_common (gfc_namespace *); void gfc_conv_structure (gfc_se *, gfc_expr *, int); /* Return an expression which determines if a dummy parameter is present. */ -tree gfc_conv_expr_present (gfc_symbol *); +tree gfc_conv_expr_present (gfc_symbol *, bool use_saved_decl = false); /* Convert a missing, dummy argument into a null or zero. */ void gfc_conv_missing_dummy (gfc_se *, gfc_expr *, gfc_typespec, int); @@ -803,6 +803,7 @@ tree gfc_omp_check_optional_argument (tree, bool); tree gfc_omp_array_data (tree, bool); bool gfc_omp_privatize_by_reference (const_tree); enum omp_clause_default_kind gfc_omp_predetermined_sharing (tree); +enum omp_clause_defaultmap_kind gfc_omp_predetermined_mapping (tree); tree gfc_omp_report_decl (tree); tree gfc_omp_clause_default_ctor (tree, tree, tree); tree gfc_omp_clause_copy_ctor (tree, tree, tree); |