diff options
| author | Philip Herron <philip.herron@embecosm.com> | 2022-08-23 14:29:23 +0100 |
|---|---|---|
| committer | Philip Herron <philip.herron@embecosm.com> | 2022-08-23 14:31:03 +0100 |
| commit | 57f0c9d6464c95807e836844f3013ed67948a16e (patch) | |
| tree | 2a6b2ddf4fb364ebbc3699bcede6f40466f80aaa /gcc/fortran | |
| parent | 8d1a6deb4e69e7dc162e741377674cf03459bcd9 (diff) | |
| parent | baa3ffb19c54fa334ac2884f6acb5d31aa79ac32 (diff) | |
| download | gcc-57f0c9d6464c95807e836844f3013ed67948a16e.zip gcc-57f0c9d6464c95807e836844f3013ed67948a16e.tar.gz gcc-57f0c9d6464c95807e836844f3013ed67948a16e.tar.bz2 | |
Merge remote-tracking branch 'gcc/master' into phil/gcc-upstream-merge
This merges GCC as of baa3ffb19c54fa334ac2884f6acb5d31aa79ac32 into gccrs
Diffstat (limited to 'gcc/fortran')
42 files changed, 2503 insertions, 607 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 0e8d6d8..1352a54 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,804 @@ +2022-08-22 Harald Anlauf <anlauf@gmx.de> + + PR fortran/106557 + * simplify.cc (gfc_simplify_ibclr): Ensure consistent results of + the simplification by dropping a redundant memory representation + of argument x. + (gfc_simplify_ibset): Likewise. + +2022-08-20 Jakub Jelinek <jakub@redhat.com> + + PR fortran/46539 + * lang.opt (static-libgfortran, static-libquadmath): Change Fortran + to Driver. + * options.cc (gfc_handle_option): Don't handle OPT_static_libgfortran + nor OPT_static_libquadmath here. + +2022-08-18 Harald Anlauf <anlauf@gmx.de> + + Revert: + 2022-07-31 Harald Anlauf <anlauf@gmx.de> + + PR fortran/77652 + * check.cc (gfc_check_associated): Make the rank check of POINTER + vs. TARGET match the allowed forms of pointer assignment for the + selected Fortran standard. + +2022-08-17 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + Jakub Jelinek <jakub@redhat.com> + + PR fortran/46539 + * lang.opt (static-libquadmath): New option. + * invoke.texi (-static-libquadmath): Document it. + * options.cc (gfc_handle_option): Error out if -static-libquadmath + is passed but we do not support it. + +2022-08-17 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/106566 + * openmp.cc (gfc_match_omp_clauses): Fix setting linear-step value + to 1 when not specified. + (gfc_match_omp_declare_simd): Accept module procedures. + +2022-08-16 Martin Liska <mliska@suse.cz> + + * gfortran.texi: Fix link destination to a valid URL. + +2022-07-31 Harald Anlauf <anlauf@gmx.de> + Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/92805 + * match.cc (gfc_match_small_literal_int): Make gobbling of leading + whitespace optional. + (gfc_match_name): Likewise. + (gfc_match_char): Likewise. + * match.h (gfc_match_small_literal_int): Adjust prototype. + (gfc_match_name): Likewise. + (gfc_match_char): Likewise. + * primary.cc (match_kind_param): Match small literal int or name + without gobbling whitespace. + (get_kind): Do not skip over blanks. + (match_string_constant): Likewise. + +2022-07-31 Harald Anlauf <anlauf@gmx.de> + + PR fortran/77652 + * check.cc (gfc_check_associated): Make the rank check of POINTER + vs. TARGET match the allowed forms of pointer assignment for the + selected Fortran standard. + +2022-07-29 Tobias Burnus <tobias@codesourcery.com> + + * openmp.cc (resolve_omp_clauses): Permit assumed-size arrays + in uniform clause. + +2022-07-26 Harald Anlauf <anlauf@gmx.de> + + PR fortran/103504 + * interface.cc (get_sym_storage_size): Array bounds and character + length can only be of integer type. + +2022-07-21 Martin Liska <mliska@suse.cz> + + * intrinsic.texi: Remove trailing dots for 2 Fortran fns. + +2022-07-20 Harald Anlauf <anlauf@gmx.de> + + PR fortran/101330 + * openmp.cc (gfc_match_iterator): Remove left-over code from + development that could lead to a crash on invalid input. + +2022-07-19 Harald Anlauf <anlauf@gmx.de> + + PR fortran/103590 + * resolve.cc (find_array_spec): Change function result to bool to + enable error recovery. Generate error message for invalid array + reference of non-array entity instead of an internal error. + (gfc_resolve_ref): Use function result from find_array_spec for + error recovery. + +2022-07-15 Steve Kargl <kargl@gcc.gnu.org> + + PR fortran/104313 + * trans-decl.cc (gfc_generate_return): Do not generate conflicting + fake results for functions with no result variable under -ff2c. + +2022-07-14 Harald Anlauf <anlauf@gmx.de> + Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/106209 + * decl.cc (add_init_expr_to_sym): Handle bad initializers for + implied-shape arrays. + +2022-07-12 Harald Anlauf <anlauf@gmx.de> + + PR fortran/106049 + * simplify.cc (is_constant_array_expr): A non-zero-sized constant + array shall have a non-empty constructor. When the constructor is + empty or missing, treat as non-constant. + +2022-07-04 Tobias Burnus <tobias@codesourcery.com> + Jakub Jelinek <jakub@redhat.com> + + * gfortran.h (gfc_omp_namelist): Update by creating 'linear' struct, + move 'linear_op' as 'op' to id and add 'old_modifier' to it. + * dump-parse-tree.cc (show_omp_namelist): Update accordingly. + * module.cc (mio_omp_declare_simd): Likewise. + * trans-openmp.cc (gfc_trans_omp_clauses): Likewise. + * openmp.cc (resolve_omp_clauses): Likewise; accept new-style + 'val' modifier with do/simd. + (gfc_match_omp_clauses): Handle OpenMP 5.2 linear clause syntax. + +2022-07-04 Tobias Burnus <tobias@codesourcery.com> + Chung-Lin Tang <cltang@codesourcery.com> + Thomas Schwinge <thomas@codesourcery.com> + + * openmp.cc (gfc_match_omp_requires): Remove sorry. + * parse.cc (decode_omp_directive): Don't regard 'declare target' + as target usage for 'omp requires'; add more flags to + omp_requires_mask. + +2022-07-01 Tobias Burnus <tobias@codesourcery.com> + + * dump-parse-tree.cc (show_omp_namelist): For the map-type, + also handle the always modifer and release/delete. + * openmp.cc (resolve_omp_clauses): Accept tofrom + map-type modifier for target enter/exit data, + but use 'to' / 'from' internally. + +2022-06-30 Harald Anlauf <anlauf@gmx.de> + Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/103137 + PR fortran/103138 + PR fortran/103693 + PR fortran/105243 + * decl.cc (gfc_match_data_decl): Reject CLASS entity declaration + when it is given the PARAMETER attribute. + +2022-06-29 Harald Anlauf <anlauf@gmx.de> + Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/106121 + * simplify.cc (gfc_simplify_extends_type_of): Do not attempt to + simplify when one of the arguments is a CLASS variable that was + not properly declared. + +2022-06-28 Jakub Jelinek <jakub@redhat.com> + + * gfortran.h (gfc_real_info): Add use_iec_60559 bitfield. + * trans-types.h (gfc_real16_use_iec_60559): Declare. + * trans-types.cc (gfc_real16_use_iec_60559): Define. + (gfc_init_kinds): When building powerpc64le-linux libgfortran + on glibc 2.26 to 2.31, set gfc_real16_use_iec_60559 and + use_iec_60559. + (gfc_build_real_type): Set gfc_real16_use_iec_60559 and use_iec_60559 + on glibc 2.26 or later. + * trans-intrinsic.cc (gfc_build_intrinsic_lib_fndecls): Adjust + comment. Handle gfc_real16_use_iec_60559. + (gfc_get_intrinsic_lib_fndecl): Handle use_iec_60559. + +2022-06-26 Harald Anlauf <anlauf@gmx.de> + + PR fortran/105691 + * simplify.cc (gfc_simplify_index): Replace old simplification + code by the equivalent of the runtime library implementation. Use + HOST_WIDE_INT instead of int for string index, length variables. + +2022-06-26 Harald Anlauf <anlauf@gmx.de> + + PR fortran/105954 + * decl.cc (variable_decl): Adjust upper bounds for explicit-shape + specs with constant bound expressions to ensure non-negative + extents. + +2022-06-24 Harald Anlauf <anlauf@gmx.de> + + PR fortran/105813 + * check.cc (gfc_check_unpack): Try to simplify MASK argument to + UNPACK so that checking of the VECTOR argument can work when MASK + is a variable. + +2022-06-18 Harald Anlauf <anlauf@gmx.de> + + PR fortran/105986 + * simplify.cc (gfc_simplify_btest): Add check for POS argument. + (gfc_simplify_ibclr): Add check for POS argument. + (gfc_simplify_ibits): Add check for POS and LEN arguments. + (gfc_simplify_ibset): Add check for POS argument. + +2022-06-08 Tobias Burnus <tobias@codesourcery.com> + + * openmp.cc (gfc_match_omp_clauses): Check also parent namespace + for 'requires reverse_offload'. + +2022-06-07 Jakub Jelinek <jakub@redhat.com> + + * trans-openmp.cc (gfc_trans_omp_clauses): Set + OMP_CLAUSE_LINEAR_OLD_LINEAR_MODIFIER on OMP_CLAUSE_LINEAR + clauses unconditionally for now. + +2022-06-03 Tobias Burnus <tobias@codesourcery.com> + + * openmp.cc (OMP_SCOPE_CLAUSES): Add firstprivate and allocate. + +2022-06-02 David Malcolm <dmalcolm@redhat.com> + + * f95-lang.cc (gfc_get_sarif_source_language): New. + (LANG_HOOKS_GET_SARIF_SOURCE_LANGUAGE): Redefine. + +2022-05-31 Jason Merrill <jason@redhat.com> + + * Make-lang.in (fortran.tags): Look at *.cc. + +2022-05-30 Harald Anlauf <anlauf@gmx.de> + + PR fortran/91300 + * libgfortran.h: Define new error code LIBERROR_NO_MEMORY. + * trans-stmt.cc (gfc_trans_allocate): Generate code for setting + ERRMSG depending on result of STAT result of ALLOCATE. + * trans.cc (gfc_allocate_using_malloc): Use STAT value of + LIBERROR_NO_MEMORY in case of failed malloc. + +2022-05-28 Tobias Burnus <tobias@codesourcery.com> + + * dump-parse-tree.cc (show_omp_clauses): Handle OMP_LIST_ENTER. + * gfortran.h: Add OMP_LIST_ENTER. + * openmp.cc (enum omp_mask2, OMP_DECLARE_TARGET_CLAUSES): Add + OMP_CLAUSE_ENTER. + (gfc_match_omp_clauses, gfc_match_omp_declare_target, + resolve_omp_clauses): Handle 'enter' clause. + +2022-05-27 Tobias Burnus <tobias@codesourcery.com> + Chung-Lin Tang <cltang@codesourcery.com> + + * openmp.cc (gfc_check_omp_requires): Fix clause name in error. + +2022-05-24 Tobias Burnus <tobias@codesourcery.com> + + PR c/105378 + * openmp.cc (gfc_match_omp_taskwait): Accept nowait. + +2022-05-23 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/104949 + * f95-lang.cc (LANG_HOOKS_OMP_ARRAY_SIZE): Redefine. + * trans-openmp.cc (gfc_omp_array_size): New. + (gfc_trans_omp_variable_list): Never turn has_device_addr + to firstprivate. + * trans.h (gfc_omp_array_size): New. + +2022-05-18 Tobias Burnus <tobias@codesourcery.com> + + * gfortran.h (enum gfc_omp_depend_op): Add OMP_DEPEND_INOUTSET. + (gfc_omp_clauses): Enlarge ENUM_BITFIELD. + * dump-parse-tree.cc (show_omp_namelist, show_omp_clauses): Handle + 'inoutset' depend modifier. + * openmp.cc (gfc_match_omp_clauses, gfc_match_omp_depobj): Likewise. + * trans-openmp.cc (gfc_trans_omp_clauses, gfc_trans_omp_depobj): + Likewise. + +2022-05-17 Tobias Burnus <tobias@codesourcery.com> + + * dump-parse-tree.cc (show_omp_namelist): Handle omp_all_memory. + * openmp.cc (gfc_match_omp_variable_list, gfc_match_omp_depend_sink, + gfc_match_omp_clauses, resolve_omp_clauses): Likewise. + * trans-openmp.cc (gfc_trans_omp_clauses, gfc_trans_omp_depobj): + Likewise. + * resolve.cc (resolve_symbol): Reject it as symbol. + +2022-05-16 Martin Liska <mliska@suse.cz> + + * frontend-passes.cc (gfc_code_walker): Use ARRAY_SIZE. + * openmp.cc (gfc_match_omp_context_selector_specification): Likewise. + * trans-intrinsic.cc (conv_intrinsic_ieee_builtin): Likewise. + * trans-types.cc (gfc_get_array_descr_info): Likewise. + +2022-05-13 Tobias Burnus <tobias@codesourcery.com> + + * trans-openmp.cc (gfc_trans_omp_clauses): When mapping nondescriptor + array sections, use GOMP_MAP_FIRSTPRIVATE_POINTER instead of + GOMP_MAP_POINTER for the pointer attachment. + +2022-05-11 Harald Anlauf <anlauf@gmx.de> + Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/105230 + * expr.cc (find_array_section): Correct logic to avoid NULL + pointer dereference on invalid array section. + +2022-05-10 Harald Anlauf <anlauf@gmx.de> + + PR fortran/105526 + * resolve.cc (check_team): New. + (gfc_resolve_code): Add checks for arguments to coarray intrinsics + FORM TEAM, CHANGE TEAM, and SYNC TEAM. + +2022-05-09 Harald Anlauf <anlauf@gmx.de> + + PR fortran/105501 + * match.cc (gfc_match_if): Adjust patterns used for matching. + (gfc_match_select_rank): Likewise. + * parse.cc (decode_statement): Likewise. + +2022-05-05 Sandra Loosemore <sandra@codesourcery.com> + + * gfortran.h (struct gfc_omp_clauses): Add non_rectangular bit. + * openmp.cc (is_outer_iteration_variable): New function. + (expr_is_invariant): New function. + (bound_expr_is_canonical): New function. + (resolve_omp_do): Replace existing non-rectangularity error with + check for canonical form and setting non_rectangular bit. + * trans-openmp.cc (gfc_trans_omp_do): Transfer non_rectangular + flag to generated tree structure. + +2022-05-02 Sandra Loosemore <sandra@codesourcery.com> + + * trans-openmp.cc (gfc_trans_omp_critical): Set location on OMP + tree node. + (gfc_trans_omp_do): Likewise. + (gfc_trans_omp_masked): Likewise. + (gfc_trans_omp_do_simd): Likewise. + (gfc_trans_omp_scope): Likewise. + (gfc_trans_omp_taskgroup): Likewise. + (gfc_trans_omp_taskwait): Likewise. + (gfc_trans_omp_distribute): Likewise. + (gfc_trans_omp_taskloop): Likewise. + (gfc_trans_omp_master_masked_taskloop): Likewise. + +2022-04-29 Thomas Koenig <tkoenig@gcc.gnu.org> + + * gfortran.texi: Fix exchanged period and letter. + +2022-04-28 Thomas Koenig <tkoenig@gcc.gnu.org> + + * gfortran.texi: Mention r16_ieee and r16_ibm. + * invoke.texi: Likewise. + +2022-04-27 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/103662 + PR fortran/105379 + * array.cc (compare_bounds): Use bool as return type. + Support non-constant expressions. + (gfc_compare_array_spec): Update call to compare_bounds. + +2022-04-27 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/102043 + PR fortran/105381 + * trans-array.cc (non_negative_strides_array_p): Inline variable + orig_decl and merge nested if conditions. Add condition to not + recurse if the next argument is the same as the current. + +2022-04-25 Jakub Jelinek <jakub@redhat.com> + Thomas Schwinge <thomas@codesourcery.com> + + PR fortran/104717 + * trans-openmp.cc (gfc_trans_oacc_construct): Wrap construct body + in an extra BIND_EXPR. + +2022-04-24 Mikael Morin <mikael@gcc.gnu.org> + Jakub Jelinek <jakub@redhat.com> + + PR fortran/103662 + * interface.cc (gfc_compare_derived_types): Support comparing + unlimited polymorphic fake symbols. Recursively compare class + descriptor types and virtual table types. + * resolve.cc (resolve_fl_derived): Add type to the types list + on unlimited polymorphic short-circuit return. + +2022-04-22 Mikael Morin <mikael@gcc.gnu.org> + Richard Biener <rguenther@suse.de> + + PR fortran/102043 + * trans.h (gfc_build_array_ref): Add non_negative_offset + argument. + * trans.cc (gfc_build_array_ref): Ditto. Use pointer arithmetic + if non_negative_offset is false. + * trans-expr.cc (gfc_conv_substring): Set flag in the call to + gfc_build_array_ref. + * trans-array.cc (gfc_get_cfi_dim_item, + gfc_conv_descriptor_dimension): Same. + (build_array_ref): Decide on whether to set the flag and update + the call. + (gfc_conv_scalarized_array_ref): Same. New argument tmp_array. + (gfc_conv_tmp_array_ref): Update call to + gfc_conv_scalarized_ref. + (non_negative_strides_array_p): New function. + +2022-04-22 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/102043 + * trans-array.cc (gfc_conv_expr_descriptor): Use + gfc_conv_tmp_array_ref. + +2022-04-22 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/102043 + * trans-io.cc: Add handling for the case where the array + is referenced using pointer arithmetic. + +2022-04-22 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/102043 + * trans-expr.cc: Pre-evaluate src and dest to variables + before using them. + +2022-04-21 Fritz Reese <foreese@gcc.gnu.org> + + PR fortran/105310 + * trans-expr.cc (gfc_conv_union_initializer): Pass vec* by reference. + +2022-04-13 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/105242 + * match.cc (match_exit_cycle): Handle missing OMP LOOP, DO and SIMD + directives in the EXIT/CYCLE diagnostic. + +2022-04-10 Harald Anlauf <anlauf@gmx.de> + + PR fortran/105184 + * array.cc (match_subscript): Reject assumed size coarray + specification with missing lower bound. + * resolve.cc (resolve_allocate_expr): Fix logic for checking + allocate-coshape-spec in ALLOCATE statement. + +2022-04-05 Sandra Loosemore <sandra@codesourcery.com> + + * trans-openmp.cc (gfc_split_omp_clauses): Fix mask for + EXEC_OMP_MASKED_TASKLOOP. + +2022-04-05 Harald Anlauf <anlauf@gmx.de> + + PR fortran/104210 + * arith.cc (eval_intrinsic): Avoid NULL pointer dereference. + (gfc_zero_size_array): Likewise. + +2022-04-05 Harald Anlauf <anlauf@gmx.de> + Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/105138 + * intrinsic.cc (gfc_is_intrinsic): When a symbol refers to a + RECURSIVE procedure, it cannot be an INTRINSIC. + +2022-03-30 Harald Anlauf <anlauf@gmx.de> + + PR fortran/100892 + * check.cc (gfc_check_associated): Avoid NULL pointer dereference. + +2022-03-29 Harald Anlauf <anlauf@gmx.de> + Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/104571 + * resolve.cc (resolve_elemental_actual): Avoid NULL pointer + dereference. + +2022-03-29 Harald Anlauf <anlauf@gmx.de> + + PR fortran/50549 + * resolve.cc (resolve_structure_cons): Reject pointer assignments + of character with different lengths in structure constructor. + +2022-03-25 Jakub Jelinek <jakub@redhat.com> + + PR fortran/103691 + * trans-array.cc (gfc_conv_array_initializer): If TYPE_MAX_VALUE is + smaller than TYPE_MIN_VALUE (i.e. empty array), ignore the + initializer; if TYPE_MIN_VALUE is equal to TYPE_MAX_VALUE, use just + the TYPE_MIN_VALUE as index instead of RANGE_EXPR. + +2022-03-23 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/103560 + * scanner.cc (add_path_to_list): Don't append '/' to the + save include path. + (open_included_file): Use '/' in concatenating path + file name. + * module.cc (gzopen_included_file_1): Likewise. + +2022-03-22 Harald Anlauf <anlauf@gmx.de> + + PR fortran/104999 + * simplify.cc (gfc_simplify_cshift): Ensure temporary holding + source array stride is initialized. + +2022-03-19 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/104228 + PR fortran/104570 + * parse.cc (parse_associate): Use a new distinct gfc_charlen if the + copied type has one whose length is not known to be constant. + * resolve.cc (resolve_assoc_var): Reset charlen if it’s shared with + the associate target regardless of the expression type. + Don’t reinitialize charlen if it’s deferred. + +2022-03-18 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/103039 + * trans-openmp.cc (gfc_omp_clause_copy_ctor, gfc_omp_clause_dtor): + Only privatize pointer for associate names. + +2022-03-18 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/103039 + * openmp.cc (resolve_omp_clauses): Improve associate-name diagnostic + for select type/rank. + +2022-03-11 Tobias Burnus <tobias@codesourcery.com> + + * trans-openmp.cc (gfc_trans_omp_clauses, gfc_omp_finish_clause): + Obtain size for mapping only if allocatable array is allocated. + +2022-03-09 Harald Anlauf <anlauf@gmx.de> + + PR fortran/104849 + * expr.cc (find_array_section): Avoid NULL pointer dereference on + invalid array section. + +2022-03-09 Tobias Burnus <tobias@codesourcery.com> + + * trans-intrinsic.cc (gfc_conv_intrinsic_sizeof): Fix CLASS handling. + +2022-03-08 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/104126 + * trans-expr.cc (gfc_conv_gfc_desc_to_cfi_desc): Handle NULL + without MOLD. + +2022-03-08 Harald Anlauf <anlauf@gmx.de> + + PR fortran/104811 + * frontend-passes.cc (optimize_minmaxloc): Do not attempt + frontend-optimization of MINLOC/MAXLOC for character arrays, as + there is no suitable code yet for inline expansion. + +2022-03-07 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/99585 + PR fortran/104430 + * trans-expr.cc (conv_parent_component_references): Fix comment; + simplify comparison. + (gfc_maybe_dereference_var): Avoid d referencing a nonpointer. + +2022-03-07 Tobias Burnus <tobias@codesourcery.com> + + * array.cc (gfc_ref_dimen_size): Fix comment typo. + * dump-parse-tree.cc (gfc_dump_c_prototypes): Likewise. + * frontend-passes.cc (cfe_code): Likewise. + * gfortran.texi: Likewise. + * resolve.cc (generate_component_assignments): Likewise. + * simplify.cc (gfc_simplify_this_image): Likewise. + * trans-expr.cc (trans_scalar_class_assign, + gfc_maybe_dereference_var): Likewise. + * intrinsic.texi: Remove word duplication. + * invoke.texi: Likewise. + +2022-03-07 Jakub Jelinek <jakub@redhat.com> + + * trans-expr.cc: Fix up duplicated word issue in a comment. + * gfortran.h: Likewise. + * scanner.cc: Likewise. + +2022-03-07 Martin Liska <mliska@suse.cz> + + * intrinsic.cc (gfc_is_intrinsic): Remove asterisk from error + message. + +2022-03-07 Martin Liska <mliska@suse.cz> + + PR translation/90148 + * intrinsic.cc (gfc_is_intrinsic): Put + quote to a proper place. + +2022-03-03 Kwok Cheung Yeung <kcy@codesourcery.com> + + PR fortran/104131 + * openmp.cc (gfc_match_omp_detach): Move check for type of event + handle to... + (resolve_omp_clauses) ...here. Also check that the event handle is + not an array, or an array access or structure element access. + +2022-03-02 Harald Anlauf <anlauf@gmx.de> + + PR fortran/104573 + * resolve.cc (resolve_structure_cons): Avoid NULL pointer + dereference when there is no valid component. + +2022-02-24 Harald Anlauf <anlauf@gmx.de> + + PR fortran/84519 + * dump-parse-tree.cc (show_code_node): Dump QUIET specifier when + present. + * match.cc (gfc_match_stopcode): Implement parsing of F2018 QUIET + specifier. F2018 stopcodes may have non-default integer kind. + * resolve.cc (gfc_resolve_code): Add checks for QUIET argument. + * trans-stmt.cc (gfc_trans_stop): Pass QUIET specifier to call of + library function. + +2022-02-22 Harald Anlauf <anlauf@gmx.de> + + PR fortran/104619 + * resolve.cc (resolve_structure_cons): Skip shape check if shape + of constructor cannot be determined at compile time. + +2022-02-20 Harald Anlauf <anlauf@gmx.de> + + PR fortran/77693 + * data.cc (gfc_assign_data_value): If a variable in a data + statement has the POINTER attribute, check for allowed initial + data target that is compatible with pointer assignment. + * gfortran.h (IS_POINTER): New macro. + +2022-02-15 Tobias Burnus <tobias@codesourcery.com> + + * trans-openmp.cc (gfc_trans_omp_depobj): Fix to alloc/ptr dummy + and for c_ptr. + +2022-02-15 Tobias Burnus <tobias@codesourcery.com> + + * trans-openmp.cc (gfc_trans_omp_clauses, gfc_trans_omp_depobj): + Depend on the proper addr, for ptr/alloc depend on pointee. + +2022-02-14 Harald Anlauf <anlauf@gmx.de> + + PR fortran/104211 + * expr.cc (find_array_section): Replace assertion by error + recovery when encountering bad array constructor. + +2022-02-13 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/104228 + * resolve.cc (resolve_assoc_var): Also create a new character + length for non-dummy associate targets. + * trans-stmt.cc (trans_associate_var): Initialize character length + even if no temporary is used for the associate variable. + +2022-02-10 Roger Sayle <roger@nextmovesoftware.com> + Tobias Burnus <tobias@codesourcery.com> + + * trans-common.cc (GFC_EQUIV_FMT): New macro respecting the + target's NO_DOT_IN_LABEL and NO_DOLLAR_IN_LABEL preferences. + (build_equiv_decl): Use GFC_EQUIV_FMT here. + +2022-02-10 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/104329 + * openmp.cc (resolve_omp_atomic): Defer extra-code assert after + other diagnostics. + +2022-02-10 Marcel Vollweiler <marcel@codesourcery.com> + + * dump-parse-tree.cc (show_omp_clauses): Added OMP_LIST_HAS_DEVICE_ADDR + case. + * gfortran.h: Added OMP_LIST_HAS_DEVICE_ADDR. + * openmp.cc (enum omp_mask2): Added OMP_CLAUSE_HAS_DEVICE_ADDR. + (gfc_match_omp_clauses): Parse HAS_DEVICE_ADDR clause. + (resolve_omp_clauses): Same. + * trans-openmp.cc (gfc_trans_omp_variable_list): Added + OMP_LIST_HAS_DEVICE_ADDR case. + (gfc_trans_omp_clauses): Firstprivatize of array descriptors. + +2022-02-09 Harald Anlauf <anlauf@gmx.de> + + PR fortran/66193 + * arith.cc (reduce_binary_ac): When reducing binary expressions, + try simplification. Handle case of empty constructor. + (reduce_binary_ca): Likewise. + +2022-02-03 Harald Anlauf <anlauf@gmx.de> + + PR fortran/104311 + * check.cc (gfc_calculate_transfer_sizes): Checks for case when + storage size of SOURCE is greater than zero while the storage size + of MOLD is zero and MOLD is an array shall not depend on SIZE. + +2022-02-03 Jakub Jelinek <jakub@redhat.com> + + PR fortran/104328 + * openmp.cc (is_scalar_intrinsic_expr): If must_be_var && conv_ok + and expr is conversion, verify it is a conversion from EXPR_VARIABLE + with non-NULL symtree. Check ->block->next before dereferencing it. + +2022-02-01 Harald Anlauf <anlauf@gmx.de> + + PR fortran/104331 + * simplify.cc (gfc_simplify_eoshift): Avoid NULL pointer + dereference when shape is not set. + +2022-01-28 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/103790 + * trans-array.cc (structure_alloc_comps): Prevent descriptor + stacking for non-array data; do not broadcast caf-tokens. + * trans-intrinsic.cc (conv_co_collective): Prevent generation + of unused descriptor. + +2022-01-28 Andre Vehreschild <vehre@gcc.gnu.org> + + Revert: + 2022-01-28 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/103790 + * trans-array.cc (structure_alloc_comps): Prevent descriptor + stacking for non-array data; do not broadcast caf-tokens. + * trans-intrinsic.cc (conv_co_collective): Prevent generation + of unused descriptor. + +2022-01-28 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/103790 + * trans-array.cc (structure_alloc_comps): Prevent descriptor + stacking for non-array data; do not broadcast caf-tokens. + * trans-intrinsic.cc (conv_co_collective): Prevent generation + of unused descriptor. + +2022-01-27 Harald Anlauf <anlauf@gmx.de> + + PR fortran/104128 + * expr.cc (gfc_copy_expr): Convert internal representation of + string to wide char in value only for default character kind. + * target-memory.cc (interpret_array): Pass flag for conversion of + wide chars. + (gfc_target_interpret_expr): Likewise. + +2022-01-27 Harald Anlauf <anlauf@gmx.de> + + PR fortran/84784 + * trans-intrinsic.cc (conv_intrinsic_image_status): Convert result + to resulting (default) integer type. + (conv_intrinsic_team_number): Likewise. + (gfc_conv_intrinsic_popcnt_poppar): Likewise. + +2022-01-25 Harald Anlauf <anlauf@gmx.de> + + PR fortran/104227 + * check.cc (gfc_calculate_transfer_sizes): Fix checking of arrays + passed as MOLD argument to the TRANSFER intrinsic for having + storage size zero. + +2022-01-25 Harald Anlauf <anlauf@gmx.de> + + PR fortran/104212 + * check.cc (gfc_check_norm2): Check that optional argument DIM is + scalar. + (gfc_check_parity): Likewise. + +2022-01-24 Jakub Jelinek <jakub@redhat.com> + + * lang.opt (fconvert=): Add EnumSet property and mention also + r16_ieee and r16_ibm arguments. + (big-endian, little-endian, native, swap): Add Set(1) property. + (r16_ieee, r16_ibm): New EnumValue entries with Set(2) property. + * trans-types.cc (gfc_init_kinds): Emit gfc_fatal_error for + -fconvert=r16_ieee or -fconvert=r16_ibm when R16_IEEE <=> R16_IBM + conversions aren't supported. + +2022-01-22 Harald Anlauf <anlauf@gmx.de> + + PR fortran/104127 + * simplify.cc (gfc_simplify_transfer): Ensure that the result + typespec is set up for TRANSFER with MOLD of type CHARACTER + including character length even if the result is a zero-sized + array. + +2022-01-20 Sandra Loosemore <sandra@codesourcery.com> + + PR fortran/103695 + PR fortran/102621 + * gfortran.h (struct gfc_namespace) Add omp_affinity_iterator + field. + * dump-parse-tree.cc (show_iterator): Use it. + * openmp.cc (gfc_match_iterator): Likewise. + (resolve_omp_clauses): Likewise. + * trans-decl.cc (gfc_finish_var_decl): Likewise. + * trans-openmp.cc (handle_iterator): Likewise. + +2022-01-18 Harald Anlauf <anlauf@gmx.de> + + PR fortran/103692 + * array.cc (gfc_expand_constructor): Handle zero-sized array + constructors. + 2022-01-17 Martin Liska <mliska@suse.cz> * check.cc (gfc_check_all_any): Rename .c names to .cc. diff --git a/gcc/fortran/Make-lang.in b/gcc/fortran/Make-lang.in index a558fc8..1cb47cb 100644 --- a/gcc/fortran/Make-lang.in +++ b/gcc/fortran/Make-lang.in @@ -113,7 +113,7 @@ fortran.srcinfo: doc/gfortran.info -cp -p $^ $(srcdir)/fortran fortran.tags: force - cd $(srcdir)/fortran; $(ETAGS) -o TAGS.sub *.c *.h; \ + cd $(srcdir)/fortran; $(ETAGS) -o TAGS.sub *.cc *.h; \ $(ETAGS) --include TAGS.sub --include ../TAGS.sub fortran.info: doc/gfortran.info doc/gfc-internals.info diff --git a/gcc/fortran/arith.cc b/gcc/fortran/arith.cc index b3323ecf..d57059a 100644 --- a/gcc/fortran/arith.cc +++ b/gcc/fortran/arith.cc @@ -1305,6 +1305,8 @@ reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), head = gfc_constructor_copy (op1->value.constructor); for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c)) { + gfc_simplify_expr (c->expr, 0); + if (c->expr->expr_type == EXPR_CONSTANT) rc = eval (c->expr, op2, &r); else @@ -1321,9 +1323,19 @@ reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), else { gfc_constructor *c = gfc_constructor_first (head); - r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind, - &op1->where); - r->shape = gfc_copy_shape (op1->shape, op1->rank); + if (c) + { + r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind, + &op1->where); + r->shape = gfc_copy_shape (op1->shape, op1->rank); + } + else + { + gcc_assert (op1->ts.type != BT_UNKNOWN); + r = gfc_get_array_expr (op1->ts.type, op1->ts.kind, + &op1->where); + r->shape = gfc_get_shape (op1->rank); + } r->rank = op1->rank; r->value.constructor = head; *result = r; @@ -1345,6 +1357,8 @@ reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), head = gfc_constructor_copy (op2->value.constructor); for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c)) { + gfc_simplify_expr (c->expr, 0); + if (c->expr->expr_type == EXPR_CONSTANT) rc = eval (op1, c->expr, &r); else @@ -1361,9 +1375,19 @@ reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), else { gfc_constructor *c = gfc_constructor_first (head); - r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind, - &op2->where); - r->shape = gfc_copy_shape (op2->shape, op2->rank); + if (c) + { + r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind, + &op2->where); + r->shape = gfc_copy_shape (op2->shape, op2->rank); + } + else + { + gcc_assert (op2->ts.type != BT_UNKNOWN); + r = gfc_get_array_expr (op2->ts.type, op2->ts.kind, + &op2->where); + r->shape = gfc_get_shape (op2->rank); + } r->rank = op2->rank; r->value.constructor = head; *result = r; @@ -1465,6 +1489,9 @@ eval_intrinsic (gfc_intrinsic_op op, int unary; arith rc; + if (!op1) + return NULL; + gfc_clear_ts (&temp.ts); switch (op) @@ -1679,11 +1706,11 @@ eval_type_intrinsic0 (gfc_intrinsic_op iop, gfc_expr *op) /* Return nonzero if the expression is a zero size array. */ -static int +static bool gfc_zero_size_array (gfc_expr *e) { - if (e->expr_type != EXPR_ARRAY) - return 0; + if (e == NULL || e->expr_type != EXPR_ARRAY) + return false; return e->value.constructor == NULL; } diff --git a/gcc/fortran/array.cc b/gcc/fortran/array.cc index 4723043..bbdb5b3 100644 --- a/gcc/fortran/array.cc +++ b/gcc/fortran/array.cc @@ -134,6 +134,13 @@ end_element: if (m == MATCH_ERROR) return MATCH_ERROR; + if (star && ar->start[i] == NULL) + { + gfc_error ("Missing lower bound in assumed size " + "coarray specification at %C"); + return MATCH_ERROR; + } + /* See if we have an optional stride. */ if (gfc_match_char (':') == MATCH_YES) { @@ -950,23 +957,28 @@ gfc_copy_array_spec (gfc_array_spec *src) } -/* Returns nonzero if the two expressions are equal. Only handles integer - constants. */ +/* Returns nonzero if the two expressions are equal. + We should not need to support more than constant values, as that’s what is + allowed in derived type component array spec. However, we may create types + with non-constant array spec for dummy variable class container types, for + which the _data component holds the array spec of the variable declaration. + So we have to support non-constant bounds as well. */ -static int +static bool compare_bounds (gfc_expr *bound1, gfc_expr *bound2) { if (bound1 == NULL || bound2 == NULL - || bound1->expr_type != EXPR_CONSTANT - || bound2->expr_type != EXPR_CONSTANT || bound1->ts.type != BT_INTEGER || bound2->ts.type != BT_INTEGER) gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered"); - if (mpz_cmp (bound1->value.integer, bound2->value.integer) == 0) - return 1; - else - return 0; + /* What qualifies as identical bounds? We could probably just check that the + expressions are exact clones. We avoid rewriting a specific comparison + function and re-use instead the rather involved gfc_dep_compare_expr which + is just a bit more permissive, as it can also detect identical values for + some mismatching expressions (extra parenthesis, swapped operands, unary + plus, etc). It probably only makes a difference in corner cases. */ + return gfc_dep_compare_expr (bound1, bound2) == 0; } @@ -999,10 +1011,10 @@ gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2) if (as1->type == AS_EXPLICIT) for (i = 0; i < as1->rank + as1->corank; i++) { - if (compare_bounds (as1->lower[i], as2->lower[i]) == 0) + if (!compare_bounds (as1->lower[i], as2->lower[i])) return 0; - if (compare_bounds (as1->upper[i], as2->upper[i]) == 0) + if (!compare_bounds (as1->upper[i], as2->upper[i])) return 0; } @@ -1883,6 +1895,9 @@ gfc_expand_constructor (gfc_expr *e, bool fatal) gfc_expr *f; bool rc; + if (gfc_is_size_zero_array (e)) + return true; + /* If we can successfully get an array element at the max array size then the array is too big to expand, so we just return. */ f = gfc_get_array_element (e, flag_max_array_constructor); @@ -2417,7 +2432,7 @@ gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result, mpz_t *end) gfc_free_expr(stride_expr); } - /* Calculate the number of elements via gfc_dep_differce, but only if + /* Calculate the number of elements via gfc_dep_difference, but only if start and end are both supplied in the reference or the array spec. This is to guard against strange but valid code like diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc index 5fe8d45..91d87a1 100644 --- a/gcc/fortran/check.cc +++ b/gcc/fortran/check.cc @@ -1504,7 +1504,7 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target) argument of intrinsic inquiry functions. */ if (pointer->rank != -1 && !rank_check (target, 0, pointer->rank)) t = false; - if (target->rank > 0) + if (target->rank > 0 && target->ref) { for (i = 0; i < target->rank; i++) if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR) @@ -4338,6 +4338,9 @@ gfc_check_norm2 (gfc_expr *array, gfc_expr *dim) if (!array_check (array, 0)) return false; + if (!dim_check (dim, 1, false)) + return false; + if (!dim_rank_check (dim, array, false)) return false; @@ -4476,6 +4479,9 @@ gfc_check_parity (gfc_expr *mask, gfc_expr *dim) if (!array_check (mask, 0)) return false; + if (!dim_check (dim, 1, false)) + return false; + if (!dim_rank_check (dim, mask, false)) return false; @@ -6144,8 +6150,8 @@ gfc_calculate_transfer_sizes (gfc_expr *source, gfc_expr *mold, gfc_expr *size, * representation is not shorter than that of SOURCE. * If SIZE is present, the result is an array of rank one and size SIZE. */ - if (result_elt_size == 0 && *source_size > 0 && !size - && mold->expr_type == EXPR_ARRAY) + if (result_elt_size == 0 && *source_size > 0 + && (mold->expr_type == EXPR_ARRAY || mold->rank)) { gfc_error ("%<MOLD%> argument of %<TRANSFER%> intrinsic at %L is an " "array and shall not have storage size 0 when %<SOURCE%> " @@ -6347,6 +6353,8 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) if (!same_type_check (vector, 0, field, 2)) return false; + gfc_simplify_expr (mask, 0); + if (mask->expr_type == EXPR_ARRAY && gfc_array_size (vector, &vector_size)) { diff --git a/gcc/fortran/data.cc b/gcc/fortran/data.cc index f7c9143..7a5866f 100644 --- a/gcc/fortran/data.cc +++ b/gcc/fortran/data.cc @@ -618,6 +618,10 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index, gfc_convert_type (expr, &lvalue->ts, 0); } + if (IS_POINTER (symbol) + && !gfc_check_pointer_assign (lvalue, rvalue, false, true)) + return false; + if (last_con == NULL) symbol->value = expr; else diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc index bd586e7..b640051 100644 --- a/gcc/fortran/decl.cc +++ b/gcc/fortran/decl.cc @@ -2129,10 +2129,21 @@ add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) /* The shape may be NULL for EXPR_ARRAY, set it. */ if (init->shape == NULL) { - gcc_assert (init->expr_type == EXPR_ARRAY); + if (init->expr_type != EXPR_ARRAY) + { + gfc_error ("Bad shape of initializer at %L", &init->where); + return false; + } + init->shape = gfc_get_shape (1); if (!gfc_array_size (init, &init->shape[0])) - gfc_internal_error ("gfc_array_size failed"); + { + gfc_error ("Cannot determine shape of initializer at %L", + &init->where); + free (init->shape); + init->shape = NULL; + return false; + } } for (dim = 0; dim < sym->as->rank; ++dim) @@ -2775,6 +2786,18 @@ variable_decl (int elem) else gfc_free_expr (n); } + /* For an explicit-shape spec with constant bounds, ensure + that the effective upper bound is not lower than the + respective lower bound minus one. Otherwise adjust it so + that the extent is trivially derived to be zero. */ + if (as->lower[i]->expr_type == EXPR_CONSTANT + && as->upper[i]->expr_type == EXPR_CONSTANT + && as->lower[i]->ts.type == BT_INTEGER + && as->upper[i]->ts.type == BT_INTEGER + && mpz_cmp (as->upper[i]->value.integer, + as->lower[i]->value.integer) < 0) + mpz_sub_ui (as->upper[i]->value.integer, + as->lower[i]->value.integer, 1); } } } @@ -6250,6 +6273,14 @@ gfc_match_data_decl (void) goto cleanup; } + /* F2018:C708. */ + if (current_ts.type == BT_CLASS && current_attr.flavor == FL_PARAMETER) + { + gfc_error ("CLASS entity at %C cannot have the PARAMETER attribute"); + m = MATCH_ERROR; + goto cleanup; + } + if (current_ts.type == BT_CLASS && current_ts.u.derived->attr.unlimited_polymorphic) goto ok; diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc index a618ae2..5352008 100644 --- a/gcc/fortran/dump-parse-tree.cc +++ b/gcc/fortran/dump-parse-tree.cc @@ -1302,10 +1302,10 @@ show_code (int level, gfc_code *c) static void show_iterator (gfc_namespace *ns) { - for (gfc_symbol *sym = ns->proc_name; sym; sym = sym->tlink) + for (gfc_symbol *sym = ns->omp_affinity_iterators; sym; sym = sym->tlink) { gfc_constructor *c; - if (sym != ns->proc_name) + if (sym != ns->omp_affinity_iterators) fputc (',', dumpfile); fputs (sym->name, dumpfile); fputc ('=', dumpfile); @@ -1379,6 +1379,7 @@ show_omp_namelist (int list_type, gfc_omp_namelist *n) case OMP_DEPEND_IN: fputs ("in:", dumpfile); break; case OMP_DEPEND_OUT: fputs ("out:", dumpfile); break; case OMP_DEPEND_INOUT: fputs ("inout:", dumpfile); break; + case OMP_DEPEND_INOUTSET: fputs ("inoutset:", dumpfile); break; case OMP_DEPEND_DEPOBJ: fputs ("depobj:", dumpfile); break; case OMP_DEPEND_MUTEXINOUTSET: fputs ("mutexinoutset:", dumpfile); @@ -1413,18 +1414,23 @@ show_omp_namelist (int list_type, gfc_omp_namelist *n) case OMP_MAP_TO: fputs ("to:", dumpfile); break; case OMP_MAP_FROM: fputs ("from:", dumpfile); break; case OMP_MAP_TOFROM: fputs ("tofrom:", dumpfile); break; + case OMP_MAP_ALWAYS_TO: fputs ("always,to:", dumpfile); break; + case OMP_MAP_ALWAYS_FROM: fputs ("always,from:", dumpfile); break; + case OMP_MAP_ALWAYS_TOFROM: fputs ("always,tofrom:", dumpfile); break; + case OMP_MAP_DELETE: fputs ("delete:", dumpfile); break; + case OMP_MAP_RELEASE: fputs ("release:", dumpfile); break; default: break; } - else if (list_type == OMP_LIST_LINEAR) - switch (n->u.linear_op) + else if (list_type == OMP_LIST_LINEAR && n->u.linear.old_modifier) + switch (n->u.linear.op) { case OMP_LINEAR_REF: fputs ("ref(", dumpfile); break; case OMP_LINEAR_VAL: fputs ("val(", dumpfile); break; case OMP_LINEAR_UVAL: fputs ("uval(", dumpfile); break; default: break; } - fprintf (dumpfile, "%s", n->sym->name); - if (list_type == OMP_LIST_LINEAR && n->u.linear_op != OMP_LINEAR_DEFAULT) + fprintf (dumpfile, "%s", n->sym ? n->sym->name : "omp_all_memory"); + if (list_type == OMP_LIST_LINEAR && n->u.linear.op != OMP_LINEAR_DEFAULT) fputc (')', dumpfile); if (n->expr) { @@ -1678,11 +1684,13 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses) case OMP_LIST_IN_REDUCTION: type = "IN_REDUCTION"; break; case OMP_LIST_TASK_REDUCTION: type = "TASK_REDUCTION"; break; case OMP_LIST_DEVICE_RESIDENT: type = "DEVICE_RESIDENT"; break; + case OMP_LIST_ENTER: type = "ENTER"; break; case OMP_LIST_LINK: type = "LINK"; break; case OMP_LIST_USE_DEVICE: type = "USE_DEVICE"; break; case OMP_LIST_CACHE: type = "CACHE"; break; 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_HAS_DEVICE_ADDR: type = "HAS_DEVICE_ADDR"; break; case OMP_LIST_USE_DEVICE_ADDR: type = "USE_DEVICE_ADDR"; break; case OMP_LIST_NONTEMPORAL: type = "NONTEMPORAL"; break; case OMP_LIST_ALLOCATE: type = "ALLOCATE"; break; @@ -1897,6 +1905,7 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses) case OMP_DEPEND_IN: deptype = "IN"; break; case OMP_DEPEND_OUT: deptype = "OUT"; break; case OMP_DEPEND_INOUT: deptype = "INOUT"; break; + case OMP_DEPEND_INOUTSET: deptype = "INOUTSET"; break; case OMP_DEPEND_MUTEXINOUTSET: deptype = "MUTEXINOUTSET"; break; default: gcc_unreachable (); } @@ -2369,6 +2378,11 @@ show_code_node (int level, gfc_code *c) show_expr (c->expr1); else fprintf (dumpfile, "%d", c->ext.stop_code); + if (c->expr2 != NULL) + { + fputs (" QUIET=", dumpfile); + show_expr (c->expr2); + } break; @@ -3537,7 +3551,7 @@ gfc_dump_c_prototypes (gfc_namespace *ns, FILE *file) gfc_traverse_ns (ns, write_interop_decl); } -/* Loop over all global symbols, writing out their declrations. */ +/* Loop over all global symbols, writing out their declarations. */ void gfc_dump_external_c_prototypes (FILE * file) diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc index 279d9b3..be94c18 100644 --- a/gcc/fortran/expr.cc +++ b/gcc/fortran/expr.cc @@ -312,7 +312,8 @@ gfc_copy_expr (gfc_expr *p) break; case BT_CHARACTER: - if (p->representation.string) + if (p->representation.string + && p->ts.kind == gfc_default_character_kind) q->value.character.string = gfc_char_to_widechar (q->representation.string); else @@ -1593,7 +1594,9 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) { if ((begin && begin->expr_type != EXPR_CONSTANT) || (finish && finish->expr_type != EXPR_CONSTANT) - || (step && step->expr_type != EXPR_CONSTANT)) + || (step && step->expr_type != EXPR_CONSTANT) + || !lower + || !upper) { t = false; goto cleanup; @@ -1717,7 +1720,13 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) } cons = gfc_constructor_lookup (base, limit); - gcc_assert (cons); + if (cons == NULL) + { + gfc_error ("Error in array constructor referenced at %L", + &ref->u.ar.where); + t = false; + goto cleanup; + } gfc_constructor_append_expr (&expr->value.constructor, gfc_copy_expr (cons->expr), NULL); } diff --git a/gcc/fortran/f95-lang.cc b/gcc/fortran/f95-lang.cc index 1a895a2..319cf8f 100644 --- a/gcc/fortran/f95-lang.cc +++ b/gcc/fortran/f95-lang.cc @@ -100,6 +100,15 @@ static const struct attribute_spec gfc_attribute_table[] = { NULL, 0, 0, false, false, false, false, NULL, NULL } }; +/* Get a value for the SARIF v2.1.0 "artifact.sourceLanguage" property, + based on the list in SARIF v2.1.0 Appendix J. */ + +static const char * +gfc_get_sarif_source_language (const char *) +{ + return "fortran"; +} + #undef LANG_HOOKS_NAME #undef LANG_HOOKS_INIT #undef LANG_HOOKS_FINISH @@ -114,6 +123,7 @@ static const struct attribute_spec gfc_attribute_table[] = #undef LANG_HOOKS_TYPE_FOR_SIZE #undef LANG_HOOKS_INIT_TS #undef LANG_HOOKS_OMP_ARRAY_DATA +#undef LANG_HOOKS_OMP_ARRAY_SIZE #undef LANG_HOOKS_OMP_IS_ALLOCATABLE_OR_PTR #undef LANG_HOOKS_OMP_CHECK_OPTIONAL_ARGUMENT #undef LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE @@ -137,6 +147,7 @@ static const struct attribute_spec gfc_attribute_table[] = #undef LANG_HOOKS_BUILTIN_FUNCTION #undef LANG_HOOKS_GET_ARRAY_DESCR_INFO #undef LANG_HOOKS_ATTRIBUTE_TABLE +#undef LANG_HOOKS_GET_SARIF_SOURCE_LANGUAGE /* Define lang hooks. */ #define LANG_HOOKS_NAME "GNU Fortran" @@ -152,6 +163,7 @@ static const struct attribute_spec gfc_attribute_table[] = #define LANG_HOOKS_TYPE_FOR_SIZE gfc_type_for_size #define LANG_HOOKS_INIT_TS gfc_init_ts #define LANG_HOOKS_OMP_ARRAY_DATA gfc_omp_array_data +#define LANG_HOOKS_OMP_ARRAY_SIZE gfc_omp_array_size #define LANG_HOOKS_OMP_IS_ALLOCATABLE_OR_PTR gfc_omp_is_allocatable_or_ptr #define LANG_HOOKS_OMP_CHECK_OPTIONAL_ARGUMENT gfc_omp_check_optional_argument #define LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE gfc_omp_privatize_by_reference @@ -175,6 +187,7 @@ static const struct attribute_spec gfc_attribute_table[] = #define LANG_HOOKS_BUILTIN_FUNCTION gfc_builtin_function #define LANG_HOOKS_GET_ARRAY_DESCR_INFO gfc_get_array_descr_info #define LANG_HOOKS_ATTRIBUTE_TABLE gfc_attribute_table +#define LANG_HOOKS_GET_SARIF_SOURCE_LANGUAGE gfc_get_sarif_source_language struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER; diff --git a/gcc/fortran/frontend-passes.cc b/gcc/fortran/frontend-passes.cc index 22f1bb5..612c12d 100644 --- a/gcc/fortran/frontend-passes.cc +++ b/gcc/fortran/frontend-passes.cc @@ -974,7 +974,7 @@ cfe_code (gfc_code **c, int *walk_subtrees, void *data ATTRIBUTE_UNUSED) changed_statement = NULL; /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs - and allocation on assigment are prohibited inside WHERE, and finally + and allocation on assignment are prohibited inside WHERE, and finally masking an expression would lead to wrong-code when replacing WHERE (a>0) @@ -2276,6 +2276,7 @@ optimize_minmaxloc (gfc_expr **e) if (fn->rank != 1 || fn->value.function.actual == NULL || fn->value.function.actual->expr == NULL + || fn->value.function.actual->expr->ts.type == BT_CHARACTER || fn->value.function.actual->expr->rank != 1) return; @@ -5653,9 +5654,7 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn, WALK_SUBEXPR (co->ext.omp_clauses->detach); for (idx = 0; idx < OMP_IF_LAST; idx++) WALK_SUBEXPR (co->ext.omp_clauses->if_exprs[idx]); - for (idx = 0; - idx < sizeof (list_types) / sizeof (list_types[0]); - idx++) + for (idx = 0; idx < ARRAY_SIZE (list_types); idx++) for (n = co->ext.omp_clauses->lists[list_types[idx]]; n; n = n->next) WALK_SUBEXPR (n->expr); diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 00a558a..696aadd 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1271,6 +1271,7 @@ enum gfc_omp_depend_op OMP_DEPEND_IN, OMP_DEPEND_OUT, OMP_DEPEND_INOUT, + OMP_DEPEND_INOUTSET, OMP_DEPEND_MUTEXINOUTSET, OMP_DEPEND_DEPOBJ, OMP_DEPEND_SINK_FIRST, @@ -1344,7 +1345,11 @@ typedef struct gfc_omp_namelist gfc_omp_reduction_op reduction_op; gfc_omp_depend_op depend_op; gfc_omp_map_op map_op; - gfc_omp_linear_op linear_op; + struct + { + ENUM_BITFIELD (gfc_omp_linear_op) op:4; + bool old_modifier; + } linear; struct gfc_common_head *common; bool lastprivate_conditional; } u; @@ -1393,7 +1398,9 @@ enum OMP_LIST_USE_DEVICE_ADDR, OMP_LIST_NONTEMPORAL, OMP_LIST_ALLOCATE, - OMP_LIST_NUM + OMP_LIST_HAS_DEVICE_ADDR, + OMP_LIST_ENTER, + OMP_LIST_NUM /* Must be the last. */ }; /* Because a symbol can belong to multiple namelists, they must be @@ -1532,13 +1539,14 @@ typedef struct gfc_omp_clauses unsigned simd:1, threads:1, depend_source:1, destroy:1, order_concurrent:1; unsigned order_unconstrained:1, order_reproducible:1, capture:1; unsigned grainsize_strict:1, num_tasks_strict:1, compare:1, weak:1; + unsigned non_rectangular:1; ENUM_BITFIELD (gfc_omp_sched_kind) sched_kind:3; ENUM_BITFIELD (gfc_omp_device_type) device_type:2; ENUM_BITFIELD (gfc_omp_memorder) memorder:3; ENUM_BITFIELD (gfc_omp_memorder) fail:3; ENUM_BITFIELD (gfc_omp_cancel_kind) cancel:3; ENUM_BITFIELD (gfc_omp_proc_bind_kind) proc_bind:3; - ENUM_BITFIELD (gfc_omp_depend_op) depobj_update:3; + ENUM_BITFIELD (gfc_omp_depend_op) depobj_update:4; ENUM_BITFIELD (gfc_omp_bind_type) bind:2; ENUM_BITFIELD (gfc_omp_at_type) at:2; ENUM_BITFIELD (gfc_omp_severity_type) severity:2; @@ -2107,6 +2115,9 @@ typedef struct gfc_namespace /* !$ACC ROUTINE clauses. */ gfc_omp_clauses *oacc_routine_clauses; + /* !$ACC TASK AFFINITY iterator symbols. */ + gfc_symbol *omp_affinity_iterators; + /* !$ACC ROUTINE names. */ gfc_oacc_routine_name *oacc_routine_names; @@ -2133,7 +2144,7 @@ typedef struct gfc_namespace /* Linked list of !$omp declare variant constructs. */ struct gfc_omp_declare_variant *omp_declare_variant; - /* A hash set for the the gfc expressions that have already + /* A hash set for the gfc expressions that have already been finalized in this namespace. */ gfc_was_finalized *was_finalized; @@ -2658,6 +2669,9 @@ typedef struct unsigned int c_double : 1; unsigned int c_long_double : 1; unsigned int c_float128 : 1; + /* True if for _Float128 C2X IEC 60559 *f128 APIs should be used + instead of libquadmath *q APIs. */ + unsigned int use_iec_60559 : 1; } gfc_real_info; @@ -3893,6 +3907,9 @@ bool gfc_is_finalizable (gfc_symbol *, gfc_expr **); && CLASS_DATA (sym) \ && CLASS_DATA (sym)->attr.dimension \ && !CLASS_DATA (sym)->attr.class_pointer) +#define IS_POINTER(sym) \ + (sym->ts.type == BT_CLASS && sym->attr.class_ok && CLASS_DATA (sym) \ + ? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer) /* frontend-passes.cc */ diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi index 2a55676..59d673b 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -246,7 +246,7 @@ including OpenMP and OpenACC support for parallel programming. The GNU Fortran compiler passes the @uref{http://www.fortran-2000.com/ArnaudRecipes/fcvs21_f95.html, NIST Fortran 77 Test Suite}, and produces acceptable results on the -@uref{https://www.netlib.org/lapack/faq.html#1.21, LAPACK Test Suite}. +@uref{https://www.netlib.org/lapack/faq.html, LAPACK Test Suite}. It also provides respectable performance on the @uref{https://polyhedron.com/?page_id=175, Polyhedron Fortran compiler benchmarks} and the @@ -441,7 +441,7 @@ found in the following sections of the documentation. Additionally, the GNU Fortran compilers supports the OpenMP specification (version 4.5 and partial support of the features of the 5.0 version, -@url{https://openmp.org/@/openmp-specifications/}). +@url{https://openmp.org/@/specifications/}). There also is support for the OpenACC specification (targeting version 2.6, @uref{https://www.openacc.org/}). See @uref{https://gcc.gnu.org/wiki/OpenACC} for more information. @@ -589,7 +589,7 @@ Malformed environment variables are silently ignored. * GFORTRAN_SHOW_LOCUS:: Show location for runtime errors * GFORTRAN_OPTIONAL_PLUS:: Print leading + where permitted * GFORTRAN_LIST_SEPARATOR:: Separator for list output -* GFORTRAN_CONVERT_UNIT:: Set endianness for unformatted I/O +* GFORTRAN_CONVERT_UNIT:: Set conversion for unformatted I/O * GFORTRAN_ERROR_BACKTRACE:: Show backtrace on run-time errors * GFORTRAN_FORMATTED_BUFFER_SIZE:: Buffer size for formatted files * GFORTRAN_UNFORMATTED_BUFFER_SIZE:: Buffer size for unformatted files @@ -686,11 +686,12 @@ when @command{a.out} is the compiled Fortran program that you want to run. Default is a single space. @node GFORTRAN_CONVERT_UNIT -@section @env{GFORTRAN_CONVERT_UNIT}---Set endianness for unformatted I/O +@section @env{GFORTRAN_CONVERT_UNIT}---Set conversion for unformatted I/O By setting the @env{GFORTRAN_CONVERT_UNIT} variable, it is possible to change the representation of data for unformatted files. -The syntax for the @env{GFORTRAN_CONVERT_UNIT} variable is: +The syntax for the @env{GFORTRAN_CONVERT_UNIT} variable for +most systems is: @smallexample GFORTRAN_CONVERT_UNIT: mode | mode ';' exception | exception ; mode: 'native' | 'swap' | 'big_endian' | 'little_endian' ; @@ -711,6 +712,14 @@ the modes are the same as for the @code{CONVERT} specifier: for unformatted files. @item @code{BIG_ENDIAN} Use the big-endian format for unformatted files. @end itemize +For POWER systems which support @option{-mabi=ieeelongdouble}, +there are additional options, which can be combined with the +others with commas. Those are +@itemize @w{} +@item @code{R16_IEEE} Use IEEE 128-bit format for @code{REAL(KIND=16)}. +@item @code{R16_IBM} Use IBM @code{long double} format for +@code{REAL(KIND=16)}. +@end itemize A missing mode for an exception is taken to mean @code{BIG_ENDIAN}. Examples of values for @env{GFORTRAN_CONVERT_UNIT} are: @itemize @w{} @@ -719,6 +728,8 @@ Examples of values for @env{GFORTRAN_CONVERT_UNIT} are: in little_endian mode, except for units 10 to 20 and 25, which are in native format. @item @code{'10-20'} Units 10 to 20 are big-endian, the rest is native. +@item @code{'big_endian,r16_ibm'} Do all unformatted I/O in big-endian +mode and use IBM long double for output of @code{REAL(KIND=16)} values. @end itemize Setting the environment variables should be done on the command @@ -1093,7 +1104,7 @@ variable. The maximum number of bytes of user data in a subrecord is 2147483639 (2 GiB - 9) for a four-byte record marker. This limit can be lowered -with the @option{-fmax-subrecord-length} option, altough this is +with the @option{-fmax-subrecord-length} option, although this is rarely useful. If the length of a logical record exceeds this limit, the data is distributed among several subrecords. @@ -1736,7 +1747,7 @@ the @code{CONVERT} specifier on the @code{OPEN} statement. @xref{GFORTRAN_CONVERT_UNIT}, for an alternative way of specifying the data format via an environment variable. -Valid values for @code{CONVERT} are: +Valid values for @code{CONVERT} on most systems are: @itemize @w{} @item @code{CONVERT='NATIVE'} Use the native format. This is the default. @item @code{CONVERT='SWAP'} Swap between little- and big-endian. @@ -1745,6 +1756,15 @@ for unformatted files. @item @code{CONVERT='BIG_ENDIAN'} Use the big-endian representation for unformatted files. @end itemize +On POWER systems which support @option{-mabi=ieeelongdouble}, +there are additional options, which can be combined with the others +with commas. Those are +@itemize @w{} +@item @code{CONVERT='R16_IEEE'} Use IEEE 128-bit format for +@code{REAL(KIND=16)}. +@item @code{CONVERT='R16_IBM'} Use IBM @code{long double} format for +real@code{REAL(KIND=16)}. +@end itemize Using the option could look like this: @smallexample @@ -1786,7 +1806,7 @@ It consists of a set of compiler directives, library routines, and environment variables that influence run-time behavior. GNU Fortran strives to be compatible to the -@uref{https://openmp.org/wp/openmp-specifications/, +@uref{https://openmp.org/specifications/, OpenMP Application Program Interface v4.5}. To enable the processing of the OpenMP directive @code{!$omp} in diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc index 000a530..71eec78 100644 --- a/gcc/fortran/interface.cc +++ b/gcc/fortran/interface.cc @@ -618,6 +618,14 @@ gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2) if (!derived1 || !derived2) gfc_internal_error ("gfc_compare_derived_types: invalid derived type"); + if (derived1->attr.unlimited_polymorphic + && derived2->attr.unlimited_polymorphic) + return true; + + if (derived1->attr.unlimited_polymorphic + != derived2->attr.unlimited_polymorphic) + return false; + /* Compare UNION types specially. */ if (derived1->attr.flavor == FL_UNION || derived2->attr.flavor == FL_UNION) return compare_union_types (derived1, derived2); @@ -630,10 +638,11 @@ gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2) && strcmp (derived1->module, derived2->module) == 0) return true; - /* Compare type via the rules of the standard. Both types must have - the SEQUENCE or BIND(C) attribute to be equal. STRUCTUREs are special - because they can be anonymous; therefore two structures with different - names may be equal. */ + /* Compare type via the rules of the standard. Both types must have the + SEQUENCE or BIND(C) attribute to be equal. We also compare types + recursively if they are class descriptors types or virtual tables types. + STRUCTUREs are special because they can be anonymous; therefore two + structures with different names may be equal. */ /* Compare names, but not for anonymous types such as UNION or MAP. */ if (!is_anonymous_dt (derived1) && !is_anonymous_dt (derived2) @@ -646,6 +655,8 @@ gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2) if (!(derived1->attr.sequence && derived2->attr.sequence) && !(derived1->attr.is_bind_c && derived2->attr.is_bind_c) + && !(derived1->attr.is_class && derived2->attr.is_class) + && !(derived1->attr.vtype && derived2->attr.vtype) && !(derived1->attr.pdt_type && derived2->attr.pdt_type)) return false; @@ -2781,7 +2792,8 @@ get_sym_storage_size (gfc_symbol *sym) if (sym->ts.type == BT_CHARACTER) { if (sym->ts.u.cl && sym->ts.u.cl->length - && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT) + && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT + && sym->ts.u.cl->length->ts.type == BT_INTEGER) strlen = mpz_get_ui (sym->ts.u.cl->length->value.integer); else return 0; @@ -2798,7 +2810,9 @@ get_sym_storage_size (gfc_symbol *sym) for (i = 0; i < sym->as->rank; i++) { if (sym->as->upper[i]->expr_type != EXPR_CONSTANT - || sym->as->lower[i]->expr_type != EXPR_CONSTANT) + || sym->as->lower[i]->expr_type != EXPR_CONSTANT + || sym->as->upper[i]->ts.type != BT_INTEGER + || sym->as->lower[i]->ts.type != BT_INTEGER) return 0; elements *= mpz_get_si (sym->as->upper[i]->value.integer) diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc index 52e5f4e..e89131f 100644 --- a/gcc/fortran/intrinsic.cc +++ b/gcc/fortran/intrinsic.cc @@ -1164,6 +1164,7 @@ gfc_is_intrinsic (gfc_symbol* sym, int subroutine_flag, locus loc) /* Check for attributes which prevent the symbol from being INTRINSIC. */ if (sym->attr.external || sym->attr.contained + || sym->attr.recursive || sym->attr.if_source == IFSRC_IFBODY) return false; @@ -1184,7 +1185,7 @@ gfc_is_intrinsic (gfc_symbol* sym, int subroutine_flag, locus loc) gfc_warning_now (OPT_Wintrinsics_std, "The intrinsic %qs at %L is not " "included in the selected standard but %s and %qs will" " be treated as if declared EXTERNAL. Use an" - " appropriate %<-std=%>* option or define" + " appropriate %<-std=%> option or define" " %<-fall-intrinsics%> to allow this intrinsic.", sym->name, &loc, symstd, sym->name); diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index f182cac..55f53fc 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -316,7 +316,7 @@ Some basic guidelines for editing this document: * @code{TRANSFER}: TRANSFER, Transfer bit patterns * @code{TRANSPOSE}: TRANSPOSE, Transpose an array of rank two * @code{TRIM}: TRIM, Remove trailing blank characters of a string -* @code{TTYNAM}: TTYNAM, Get the name of a terminal device. +* @code{TTYNAM}: TTYNAM, Get the name of a terminal device * @code{UBOUND}: UBOUND, Upper dimension bounds of an array * @code{UCOBOUND}: UCOBOUND, Upper codimension bounds of an array * @code{UMASK}: UMASK, Set the file creation mask @@ -8750,7 +8750,7 @@ END PROGRAM @node ISATTY -@section @code{ISATTY} --- Whether a unit is a terminal device. +@section @code{ISATTY} --- Whether a unit is a terminal device @fnindex ISATTY @cindex system, terminal @@ -12897,7 +12897,7 @@ end program real_kinds @table @asis @item @emph{Description}: @code{SET_EXPONENT(X, I)} returns the real number whose fractional part -is that that of @var{X} and whose exponent part is @var{I}. +is that of @var{X} and whose exponent part is @var{I}. @item @emph{Standard}: Fortran 90 and later @@ -12917,7 +12917,7 @@ Elemental function @item @emph{Return value}: The return value is of the same type and kind as @var{X}. The real number whose fractional part -is that that of @var{X} and whose exponent part if @var{I} is returned; +is that of @var{X} and whose exponent part if @var{I} is returned; it is @code{FRACTION(X) * RADIX(X)**I}. @item @emph{Example}: @@ -14613,7 +14613,7 @@ END PROGRAM @node TTYNAM -@section @code{TTYNAM} --- Get the name of a terminal device. +@section @code{TTYNAM} --- Get the name of a terminal device @fnindex TTYNAM @cindex system, terminal diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi index 6435dc4..4d1e0d6 100644 --- a/gcc/fortran/invoke.texi +++ b/gcc/fortran/invoke.texi @@ -170,7 +170,7 @@ and warnings}. @item Link Options @xref{Link Options,,Options for influencing the linking step}. -@gccoptlist{-static-libgfortran} +@gccoptlist{-static-libgfortran -static-libquadmath} @item Runtime Options @xref{Runtime Options,,Options for influencing runtime behavior}. @@ -1425,6 +1425,20 @@ configured, this option has no effect. @end table +@table @gcctabopt +@item -static-libquadmath +@opindex @code{static-libquadmath} +On systems that provide @file{libquadmath} as a shared and a static +library, this option forces the use of the static version. If no +shared version of @file{libquadmath} was built when the compiler was +configured, this option has no effect. + +Please note that the @file{libquadmath} runtime library is licensed under the +GNU Lesser General Public License (LGPL), and linking it statically introduces +requirements when redistributing the resulting binaries. +@end table + + @node Runtime Options @section Influencing runtime behavior @cindex options, runtime @@ -1435,10 +1449,20 @@ These options affect the runtime behavior of programs compiled with GNU Fortran. @item -fconvert=@var{conversion} @opindex @code{fconvert=}@var{conversion} Specify the representation of data for unformatted files. Valid -values for conversion are: @samp{native}, the default; @samp{swap}, -swap between big- and little-endian; @samp{big-endian}, use big-endian -representation for unformatted files; @samp{little-endian}, use little-endian -representation for unformatted files. +values for conversion on most systems are: @samp{native}, the default; +@samp{swap}, swap between big- and little-endian; @samp{big-endian}, use +big-endian representation for unformatted files; @samp{little-endian}, use +little-endian representation for unformatted files. + +On POWER systems which suppport @option{-mabi=ieeelongdouble}, +there are additional options, which can be combined with others with +commas. Those are +@itemize @w{} +@item @option{-fconvert=r16_ieee} Use IEEE 128-bit format for +@code{REAL(KIND=16)}. +@item @option{-fconvert=r16_ibm} Use IBM long double format for +@code{REAL(KIND=16)}. +@end itemize @emph{This option has an effect only when used in the main program. The @code{CONVERT} specifier and the GFORTRAN_CONVERT_UNIT environment @@ -1858,7 +1882,7 @@ except when optimizing for size via @option{-Os}. If the code contains a very large number of argument that have to be packed, code size and also compilation time may become excessive. If that is the case, it may be better to disable this option. Instances of packing -can be found by using by using @option{-Warray-temporaries}. +can be found by using @option{-Warray-temporaries}. @item -fexternal-blas @opindex @code{fexternal-blas} @@ -2068,7 +2092,7 @@ does not generate prototypes for @code{BIND(C)} procedures, use @option{-fc-prototypes} for that. The generated prototypes may need inclusion of an appropriate -header, such as as @code{<stdint.h>} or @code{<stdlib.h>}. +header, such as @code{<stdint.h>} or @code{<stdlib.h>}. This is primarily meant for legacy code to ensure that existing C bindings match what @command{gfortran} emits. The generated C diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt index ab92e0e..b18a6d3 100644 --- a/gcc/fortran/lang.opt +++ b/gcc/fortran/lang.opt @@ -421,23 +421,29 @@ Fortran Produce a warning at runtime if a array temporary has been created for a procedure argument. fconvert= -Fortran RejectNegative Joined Enum(gfc_convert) Var(flag_convert) Init(GFC_FLAG_CONVERT_NATIVE) --fconvert=<big-endian|little-endian|native|swap> The endianness used for unformatted files. +Fortran RejectNegative Joined Enum(gfc_convert) EnumSet Var(flag_convert) Init(GFC_FLAG_CONVERT_NATIVE) +-fconvert=<big-endian|little-endian|native|swap|r16_ieee|r16_ibm> The endianness used for unformatted files. Enum Name(gfc_convert) Type(enum gfc_convert) UnknownError(Unrecognized option to endianness value: %qs) EnumValue -Enum(gfc_convert) String(big-endian) Value(GFC_FLAG_CONVERT_BIG) +Enum(gfc_convert) String(big-endian) Value(GFC_FLAG_CONVERT_BIG) Set(1) EnumValue -Enum(gfc_convert) String(little-endian) Value(GFC_FLAG_CONVERT_LITTLE) +Enum(gfc_convert) String(little-endian) Value(GFC_FLAG_CONVERT_LITTLE) Set(1) EnumValue -Enum(gfc_convert) String(native) Value(GFC_FLAG_CONVERT_NATIVE) +Enum(gfc_convert) String(native) Value(GFC_FLAG_CONVERT_NATIVE) Set(1) EnumValue -Enum(gfc_convert) String(swap) Value(GFC_FLAG_CONVERT_SWAP) +Enum(gfc_convert) String(swap) Value(GFC_FLAG_CONVERT_SWAP) Set(1) + +EnumValue +Enum(gfc_convert) String(r16_ieee) Value(GFC_FLAG_CONVERT_R16_IEEE) Set(2) + +EnumValue +Enum(gfc_convert) String(r16_ibm) Value(GFC_FLAG_CONVERT_R16_IBM) Set(2) fcray-pointer Fortran Var(flag_cray_pointer) @@ -854,9 +860,13 @@ Fortran Joined Separate ; Documented in common.opt static-libgfortran -Fortran +Driver Statically link the GNU Fortran helper library (libgfortran). +static-libquadmath +Driver +Statically link the GCC Quad-Precision Math Library (libquadmath). + std=f2003 Fortran Conform to the ISO Fortran 2003 standard. diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h index 064795e..4328447 100644 --- a/gcc/fortran/libgfortran.h +++ b/gcc/fortran/libgfortran.h @@ -133,6 +133,7 @@ typedef enum LIBERROR_CORRUPT_FILE, LIBERROR_INQUIRE_INTERNAL_UNIT, /* Must be different from STAT_STOPPED_IMAGE. */ LIBERROR_BAD_WAIT_ID, + LIBERROR_NO_MEMORY, LIBERROR_LAST /* Not a real error, the last error # + 1. */ } libgfortran_error_codes; diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc index 8edfe4a..8b8b6e7 100644 --- a/gcc/fortran/match.cc +++ b/gcc/fortran/match.cc @@ -454,10 +454,11 @@ gfc_match_eos (void) /* Match a literal integer on the input, setting the value on MATCH_YES. Literal ints occur in kind-parameters as well as old-style character length specifications. If cnt is non-NULL it - will be set to the number of digits. */ + will be set to the number of digits. + When gobble_ws is false, do not skip over leading blanks. */ match -gfc_match_small_literal_int (int *value, int *cnt) +gfc_match_small_literal_int (int *value, int *cnt, bool gobble_ws) { locus old_loc; char c; @@ -466,7 +467,8 @@ gfc_match_small_literal_int (int *value, int *cnt) old_loc = gfc_current_locus; *value = -1; - gfc_gobble_whitespace (); + if (gobble_ws) + gfc_gobble_whitespace (); c = gfc_next_ascii_char (); if (cnt) *cnt = 0; @@ -608,17 +610,19 @@ gfc_match_label (void) /* See if the current input looks like a name of some sort. Modifies the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long. Note that options.cc restricts max_identifier_length to not more - than GFC_MAX_SYMBOL_LEN. */ + than GFC_MAX_SYMBOL_LEN. + When gobble_ws is false, do not skip over leading blanks. */ match -gfc_match_name (char *buffer) +gfc_match_name (char *buffer, bool gobble_ws) { locus old_loc; int i; char c; old_loc = gfc_current_locus; - gfc_gobble_whitespace (); + if (gobble_ws) + gfc_gobble_whitespace (); c = gfc_next_ascii_char (); if (!(ISALPHA (c) || (c == '_' && flag_allow_leading_underscore))) @@ -1053,15 +1057,17 @@ cleanup: /* Tries to match the next non-whitespace character on the input. - This subroutine does not return MATCH_ERROR. */ + This subroutine does not return MATCH_ERROR. + When gobble_ws is false, do not skip over leading blanks. */ match -gfc_match_char (char c) +gfc_match_char (char c, bool gobble_ws) { locus where; where = gfc_current_locus; - gfc_gobble_whitespace (); + if (gobble_ws) + gfc_gobble_whitespace (); if (gfc_next_ascii_char () == c) return MATCH_YES; @@ -1606,21 +1612,21 @@ gfc_match_if (gfc_statement *if_type) match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT) match ("backspace", gfc_match_backspace, ST_BACKSPACE) match ("call", gfc_match_call, ST_CALL) - match ("change team", gfc_match_change_team, ST_CHANGE_TEAM) + match ("change% team", gfc_match_change_team, ST_CHANGE_TEAM) match ("close", gfc_match_close, ST_CLOSE) match ("continue", gfc_match_continue, ST_CONTINUE) match ("cycle", gfc_match_cycle, ST_CYCLE) match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE) match ("end file", gfc_match_endfile, ST_END_FILE) match ("end team", gfc_match_end_team, ST_END_TEAM) - match ("error stop", gfc_match_error_stop, ST_ERROR_STOP) - match ("event post", gfc_match_event_post, ST_EVENT_POST) - match ("event wait", gfc_match_event_wait, ST_EVENT_WAIT) + match ("error% stop", gfc_match_error_stop, ST_ERROR_STOP) + match ("event% post", gfc_match_event_post, ST_EVENT_POST) + match ("event% wait", gfc_match_event_wait, ST_EVENT_WAIT) match ("exit", gfc_match_exit, ST_EXIT) - match ("fail image", gfc_match_fail_image, ST_FAIL_IMAGE) + match ("fail% image", gfc_match_fail_image, ST_FAIL_IMAGE) match ("flush", gfc_match_flush, ST_FLUSH) match ("forall", match_simple_forall, ST_FORALL) - match ("form team", gfc_match_form_team, ST_FORM_TEAM) + match ("form% team", gfc_match_form_team, ST_FORM_TEAM) match ("go to", gfc_match_goto, ST_GOTO) match ("if", match_arithmetic_if, ST_ARITHMETIC_IF) match ("inquire", gfc_match_inquire, ST_INQUIRE) @@ -1634,10 +1640,10 @@ gfc_match_if (gfc_statement *if_type) match ("rewind", gfc_match_rewind, ST_REWIND) match ("stop", gfc_match_stop, ST_STOP) match ("wait", gfc_match_wait, ST_WAIT) - match ("sync all", gfc_match_sync_all, ST_SYNC_CALL); - match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES); - match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY); - match ("sync team", gfc_match_sync_team, ST_SYNC_TEAM) + match ("sync% all", gfc_match_sync_all, ST_SYNC_CALL); + match ("sync% images", gfc_match_sync_images, ST_SYNC_IMAGES); + match ("sync% memory", gfc_match_sync_memory, ST_SYNC_MEMORY); + match ("sync% team", gfc_match_sync_team, ST_SYNC_TEAM) match ("unlock", gfc_match_unlock, ST_UNLOCK) match ("where", match_simple_where, ST_WHERE) match ("write", gfc_match_write, ST_WRITE) @@ -2857,83 +2863,107 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op) for (o = p, cnt = 0; o->state == COMP_DO && o->previous != NULL; cnt++) o = o->previous; + + int count = 1; if (cnt > 0 && o != NULL - && o->state == COMP_OMP_STRUCTURED_BLOCK - && (o->head->op == EXEC_OACC_LOOP - || o->head->op == EXEC_OACC_KERNELS_LOOP - || o->head->op == EXEC_OACC_PARALLEL_LOOP - || o->head->op == EXEC_OACC_SERIAL_LOOP)) - { - int collapse = 1; - gcc_assert (o->head->next != NULL - && (o->head->next->op == EXEC_DO - || o->head->next->op == EXEC_DO_WHILE) - && o->previous != NULL - && o->previous->tail->op == o->head->op); - if (o->previous->tail->ext.omp_clauses != NULL) - { - /* Both collapsed and tiled loops are lowered the same way, but are not - compatible. In gfc_trans_omp_do, the tile is prioritized. */ - if (o->previous->tail->ext.omp_clauses->tile_list) - { - collapse = 0; - gfc_expr_list *el = o->previous->tail->ext.omp_clauses->tile_list; - for ( ; el; el = el->next) - ++collapse; - } - else if (o->previous->tail->ext.omp_clauses->collapse > 1) - collapse = o->previous->tail->ext.omp_clauses->collapse; - } - if (st == ST_EXIT && cnt <= collapse) - { - gfc_error ("EXIT statement at %C terminating !$ACC LOOP loop"); - return MATCH_ERROR; - } - if (st == ST_CYCLE && cnt < collapse) - { - gfc_error (o->previous->tail->ext.omp_clauses->tile_list - ? G_("CYCLE statement at %C to non-innermost tiled" - " !$ACC LOOP loop") - : G_("CYCLE statement at %C to non-innermost collapsed" - " !$ACC LOOP loop")); - return MATCH_ERROR; - } - } - if (cnt > 0 - && o != NULL - && (o->state == COMP_OMP_STRUCTURED_BLOCK) - && (o->head->op == EXEC_OMP_DO - || o->head->op == EXEC_OMP_PARALLEL_DO - || o->head->op == EXEC_OMP_SIMD - || o->head->op == EXEC_OMP_DO_SIMD - || o->head->op == EXEC_OMP_PARALLEL_DO_SIMD)) - { - int count = 1; - gcc_assert (o->head->next != NULL + && o->state == COMP_OMP_STRUCTURED_BLOCK) + switch (o->head->op) + { + case EXEC_OACC_LOOP: + case EXEC_OACC_KERNELS_LOOP: + case EXEC_OACC_PARALLEL_LOOP: + case EXEC_OACC_SERIAL_LOOP: + gcc_assert (o->head->next != NULL + && (o->head->next->op == EXEC_DO + || o->head->next->op == EXEC_DO_WHILE) + && o->previous != NULL + && o->previous->tail->op == o->head->op); + if (o->previous->tail->ext.omp_clauses != NULL) + { + /* Both collapsed and tiled loops are lowered the same way, but are + not compatible. In gfc_trans_omp_do, the tile is prioritized. */ + if (o->previous->tail->ext.omp_clauses->tile_list) + { + count = 0; + gfc_expr_list *el + = o->previous->tail->ext.omp_clauses->tile_list; + for ( ; el; el = el->next) + ++count; + } + else if (o->previous->tail->ext.omp_clauses->collapse > 1) + count = o->previous->tail->ext.omp_clauses->collapse; + } + if (st == ST_EXIT && cnt <= count) + { + gfc_error ("EXIT statement at %C terminating !$ACC LOOP loop"); + return MATCH_ERROR; + } + if (st == ST_CYCLE && cnt < count) + { + gfc_error (o->previous->tail->ext.omp_clauses->tile_list + ? G_("CYCLE statement at %C to non-innermost tiled " + "!$ACC LOOP loop") + : G_("CYCLE statement at %C to non-innermost collapsed " + "!$ACC LOOP loop")); + return MATCH_ERROR; + } + break; + 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: + case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: + case EXEC_OMP_MASTER_TASKLOOP_SIMD: + case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: + case EXEC_OMP_MASKED_TASKLOOP_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_LOOP: + case EXEC_OMP_PARALLEL_LOOP: + case EXEC_OMP_TEAMS_LOOP: + case EXEC_OMP_TARGET_PARALLEL_LOOP: + case EXEC_OMP_TARGET_TEAMS_LOOP: + case EXEC_OMP_DO: + case EXEC_OMP_PARALLEL_DO: + case EXEC_OMP_SIMD: + case EXEC_OMP_DO_SIMD: + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TARGET_PARALLEL_DO: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + + gcc_assert (o->head->next != NULL && (o->head->next->op == EXEC_DO || o->head->next->op == EXEC_DO_WHILE) && o->previous != NULL && o->previous->tail->op == o->head->op); - if (o->previous->tail->ext.omp_clauses != NULL) - { - if (o->previous->tail->ext.omp_clauses->collapse > 1) - count = o->previous->tail->ext.omp_clauses->collapse; - if (o->previous->tail->ext.omp_clauses->orderedc) - count = o->previous->tail->ext.omp_clauses->orderedc; - } - if (st == ST_EXIT && cnt <= count) - { - gfc_error ("EXIT statement at %C terminating !$OMP DO loop"); - return MATCH_ERROR; - } - if (st == ST_CYCLE && cnt < count) - { - gfc_error ("CYCLE statement at %C to non-innermost collapsed" - " !$OMP DO loop"); - return MATCH_ERROR; - } - } + if (o->previous->tail->ext.omp_clauses != NULL) + { + if (o->previous->tail->ext.omp_clauses->collapse > 1) + count = o->previous->tail->ext.omp_clauses->collapse; + if (o->previous->tail->ext.omp_clauses->orderedc) + count = o->previous->tail->ext.omp_clauses->orderedc; + } + if (st == ST_EXIT && cnt <= count) + { + gfc_error ("EXIT statement at %C terminating !$OMP DO loop"); + return MATCH_ERROR; + } + if (st == ST_CYCLE && cnt < count) + { + gfc_error ("CYCLE statement at %C to non-innermost collapsed " + "!$OMP DO loop"); + return MATCH_ERROR; + } + break; + default: + break; + } /* Save the first statement in the construct - needed by the backend. */ new_st.ext.which_construct = p->construct; @@ -2978,6 +3008,13 @@ Fortran 2008 has R856 allstop-stmt is ALL STOP [ stop-code ] R857 stop-code is scalar-default-char-constant-expr or scalar-int-constant-expr +Fortran 2018 has + + R1160 stop-stmt is STOP [ stop-code ] [ , QUIET = scalar-logical-expr] + R1161 error-stop-stmt is + ERROR STOP [ stop-code ] [ , QUIET = scalar-logical-expr] + R1162 stop-code is scalar-default-char-expr + or scalar-int-expr For free-form source code, all standards contain a statement of the form: @@ -2994,8 +3031,10 @@ static match gfc_match_stopcode (gfc_statement st) { gfc_expr *e = NULL; + gfc_expr *quiet = NULL; match m; bool f95, f03, f08; + char c; /* Set f95 for -std=f95. */ f95 = (gfc_option.allow_std == GFC_STD_OPT_F95); @@ -3006,11 +3045,16 @@ gfc_match_stopcode (gfc_statement st) /* Set f08 for -std=f2008. */ f08 = (gfc_option.allow_std == GFC_STD_OPT_F08); - /* Look for a blank between STOP and the stop-code for F2008 or later. */ - if (gfc_current_form != FORM_FIXED && !(f95 || f03)) - { - char c = gfc_peek_ascii_char (); + /* Plain STOP statement? */ + if (gfc_match_eos () == MATCH_YES) + goto checks; + /* Look for a blank between STOP and the stop-code for F2008 or later. + But allow for F2018's ,QUIET= specifier. */ + c = gfc_peek_ascii_char (); + + if (gfc_current_form != FORM_FIXED && !(f95 || f03) && c != ',') + { /* Look for end-of-statement. There is no stop-code. */ if (c == '\n' || c == '!' || c == ';') goto done; @@ -3023,7 +3067,12 @@ gfc_match_stopcode (gfc_statement st) } } - if (gfc_match_eos () != MATCH_YES) + if (c == ' ') + { + gfc_gobble_whitespace (); + c = gfc_peek_ascii_char (); + } + if (c != ',') { int stopcode; locus old_locus; @@ -3053,11 +3102,20 @@ gfc_match_stopcode (gfc_statement st) goto cleanup; if (m == MATCH_NO) goto syntax; + } - if (gfc_match_eos () != MATCH_YES) - goto syntax; + if (gfc_match (" , quiet = %e", &quiet) == MATCH_YES) + { + if (!gfc_notify_std (GFC_STD_F2018, "QUIET= specifier for %s at %L", + gfc_ascii_statement (st), &quiet->where)) + goto cleanup; } + if (gfc_match_eos () != MATCH_YES) + goto syntax; + +checks: + if (gfc_pure (NULL)) { if (st == ST_ERROR_STOP) @@ -3133,10 +3191,22 @@ gfc_match_stopcode (gfc_statement st) goto cleanup; } - if (e->ts.type == BT_INTEGER && e->ts.kind != gfc_default_integer_kind) + if (e->ts.type == BT_INTEGER && e->ts.kind != gfc_default_integer_kind + && !gfc_notify_std (GFC_STD_F2018, + "STOP code at %L must be default integer KIND=%d", + &e->where, (int) gfc_default_integer_kind)) + goto cleanup; + } + + if (quiet != NULL) + { + if (!gfc_simplify_expr (quiet, 0)) + goto cleanup; + + if (quiet->rank != 0) { - gfc_error ("STOP code at %L must be default integer KIND=%d", - &e->where, (int) gfc_default_integer_kind); + gfc_error ("QUIET specifier at %L must be a scalar LOGICAL", + &quiet->where); goto cleanup; } } @@ -3159,6 +3229,7 @@ done: } new_st.expr1 = e; + new_st.expr2 = quiet; new_st.ext.stop_code = -1; return MATCH_YES; @@ -3169,6 +3240,7 @@ syntax: cleanup: gfc_free_expr (e); + gfc_free_expr (quiet); return MATCH_ERROR; } @@ -6650,7 +6722,7 @@ gfc_match_select_rank (void) if (m == MATCH_ERROR) return m; - m = gfc_match (" select rank ( "); + m = gfc_match (" select% rank ( "); if (m != MATCH_YES) return m; diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 495c93e..1f53e0c 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -45,14 +45,14 @@ extern gfc_access gfc_typebound_default_access; match gfc_match_special_char (gfc_char_t *); match gfc_match_space (void); match gfc_match_eos (void); -match gfc_match_small_literal_int (int *, int *); +match gfc_match_small_literal_int (int *, int *, bool = true); match gfc_match_st_label (gfc_st_label **); match gfc_match_small_int (int *); -match gfc_match_name (char *); +match gfc_match_name (char *, bool = true); match gfc_match_symbol (gfc_symbol **, int); match gfc_match_sym_tree (gfc_symtree **, int); match gfc_match_intrinsic_op (gfc_intrinsic_op *); -match gfc_match_char (char); +match gfc_match_char (char, bool = true); match gfc_match (const char *, ...); match gfc_match_iterator (gfc_iterator *, int); match gfc_match_parens (void); diff --git a/gcc/fortran/module.cc b/gcc/fortran/module.cc index 281b1b1..5ddabdc 100644 --- a/gcc/fortran/module.cc +++ b/gcc/fortran/module.cc @@ -1095,8 +1095,9 @@ gzopen_included_file_1 (const char *name, gfc_directorylist *list, if (module && !p->use_for_modules) continue; - fullname = (char *) alloca(strlen (p->path) + strlen (name) + 1); + fullname = (char *) alloca(strlen (p->path) + strlen (name) + 2); strcpy (fullname, p->path); + strcat (fullname, "/"); strcat (fullname, name); f = gzopen (fullname, "r"); @@ -4382,10 +4383,10 @@ mio_omp_declare_simd (gfc_namespace *ns, gfc_omp_declare_simd **odsp) } for (n = ods->clauses->lists[OMP_LIST_LINEAR]; n; n = n->next) { - if (n->u.linear_op == OMP_LINEAR_DEFAULT) + if (n->u.linear.op == OMP_LINEAR_DEFAULT) mio_name (4, omp_declare_simd_clauses); else - mio_name (32 + n->u.linear_op, omp_declare_simd_clauses); + mio_name (32 + n->u.linear.op, omp_declare_simd_clauses); mio_symbol_ref (&n->sym); mio_expr (&n->expr); } @@ -4437,7 +4438,7 @@ mio_omp_declare_simd (gfc_namespace *ns, gfc_omp_declare_simd **odsp) case 34: case 35: *ptrs[1] = n = gfc_get_omp_namelist (); - n->u.linear_op = (enum gfc_omp_linear_op) (t - 32); + n->u.linear.op = (enum gfc_omp_linear_op) (t - 32); t = 4; goto finish_namelist; } diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc index 9b73b9f..5949077 100644 --- a/gcc/fortran/openmp.cc +++ b/gcc/fortran/openmp.cc @@ -296,14 +296,17 @@ gfc_find_omp_udr (gfc_namespace *ns, const char *name, gfc_typespec *ts) } -/* Match a variable/common block list and construct a namelist from it. */ +/* Match a variable/common block list and construct a namelist from it; + if has_all_memory != NULL, *has_all_memory is set and omp_all_memory + yields a list->sym NULL entry. */ static match gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list, bool allow_common, bool *end_colon = NULL, gfc_omp_namelist ***headp = NULL, bool allow_sections = false, - bool allow_derived = false) + bool allow_derived = false, + bool *has_all_memory = NULL) { gfc_omp_namelist *head, *tail, *p; locus old_loc, cur_loc; @@ -315,7 +318,8 @@ gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list, head = tail = NULL; old_loc = gfc_current_locus; - + if (has_all_memory) + *has_all_memory = false; m = gfc_match (str); if (m != MATCH_YES) return m; @@ -323,7 +327,35 @@ gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list, for (;;) { cur_loc = gfc_current_locus; - m = gfc_match_symbol (&sym, 1); + + m = gfc_match_name (n); + if (m == MATCH_YES && strcmp (n, "omp_all_memory") == 0) + { + if (!has_all_memory) + { + gfc_error ("%<omp_all_memory%> at %C not permitted in this " + "clause"); + goto cleanup; + } + *has_all_memory = true; + p = gfc_get_omp_namelist (); + if (head == NULL) + head = tail = p; + else + { + tail->next = p; + tail = tail->next; + } + tail->where = cur_loc; + goto next_item; + } + if (m == MATCH_YES) + { + gfc_symtree *st; + if ((m = gfc_get_ha_sym_tree (n, &st) ? MATCH_ERROR : MATCH_YES) + == MATCH_YES) + sym = st->n.sym; + } switch (m) { case MATCH_YES: @@ -531,14 +563,6 @@ gfc_match_omp_detach (gfc_expr **expr) if (gfc_match_variable (expr, 0) != MATCH_YES) goto syntax_error; - if ((*expr)->ts.type != BT_INTEGER || (*expr)->ts.kind != gfc_c_intptr_kind) - { - gfc_error ("%qs at %L should be of type " - "integer(kind=omp_event_handle_kind)", - (*expr)->symtree->n.sym->name, &(*expr)->where); - return MATCH_ERROR; - } - if (gfc_match_char (')') != MATCH_YES) goto syntax_error; @@ -586,6 +610,12 @@ gfc_match_omp_depend_sink (gfc_omp_namelist **list) tail->sym = sym; tail->expr = NULL; tail->where = cur_loc; + if (UNLIKELY (strcmp (sym->name, "omp_all_memory") == 0)) + { + gfc_error ("%<omp_all_memory%> used with DEPEND kind " + "other than OUT or INOUT at %C"); + goto cleanup; + } if (gfc_match_char ('+') == MATCH_YES) { if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES) @@ -926,7 +956,7 @@ enum omp_mask1 OMP_MASK1_LAST }; -/* OpenACC 2.0+ specific clauses. */ +/* More OpenMP clauses and OpenACC 2.0+ specific clauses. */ enum omp_mask2 { OMP_CLAUSE_ASYNC, @@ -955,6 +985,8 @@ enum omp_mask2 OMP_CLAUSE_FINALIZE, OMP_CLAUSE_ATTACH, OMP_CLAUSE_NOHOST, + OMP_CLAUSE_HAS_DEVICE_ADDR, /* OpenMP 5.1 */ + OMP_CLAUSE_ENTER, /* OpenMP 5.2 */ /* This must come last. */ OMP_MASK2_LAST }; @@ -1123,7 +1155,7 @@ gfc_match_iterator (gfc_namespace **ns, bool permit_var) if (last) last->tlink = sym; else - (*ns)->proc_name = sym; + (*ns)->omp_affinity_iterators = sym; last = sym; sym->declared_at = prev_loc; sym->ts = ts; @@ -1149,7 +1181,6 @@ gfc_match_iterator (gfc_namespace **ns, bool permit_var) } if (':' == gfc_peek_ascii_char ()) { - step = gfc_get_expr (); if (gfc_match (": %e ", &step) != MATCH_YES) { gfc_free_expr (begin); @@ -1875,6 +1906,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if ((mask & OMP_CLAUSE_DEPEND) && gfc_match ("depend ( ") == MATCH_YES) { + bool has_omp_all_memory; gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns; match m_it = gfc_match_iterator (&ns_iter, false); if (m_it == MATCH_ERROR) @@ -1883,7 +1915,9 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, break; m = MATCH_YES; gfc_omp_depend_op depend_op = OMP_DEPEND_OUT; - if (gfc_match ("inout") == MATCH_YES) + if (gfc_match ("inoutset") == MATCH_YES) + depend_op = OMP_DEPEND_INOUTSET; + else if (gfc_match ("inout") == MATCH_YES) depend_op = OMP_DEPEND_INOUT; else if (gfc_match ("in") == MATCH_YES) depend_op = OMP_DEPEND_IN; @@ -1927,21 +1961,27 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if (m == MATCH_YES) m = gfc_match_omp_variable_list (" : ", &c->lists[OMP_LIST_DEPEND], - false, NULL, &head, true); + false, NULL, &head, true, + false, &has_omp_all_memory); + if (m != MATCH_YES) + goto error; gfc_current_ns = ns_curr; - if (m == MATCH_YES) + if (has_omp_all_memory && depend_op != OMP_DEPEND_INOUT + && depend_op != OMP_DEPEND_OUT) { - gfc_omp_namelist *n; - for (n = *head; n; n = n->next) - { - n->u.depend_op = depend_op; - n->u2.ns = ns_iter; - if (ns_iter) - ns_iter->refs++; - } - continue; + gfc_error ("%<omp_all_memory%> used with DEPEND kind " + "other than OUT or INOUT at %C"); + goto error; } - break; + gfc_omp_namelist *n; + for (n = *head; n; n = n->next) + { + n->u.depend_op = depend_op; + n->u2.ns = ns_iter; + if (ns_iter) + ns_iter->refs++; + } + continue; } if ((mask & OMP_CLAUSE_DETACH) && !openacc @@ -1973,8 +2013,15 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, } else if (gfc_match ("ancestor : ") == MATCH_YES) { + bool has_requires = false; c->ancestor = true; - if (!(gfc_current_ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD)) + for (gfc_namespace *ns = gfc_current_ns; ns; ns = ns->parent) + if (ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD) + { + has_requires = true; + break; + } + if (!has_requires) { gfc_error ("%<ancestor%> device modifier not " "preceded by %<requires%> directive " @@ -2061,6 +2108,16 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, continue; } break; + case 'e': + if ((mask & OMP_CLAUSE_ENTER)) + { + m = gfc_match_omp_to_link ("enter (", &c->lists[OMP_LIST_ENTER]); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_YES) + continue; + } + break; case 'f': if ((mask & OMP_CLAUSE_FAIL) && (m = gfc_match_dupl_check (c->fail == OMP_MEMORDER_UNSET, @@ -2151,6 +2208,11 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, } break; case 'h': + if ((mask & OMP_CLAUSE_HAS_DEVICE_ADDR) + && gfc_match_omp_variable_list + ("has_device_addr (", &c->lists[OMP_LIST_HAS_DEVICE_ADDR], + false, NULL, NULL, true) == MATCH_YES) + continue; if ((mask & OMP_CLAUSE_HINT) && (m = gfc_match_dupl_check (!c->hint, "hint", true, &c->hint)) != MATCH_NO) @@ -2261,6 +2323,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if ((mask & OMP_CLAUSE_LINEAR) && gfc_match ("linear (") == MATCH_YES) { + bool old_linear_modifier = false; gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT; gfc_expr *step = NULL; @@ -2268,17 +2331,26 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, &c->lists[OMP_LIST_LINEAR], false, NULL, &head) == MATCH_YES) - linear_op = OMP_LINEAR_REF; + { + linear_op = OMP_LINEAR_REF; + old_linear_modifier = true; + } else if (gfc_match_omp_variable_list (" val (", &c->lists[OMP_LIST_LINEAR], false, NULL, &head) == MATCH_YES) - linear_op = OMP_LINEAR_VAL; + { + linear_op = OMP_LINEAR_VAL; + old_linear_modifier = true; + } else if (gfc_match_omp_variable_list (" uval (", &c->lists[OMP_LIST_LINEAR], false, NULL, &head) == MATCH_YES) - linear_op = OMP_LINEAR_UVAL; + { + linear_op = OMP_LINEAR_UVAL; + old_linear_modifier = true; + } else if (gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_LINEAR], false, &end_colon, &head) @@ -2301,14 +2373,114 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, break; } } - if (end_colon && gfc_match (" %e )", &step) != MATCH_YES) + gfc_gobble_whitespace (); + if (old_linear_modifier && end_colon) { - gfc_free_omp_namelist (*head, false); - gfc_current_locus = old_loc; - *head = NULL; - break; + if (gfc_match (" %e )", &step) != MATCH_YES) + { + gfc_free_omp_namelist (*head, false); + gfc_current_locus = old_loc; + *head = NULL; + goto error; + } } - else if (!end_colon) + else if (end_colon) + { + bool has_error = false; + bool has_modifiers = false; + bool has_step = false; + bool duplicate_step = false; + bool duplicate_mod = false; + while (true) + { + old_loc = gfc_current_locus; + bool close_paren = gfc_match ("val )") == MATCH_YES; + if (close_paren || gfc_match ("val , ") == MATCH_YES) + { + if (linear_op != OMP_LINEAR_DEFAULT) + { + duplicate_mod = true; + break; + } + linear_op = OMP_LINEAR_VAL; + has_modifiers = true; + if (close_paren) + break; + continue; + } + close_paren = gfc_match ("uval )") == MATCH_YES; + if (close_paren || gfc_match ("uval , ") == MATCH_YES) + { + if (linear_op != OMP_LINEAR_DEFAULT) + { + duplicate_mod = true; + break; + } + linear_op = OMP_LINEAR_UVAL; + has_modifiers = true; + if (close_paren) + break; + continue; + } + close_paren = gfc_match ("ref )") == MATCH_YES; + if (close_paren || gfc_match ("ref , ") == MATCH_YES) + { + if (linear_op != OMP_LINEAR_DEFAULT) + { + duplicate_mod = true; + break; + } + linear_op = OMP_LINEAR_REF; + has_modifiers = true; + if (close_paren) + break; + continue; + } + close_paren = (gfc_match ("step ( %e ) )", &step) + == MATCH_YES); + if (close_paren + || gfc_match ("step ( %e ) , ", &step) == MATCH_YES) + { + if (has_step) + { + duplicate_step = true; + break; + } + has_modifiers = has_step = true; + if (close_paren) + break; + continue; + } + if (!has_modifiers + && gfc_match ("%e )", &step) == MATCH_YES) + { + if ((step->expr_type == EXPR_FUNCTION + || step->expr_type == EXPR_VARIABLE) + && strcmp (step->symtree->name, "step") == 0) + { + gfc_current_locus = old_loc; + gfc_match ("step ("); + has_error = true; + } + break; + } + has_error = true; + break; + } + if (duplicate_mod || duplicate_step) + { + gfc_error ("Multiple %qs modifiers specified at %C", + duplicate_mod ? "linear" : "step"); + has_error = true; + } + if (has_error) + { + gfc_free_omp_namelist (*head, false); + *head = NULL; + goto error; + } + } + if (step == NULL) { step = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, @@ -2316,9 +2488,12 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, mpz_set_si (step->value.integer, 1); } (*head)->expr = step; - if (linear_op != OMP_LINEAR_DEFAULT) + if (linear_op != OMP_LINEAR_DEFAULT || old_linear_modifier) for (gfc_omp_namelist *n = *head; n; n = n->next) - n->u.linear_op = linear_op; + { + n->u.linear.op = linear_op; + n->u.linear.old_modifier = old_linear_modifier; + } continue; } if ((mask & OMP_CLAUSE_LINK) @@ -2876,8 +3051,12 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, continue; if ((mask & OMP_CLAUSE_TO) && (mask & OMP_CLAUSE_LINK)) { - if (gfc_match_omp_to_link ("to (", &c->lists[OMP_LIST_TO]) - == MATCH_YES) + /* Declare target: 'to' is an alias for 'enter'; + 'to' is deprecated since 5.2. */ + m = gfc_match_omp_to_link ("to (", &c->lists[OMP_LIST_TO]); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_YES) continue; } else if ((mask & OMP_CLAUSE_TO) @@ -2923,8 +3102,8 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, continue; if ((mask & OMP_CLAUSE_USE_DEVICE_ADDR) && gfc_match_omp_variable_list - ("use_device_addr (", - &c->lists[OMP_LIST_USE_DEVICE_ADDR], false) == MATCH_YES) + ("use_device_addr (", &c->lists[OMP_LIST_USE_DEVICE_ADDR], + false, NULL, NULL, true) == MATCH_YES) continue; break; case 'v': @@ -3622,7 +3801,8 @@ cleanup: | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION) #define OMP_SCOPE_CLAUSES \ - (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_REDUCTION) + (omp_mask (OMP_CLAUSE_PRIVATE) |OMP_CLAUSE_FIRSTPRIVATE \ + | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE) #define OMP_SECTIONS_CLAUSES \ (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \ | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE) @@ -3651,7 +3831,8 @@ cleanup: | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_PRIVATE \ | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULTMAP \ | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_IN_REDUCTION \ - | OMP_CLAUSE_THREAD_LIMIT | OMP_CLAUSE_ALLOCATE) + | OMP_CLAUSE_THREAD_LIMIT | OMP_CLAUSE_ALLOCATE \ + | OMP_CLAUSE_HAS_DEVICE_ADDR) #define OMP_TARGET_DATA_CLAUSES \ (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \ | OMP_CLAUSE_USE_DEVICE_PTR | OMP_CLAUSE_USE_DEVICE_ADDR) @@ -3678,7 +3859,8 @@ cleanup: #define OMP_ORDERED_CLAUSES \ (omp_mask (OMP_CLAUSE_THREADS) | OMP_CLAUSE_SIMD) #define OMP_DECLARE_TARGET_CLAUSES \ - (omp_mask (OMP_CLAUSE_TO) | OMP_CLAUSE_LINK | OMP_CLAUSE_DEVICE_TYPE) + (omp_mask (OMP_CLAUSE_ENTER) | OMP_CLAUSE_LINK | OMP_CLAUSE_DEVICE_TYPE \ + | OMP_CLAUSE_TO) #define OMP_ATOMIC_CLAUSES \ (omp_mask (OMP_CLAUSE_ATOMIC) | OMP_CLAUSE_CAPTURE | OMP_CLAUSE_HINT \ | OMP_CLAUSE_MEMORDER | OMP_CLAUSE_COMPARE | OMP_CLAUSE_FAIL \ @@ -3761,7 +3943,9 @@ gfc_match_omp_depobj (void) if (gfc_match ("update ( ") == MATCH_YES) { c = gfc_get_omp_clauses (); - if (gfc_match ("inout )") == MATCH_YES) + if (gfc_match ("inoutset )") == MATCH_YES) + c->depobj_update = OMP_DEPEND_INOUTSET; + else if (gfc_match ("inout )") == MATCH_YES) c->depobj_update = OMP_DEPEND_INOUT; else if (gfc_match ("in )") == MATCH_YES) c->depobj_update = OMP_DEPEND_IN; @@ -3771,8 +3955,8 @@ gfc_match_omp_depobj (void) c->depobj_update = OMP_DEPEND_MUTEXINOUTSET; else { - gfc_error ("Expected IN, OUT, INOUT, MUTEXINOUTSET followed by " - "%<)%> at %C"); + gfc_error ("Expected IN, OUT, INOUT, INOUTSET or MUTEXINOUTSET " + "followed by %<)%> at %C"); goto error; } } @@ -4029,9 +4213,13 @@ gfc_match_omp_declare_simd (void) gfc_omp_declare_simd *ods; bool needs_space = false; - switch (gfc_match (" ( %s ) ", &proc_name)) + switch (gfc_match (" ( ")) { - case MATCH_YES: break; + case MATCH_YES: + if (gfc_match_symbol (&proc_name, /* host assoc = */ true) != MATCH_YES + || gfc_match (" ) ") != MATCH_YES) + return MATCH_ERROR; + break; case MATCH_NO: proc_name = NULL; needs_space = true; break; case MATCH_ERROR: return MATCH_ERROR; } @@ -4482,7 +4670,7 @@ gfc_match_omp_declare_target (void) { c = gfc_get_omp_clauses (); gfc_current_locus = old_loc; - m = gfc_match_omp_to_link (" (", &c->lists[OMP_LIST_TO]); + m = gfc_match_omp_to_link (" (", &c->lists[OMP_LIST_ENTER]); if (m != MATCH_YES) goto syntax; if (gfc_match_omp_eos () != MATCH_YES) @@ -4496,38 +4684,40 @@ gfc_match_omp_declare_target (void) gfc_buffer_error (false); - for (list = OMP_LIST_TO; list != OMP_LIST_NUM; - list = (list == OMP_LIST_TO ? OMP_LIST_LINK : OMP_LIST_NUM)) + static const int to_enter_link_lists[] + = { OMP_LIST_TO, OMP_LIST_ENTER, OMP_LIST_LINK }; + for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists) + && (list = to_enter_link_lists[listn], true); ++listn) for (n = c->lists[list]; n; n = n->next) if (n->sym) n->sym->mark = 0; else if (n->u.common->head) n->u.common->head->mark = 0; - for (list = OMP_LIST_TO; list != OMP_LIST_NUM; - list = (list == OMP_LIST_TO ? OMP_LIST_LINK : OMP_LIST_NUM)) + for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists) + && (list = to_enter_link_lists[listn], true); ++listn) for (n = c->lists[list]; n; n = n->next) if (n->sym) { if (n->sym->attr.in_common) gfc_error_now ("OMP DECLARE TARGET variable at %L is an " "element of a COMMON block", &n->where); + else if (n->sym->mark) + gfc_error_now ("Variable at %L mentioned multiple times in " + "clauses of the same OMP DECLARE TARGET directive", + &n->where); else if (n->sym->attr.omp_declare_target && n->sym->attr.omp_declare_target_link && list != OMP_LIST_LINK) gfc_error_now ("OMP DECLARE TARGET variable at %L previously " - "mentioned in LINK clause and later in TO clause", - &n->where); + "mentioned in LINK clause and later in %s clause", + &n->where, list == OMP_LIST_TO ? "TO" : "ENTER"); else if (n->sym->attr.omp_declare_target && !n->sym->attr.omp_declare_target_link && list == OMP_LIST_LINK) gfc_error_now ("OMP DECLARE TARGET variable at %L previously " - "mentioned in TO clause and later in LINK clause", - &n->where); - else if (n->sym->mark) - gfc_error_now ("Variable at %L mentioned multiple times in " - "clauses of the same OMP DECLARE TARGET directive", - &n->where); + "mentioned in TO or ENTER clause and later in " + "LINK clause", &n->where); else if (gfc_add_omp_declare_target (&n->sym->attr, n->sym->name, &n->sym->declared_at)) { @@ -4550,14 +4740,14 @@ gfc_match_omp_declare_target (void) && n->u.common->omp_declare_target_link && list != OMP_LIST_LINK) gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously " - "mentioned in LINK clause and later in TO clause", - &n->where); + "mentioned in LINK clause and later in %s clause", + &n->where, list == OMP_LIST_TO ? "TO" : "ENTER"); else if (n->u.common->omp_declare_target && !n->u.common->omp_declare_target_link && list == OMP_LIST_LINK) gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously " - "mentioned in TO clause and later in LINK clause", - &n->where); + "mentioned in TO or ENTER clause and later in " + "LINK clause", &n->where); else if (n->u.common->head && n->u.common->head->mark) gfc_error_now ("COMMON at %L mentioned multiple times in " "clauses of the same OMP DECLARE TARGET directive", @@ -4591,7 +4781,10 @@ gfc_match_omp_declare_target (void) s->attr.omp_device_type = c->device_type; } } - if (c->device_type && !c->lists[OMP_LIST_TO] && !c->lists[OMP_LIST_LINK]) + if (c->device_type + && !c->lists[OMP_LIST_ENTER] + && !c->lists[OMP_LIST_TO] + && !c->lists[OMP_LIST_LINK]) gfc_warning_now (0, "OMP DECLARE TARGET directive at %L with only " "DEVICE_TYPE clause is ignored", &old_loc); @@ -4903,8 +5096,7 @@ gfc_match_omp_context_selector_specification (gfc_omp_declare_variant *odv) match m; const char *selector_sets[] = { "construct", "device", "implementation", "user" }; - const int selector_set_count - = sizeof (selector_sets) / sizeof (*selector_sets); + const int selector_set_count = ARRAY_SIZE (selector_sets); int i; char buf[GFC_MAX_SYMBOL_LEN + 1]; @@ -5225,7 +5417,7 @@ gfc_check_omp_requires (gfc_namespace *ns, int ref_omp_requires) 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 " + "but does not set !$OMP REQUIRES REVERSE_OFFLOAD 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)) @@ -5412,10 +5604,6 @@ gfc_match_omp_requires (void) else goto error; - if (requires_clause & ~(OMP_REQ_ATOMIC_MEM_ORDER_MASK - | OMP_REQ_DYNAMIC_ALLOCATORS)) - 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; @@ -5654,7 +5842,8 @@ gfc_match_omp_taskwait (void) new_st.ext.omp_clauses = NULL; return MATCH_YES; } - return match_omp (EXEC_OMP_TASKWAIT, omp_mask (OMP_CLAUSE_DEPEND)); + return match_omp (EXEC_OMP_TASKWAIT, + omp_mask (OMP_CLAUSE_DEPEND) | OMP_CLAUSE_NOWAIT); } @@ -6283,7 +6472,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, "IN_REDUCTION", "TASK_REDUCTION", "DEVICE_RESIDENT", "LINK", "USE_DEVICE", "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR", - "NONTEMPORAL", "ALLOCATE" }; + "NONTEMPORAL", "ALLOCATE", "HAS_DEVICE_ADDR", "ENTER" }; STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM); if (omp_clauses == NULL) @@ -6492,6 +6681,8 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, for (list = 0; list < OMP_LIST_NUM; list++) for (n = omp_clauses->lists[list]; n; n = n->next) { + if (!n->sym) /* omp_all_memory. */ + continue; n->sym->mark = 0; n->sym->comp_mark = 0; if (n->sym->attr.flavor == FL_VARIABLE @@ -6783,8 +6974,10 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, gfc_error ("Cray pointee %qs in SHARED clause at %L", n->sym->name, &n->where); if (n->sym->attr.associate_var) - gfc_error ("ASSOCIATE name %qs in SHARED clause at %L", - n->sym->name, &n->where); + gfc_error ("Associate name %qs in SHARED clause at %L", + n->sym->attr.select_type_temporary + ? n->sym->assoc->target->symtree->n.sym->name + : n->sym->name, &n->where); if (omp_clauses->detach && n->sym == omp_clauses->detach->symtree->n.sym) gfc_error ("DETACH event handle %qs in SHARED clause at %L", @@ -6832,8 +7025,8 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, && n->u2.ns && !n->u2.ns->resolved) { n->u2.ns->resolved = 1; - for (gfc_symbol *sym = n->u2.ns->proc_name; sym; - sym = sym->tlink) + for (gfc_symbol *sym = n->u2.ns->omp_affinity_iterators; + sym; sym = sym->tlink) { gfc_constructor *c; c = gfc_constructor_first (sym->value->value.constructor); @@ -7072,10 +7265,16 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, case OMP_MAP_ALWAYS_TO: case OMP_MAP_ALLOC: break; + case OMP_MAP_TOFROM: + n->u.map_op = OMP_MAP_TO; + break; + case OMP_MAP_ALWAYS_TOFROM: + n->u.map_op = OMP_MAP_ALWAYS_TO; + break; default: gfc_error ("TARGET ENTER DATA with map-type other " - "than TO, or ALLOC on MAP clause at %L", - &n->where); + "than TO, TOFROM or ALLOC on MAP clause " + "at %L", &n->where); break; } break; @@ -7087,10 +7286,16 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, case OMP_MAP_RELEASE: case OMP_MAP_DELETE: break; + case OMP_MAP_TOFROM: + n->u.map_op = OMP_MAP_FROM; + break; + case OMP_MAP_ALWAYS_TOFROM: + n->u.map_op = OMP_MAP_ALWAYS_FROM; + break; default: gfc_error ("TARGET EXIT DATA with map-type other " - "than FROM, RELEASE, or DELETE on MAP " - "clause at %L", &n->where); + "than FROM, TOFROM, RELEASE, or DELETE on " + "MAP clause at %L", &n->where); break; } break; @@ -7132,6 +7337,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, n->sym->name, name, &n->where); } break; + case OMP_LIST_HAS_DEVICE_ADDR: case OMP_LIST_USE_DEVICE_PTR: case OMP_LIST_USE_DEVICE_ADDR: /* FIXME: Handle OMP_LIST_USE_DEVICE_PTR. */ @@ -7163,8 +7369,10 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, gfc_error ("Cray pointee %qs in %s clause at %L", n->sym->name, name, &n->where); if (n->sym->attr.associate_var) - gfc_error ("ASSOCIATE name %qs in %s clause at %L", - n->sym->name, name, &n->where); + gfc_error ("Associate name %qs in %s clause at %L", + n->sym->attr.select_type_temporary + ? n->sym->assoc->target->symtree->n.sym->name + : n->sym->name, name, &n->where); if (list != OMP_LIST_PRIVATE && is_reduction) { if (n->sym->attr.proc_pointer) @@ -7182,7 +7390,8 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, || code->op == EXEC_OACC_PARALLEL || code->op == EXEC_OACC_SERIAL)) check_array_not_assumed (n->sym, n->where, name); - else if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE) + else if (list != OMP_LIST_UNIFORM + && n->sym->as && 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 (n->sym->attr.in_namelist && !is_reduction) @@ -7347,28 +7556,38 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, break; case OMP_LIST_LINEAR: if (code - && n->u.linear_op != OMP_LINEAR_DEFAULT - && n->u.linear_op != linear_op) + && n->u.linear.op != OMP_LINEAR_DEFAULT + && n->u.linear.op != linear_op) { - gfc_error ("LINEAR clause modifier used on DO or SIMD" - " construct at %L", &n->where); - linear_op = n->u.linear_op; + if (n->u.linear.old_modifier) + { + gfc_error ("LINEAR clause modifier used on DO or " + "SIMD construct at %L", &n->where); + linear_op = n->u.linear.op; + } + else if (n->u.linear.op != OMP_LINEAR_VAL) + { + gfc_error ("LINEAR clause modifier other than VAL " + "used on DO or SIMD construct at %L", + &n->where); + linear_op = n->u.linear.op; + } } else if (omp_clauses->orderedc) gfc_error ("LINEAR clause specified together with " "ORDERED clause with argument at %L", &n->where); - else if (n->u.linear_op != OMP_LINEAR_REF + else if (n->u.linear.op != OMP_LINEAR_REF && n->sym->ts.type != BT_INTEGER) gfc_error ("LINEAR variable %qs must be INTEGER " "at %L", n->sym->name, &n->where); - else if ((n->u.linear_op == OMP_LINEAR_REF - || n->u.linear_op == OMP_LINEAR_UVAL) + else if ((n->u.linear.op == OMP_LINEAR_REF + || n->u.linear.op == OMP_LINEAR_UVAL) && n->sym->attr.value) gfc_error ("LINEAR dummy argument %qs with VALUE " "attribute with %s modifier at %L", n->sym->name, - n->u.linear_op == OMP_LINEAR_REF + n->u.linear.op == OMP_LINEAR_REF ? "REF" : "UVAL", &n->where); else if (n->expr) { @@ -7573,9 +7792,29 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, gfc_error ("%s must contain at least one MAP clause at %L", p, &code->loc); } - if (!openacc && omp_clauses->mergeable && omp_clauses->detach) - gfc_error ("%<DETACH%> clause at %L must not be used together with " - "%<MERGEABLE%> clause", &omp_clauses->detach->where); + + if (!openacc && omp_clauses->detach) + { + if (!gfc_resolve_expr (omp_clauses->detach) + || omp_clauses->detach->ts.type != BT_INTEGER + || omp_clauses->detach->ts.kind != gfc_c_intptr_kind + || omp_clauses->detach->rank != 0) + gfc_error ("%qs at %L should be a scalar of type " + "integer(kind=omp_event_handle_kind)", + omp_clauses->detach->symtree->n.sym->name, + &omp_clauses->detach->where); + else if (omp_clauses->detach->symtree->n.sym->attr.dimension > 0) + gfc_error ("The event handle at %L must not be an array element", + &omp_clauses->detach->where); + else if (omp_clauses->detach->symtree->n.sym->ts.type == BT_DERIVED + || omp_clauses->detach->symtree->n.sym->ts.type == BT_CLASS) + gfc_error ("The event handle at %L must not be part of " + "a derived type or class", &omp_clauses->detach->where); + + if (omp_clauses->mergeable) + gfc_error ("%<DETACH%> clause at %L must not be used together with " + "%<MERGEABLE%> clause", &omp_clauses->detach->where); + } } @@ -7660,9 +7899,16 @@ static bool is_scalar_intrinsic_expr (gfc_expr *expr, bool must_be_var, bool conv_ok) { if (must_be_var - && (expr->expr_type != EXPR_VARIABLE || !expr->symtree) - && (!conv_ok || !is_conversion (expr, true, true))) - return false; + && (expr->expr_type != EXPR_VARIABLE || !expr->symtree)) + { + if (!conv_ok) + return false; + gfc_expr *conv = is_conversion (expr, true, true); + if (!conv) + return false; + if (conv->expr_type != EXPR_VARIABLE || !conv->symtree) + return false; + } return (expr->rank == 0 && !gfc_is_coindexed (expr) && (expr->ts.type == BT_INTEGER @@ -7680,7 +7926,7 @@ resolve_omp_atomic (gfc_code *code) gfc_omp_atomic_op aop = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK); - gfc_code *stmt = NULL, *capture_stmt = NULL; + gfc_code *stmt = NULL, *capture_stmt = NULL, *tailing_stmt = NULL; gfc_expr *comp_cond = NULL; locus *loc = NULL; @@ -7705,6 +7951,7 @@ resolve_omp_atomic (gfc_code *code) if (next->op == EXEC_IF && next->block && next->block->op == EXEC_IF + && next->block->next && next->block->next->op == EXEC_ASSIGN) { comp_cond = next->block->expr1; @@ -7757,6 +8004,7 @@ resolve_omp_atomic (gfc_code *code) if (code->op == EXEC_IF && code->block && code->block->op == EXEC_IF + && code->block->next && code->block->next->op == EXEC_ASSIGN) { comp_cond = code->block->expr1; @@ -7816,7 +8064,8 @@ resolve_omp_atomic (gfc_code *code) stmt = code; capture_stmt = code->next; } - gcc_assert (!code->next->next); + /* Shall be NULL but can happen for invalid code. */ + tailing_stmt = code->next->next; } else { @@ -7824,7 +8073,8 @@ resolve_omp_atomic (gfc_code *code) stmt = code; if (!atomic_code->ext.omp_clauses->compare && stmt->op != EXEC_ASSIGN) goto unexpected; - gcc_assert (!code->next); + /* Shall be NULL but can happen for invalid code. */ + tailing_stmt = code->next; } if (comp_cond) @@ -7877,6 +8127,9 @@ resolve_omp_atomic (gfc_code *code) return; } + /* Should be diagnosed above already. */ + gcc_assert (tailing_stmt == NULL); + var = stmt->expr1->symtree->n.sym; stmt_expr2 = is_conversion (stmt->expr2, true, true); if (stmt_expr2 == NULL) @@ -8408,6 +8661,105 @@ gfc_resolve_omp_local_vars (gfc_namespace *ns) gfc_traverse_ns (ns, handle_local_var); } +/* CODE is an OMP loop construct. Return true if VAR matches an iteration + variable outer to level DEPTH. */ +static bool +is_outer_iteration_variable (gfc_code *code, int depth, gfc_symbol *var) +{ + int i; + gfc_code *do_code = code->block->next; + + for (i = 1; i < depth; i++) + { + gfc_symbol *ivar = do_code->ext.iterator->var->symtree->n.sym; + if (var == ivar) + return true; + do_code = do_code->block->next; + } + return false; +} + +/* CODE is an OMP loop construct. Return true if EXPR does not reference + any iteration variables outer to level DEPTH. */ +static bool +expr_is_invariant (gfc_code *code, int depth, gfc_expr *expr) +{ + int i; + gfc_code *do_code = code->block->next; + + for (i = 1; i < depth; i++) + { + gfc_symbol *ivar = do_code->ext.iterator->var->symtree->n.sym; + if (gfc_find_sym_in_expr (ivar, expr)) + return false; + do_code = do_code->block->next; + } + return true; +} + +/* CODE is an OMP loop construct. Return true if EXPR matches one of the + canonical forms for a bound expression. It may include references to + an iteration variable outer to level DEPTH; set OUTER_VARP if so. */ +static bool +bound_expr_is_canonical (gfc_code *code, int depth, gfc_expr *expr, + gfc_symbol **outer_varp) +{ + gfc_expr *expr2 = NULL; + + /* Rectangular case. */ + if (depth == 0 || expr_is_invariant (code, depth, expr)) + return true; + + /* Any simple variable that didn't pass expr_is_invariant must be + an outer_var. */ + if (expr->expr_type == EXPR_VARIABLE && expr->rank == 0) + { + *outer_varp = expr->symtree->n.sym; + return true; + } + + /* All other permitted forms are binary operators. */ + if (expr->expr_type != EXPR_OP) + return false; + + /* Check for plus/minus a loop invariant expr. */ + if (expr->value.op.op == INTRINSIC_PLUS + || expr->value.op.op == INTRINSIC_MINUS) + { + if (expr_is_invariant (code, depth, expr->value.op.op1)) + expr2 = expr->value.op.op2; + else if (expr_is_invariant (code, depth, expr->value.op.op2)) + expr2 = expr->value.op.op1; + else + return false; + } + else + expr2 = expr; + + /* Check for a product with a loop-invariant expr. */ + if (expr2->expr_type == EXPR_OP + && expr2->value.op.op == INTRINSIC_TIMES) + { + if (expr_is_invariant (code, depth, expr2->value.op.op1)) + expr2 = expr2->value.op.op2; + else if (expr_is_invariant (code, depth, expr2->value.op.op2)) + expr2 = expr2->value.op.op1; + else + return false; + } + + /* What's left must be a reference to an outer loop variable. */ + if (expr2->expr_type == EXPR_VARIABLE + && expr2->rank == 0 + && is_outer_iteration_variable (code, depth, expr2->symtree->n.sym)) + { + *outer_varp = expr2->symtree->n.sym; + return true; + } + + return false; +} + static void resolve_omp_do (gfc_code *code) { @@ -8526,8 +8878,15 @@ resolve_omp_do (gfc_code *code) if (collapse <= 0) collapse = 1; } + + /* While the spec defines the loop nest depth independently of the COLLAPSE + clause, in practice the middle end only pays attention to the COLLAPSE + depth and treats any further inner loops as the final-loop-body. So + here we also check canonical loop nest form only for the number of + outer loops specified by the COLLAPSE clause too. */ for (i = 1; i <= collapse; i++) { + gfc_symbol *start_var = NULL, *end_var = NULL; if (do_code->op == EXEC_DO_WHILE) { gfc_error ("%s cannot be a DO WHILE or DO without loop control " @@ -8568,26 +8927,43 @@ resolve_omp_do (gfc_code *code) "LINEAR at %L", name, &do_code->loc); break; } - if (i > 1) + if (is_outer_iteration_variable (code, i, dovar)) { - gfc_code *do_code2 = code->block->next; - int j; - - for (j = 1; j < i; j++) - { - gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym; - if (dovar == ivar - || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start) - || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end) - || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step)) - { - gfc_error ("%s collapsed loops don't form rectangular " - "iteration space at %L", name, &do_code->loc); - break; - } - do_code2 = do_code2->block->next; - } + gfc_error ("%s iteration variable used in more than one loop at %L", + name, &do_code->loc); + break; + } + else if (!bound_expr_is_canonical (code, i, + do_code->ext.iterator->start, + &start_var)) + { + gfc_error ("%s loop start expression not in canonical form at %L", + name, &do_code->loc); + break; + } + else if (!bound_expr_is_canonical (code, i, + do_code->ext.iterator->end, + &end_var)) + { + gfc_error ("%s loop end expression not in canonical form at %L", + name, &do_code->loc); + break; } + else if (start_var && end_var && start_var != end_var) + { + gfc_error ("%s loop bounds reference different " + "iteration variables at %L", name, &do_code->loc); + break; + } + else if (!expr_is_invariant (code, i, do_code->ext.iterator->step)) + { + gfc_error ("%s loop increment not in canonical form at %L", + name, &do_code->loc); + break; + } + if (start_var || end_var) + code->ext.omp_clauses->non_rectangular = 1; + for (c = do_code->next; c; c = c->next) if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE) { diff --git a/gcc/fortran/options.cc b/gcc/fortran/options.cc index d0fa634..08afb78 100644 --- a/gcc/fortran/options.cc +++ b/gcc/fortran/options.cc @@ -685,13 +685,6 @@ gfc_handle_option (size_t scode, const char *arg, HOST_WIDE_INT value, gfc_option.source_form = FORM_FREE; break; - case OPT_static_libgfortran: -#ifndef HAVE_LD_STATIC_DYNAMIC - gfc_fatal_error ("%<-static-libgfortran%> is not supported in this " - "configuration"); -#endif - break; - case OPT_fintrinsic_modules_path: case OPT_fintrinsic_modules_path_: diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc index db91829..0b4c596 100644 --- a/gcc/fortran/parse.cc +++ b/gcc/fortran/parse.cc @@ -454,7 +454,7 @@ decode_statement (void) case 'c': match ("call", gfc_match_call, ST_CALL); - match ("change team", gfc_match_change_team, ST_CHANGE_TEAM); + match ("change% team", gfc_match_change_team, ST_CHANGE_TEAM); match ("close", gfc_match_close, ST_CLOSE); match ("continue", gfc_match_continue, ST_CONTINUE); match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL); @@ -479,7 +479,7 @@ decode_statement (void) match ("else", gfc_match_else, ST_ELSE); match ("else where", gfc_match_elsewhere, ST_ELSEWHERE); match ("else if", gfc_match_elseif, ST_ELSEIF); - match ("error stop", gfc_match_error_stop, ST_ERROR_STOP); + match ("error% stop", gfc_match_error_stop, ST_ERROR_STOP); match ("enum , bind ( c )", gfc_match_enum, ST_ENUM); if (gfc_match_end (&st) == MATCH_YES) @@ -488,15 +488,15 @@ decode_statement (void) match ("entry% ", gfc_match_entry, ST_ENTRY); match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE); match ("external", gfc_match_external, ST_ATTR_DECL); - match ("event post", gfc_match_event_post, ST_EVENT_POST); - match ("event wait", gfc_match_event_wait, ST_EVENT_WAIT); + match ("event% post", gfc_match_event_post, ST_EVENT_POST); + match ("event% wait", gfc_match_event_wait, ST_EVENT_WAIT); break; case 'f': - match ("fail image", gfc_match_fail_image, ST_FAIL_IMAGE); + match ("fail% image", gfc_match_fail_image, ST_FAIL_IMAGE); match ("final", gfc_match_final_decl, ST_FINAL); match ("flush", gfc_match_flush, ST_FLUSH); - match ("form team", gfc_match_form_team, ST_FORM_TEAM); + match ("form% team", gfc_match_form_team, ST_FORM_TEAM); match ("format", gfc_match_format, ST_FORMAT); break; @@ -562,16 +562,16 @@ decode_statement (void) match ("save", gfc_match_save, ST_ATTR_DECL); match ("static", gfc_match_static, ST_ATTR_DECL); match ("submodule", gfc_match_submodule, ST_SUBMODULE); - match ("sync all", gfc_match_sync_all, ST_SYNC_ALL); - match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES); - match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY); - match ("sync team", gfc_match_sync_team, ST_SYNC_TEAM); + match ("sync% all", gfc_match_sync_all, ST_SYNC_ALL); + match ("sync% images", gfc_match_sync_images, ST_SYNC_IMAGES); + match ("sync% memory", gfc_match_sync_memory, ST_SYNC_MEMORY); + match ("sync% team", gfc_match_sync_team, ST_SYNC_TEAM); break; case 't': match ("target", gfc_match_target, ST_ATTR_DECL); match ("type", gfc_match_derived_decl, ST_DERIVED_DECL); - match ("type is", gfc_match_type_is, ST_TYPE_IS); + match ("type% is", gfc_match_type_is, ST_TYPE_IS); break; case 'u': @@ -1168,7 +1168,8 @@ decode_omp_directive (void) } switch (ret) { - case ST_OMP_DECLARE_TARGET: + /* Set omp_target_seen; exclude ST_OMP_DECLARE_TARGET. + FIXME: Get clarification, cf. OpenMP Spec Issue #3240. */ case ST_OMP_TARGET: case ST_OMP_TARGET_DATA: case ST_OMP_TARGET_ENTER_DATA: @@ -4924,6 +4925,24 @@ parse_associate (void) in case of association to a derived-type. */ sym->ts = a->target->ts; + /* Don’t share the character length information between associate + variable and target if the length is not a compile-time constant, + as we don’t want to touch some other character length variable when + we try to initialize the associate variable’s character length + variable. + We do it here rather than later so that expressions referencing the + associate variable will automatically have the correctly setup length + information. If we did it at resolution stage the expressions would + use the original length information, and the variable a new different + one, but only the latter one would be correctly initialized at + translation stage, and the former one would need some additional setup + there. */ + if (sym->ts.type == BT_CHARACTER + && sym->ts.u.cl + && !(sym->ts.u.cl->length + && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)) + sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); + /* Check if the target expression is array valued. This cannot always be done by looking at target.rank, because that might not have been set yet. Therefore traverse the chain of refs, looking for the last @@ -6861,11 +6880,14 @@ done: /* Fixup for external procedures and resolve 'omp requires'. */ int omp_requires; + bool omp_target_seen; omp_requires = 0; + omp_target_seen = false; 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; + omp_target_seen |= gfc_current_ns->omp_target_seen; gfc_check_externals (gfc_current_ns); } for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns; @@ -6890,6 +6912,22 @@ done: break; } + if (omp_target_seen) + omp_requires_mask = (enum omp_requires) (omp_requires_mask + | OMP_REQUIRES_TARGET_USED); + if (omp_requires & OMP_REQ_REVERSE_OFFLOAD) + omp_requires_mask = (enum omp_requires) (omp_requires_mask + | OMP_REQUIRES_REVERSE_OFFLOAD); + if (omp_requires & OMP_REQ_UNIFIED_ADDRESS) + omp_requires_mask = (enum omp_requires) (omp_requires_mask + | OMP_REQUIRES_UNIFIED_ADDRESS); + if (omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY) + omp_requires_mask + = (enum omp_requires) (omp_requires_mask + | OMP_REQUIRES_UNIFIED_SHARED_MEMORY); + if (omp_requires & OMP_REQ_DYNAMIC_ALLOCATORS) + omp_requires_mask = (enum omp_requires) (omp_requires_mask + | OMP_REQUIRES_DYNAMIC_ALLOCATORS); /* Do the parse tree dump. */ gfc_current_ns = flag_dump_fortran_original ? gfc_global_ns_list : NULL; diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc index 3f01f67..19f2e78 100644 --- a/gcc/fortran/primary.cc +++ b/gcc/fortran/primary.cc @@ -45,11 +45,11 @@ match_kind_param (int *kind, int *is_iso_c) *is_iso_c = 0; - m = gfc_match_small_literal_int (kind, NULL); + m = gfc_match_small_literal_int (kind, NULL, false); if (m != MATCH_NO) return m; - m = gfc_match_name (name); + m = gfc_match_name (name, false); if (m != MATCH_YES) return m; @@ -95,7 +95,7 @@ get_kind (int *is_iso_c) *is_iso_c = 0; - if (gfc_match_char ('_') != MATCH_YES) + if (gfc_match_char ('_', false) != MATCH_YES) return -2; m = match_kind_param (&kind, is_iso_c); @@ -1074,17 +1074,9 @@ match_string_constant (gfc_expr **result) c = gfc_next_char (); } - if (c == ' ') - { - gfc_gobble_whitespace (); - c = gfc_next_char (); - } - if (c != '_') goto no_match; - gfc_gobble_whitespace (); - c = gfc_next_char (); if (c != '\'' && c != '"') goto no_match; diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 835a478..ca11475 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -1288,15 +1288,19 @@ resolve_structure_cons (gfc_expr *expr, int init) } } - cons = gfc_constructor_first (expr->value.constructor); - /* A constructor may have references if it is the result of substituting a parameter variable. In this case we just pull out the component we want. */ if (expr->ref) comp = expr->ref->u.c.sym->components; - else + else if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS + || expr->ts.type == BT_UNION) + && expr->ts.u.derived) comp = expr->ts.u.derived->components; + else + return false; + + cons = gfc_constructor_first (expr->value.constructor); for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons)) { @@ -1371,11 +1375,22 @@ resolve_structure_cons (gfc_expr *expr, int init) && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT - && cons->expr->rank != 0 && mpz_cmp (cons->expr->ts.u.cl->length->value.integer, comp->ts.u.cl->length->value.integer) != 0) { + if (comp->attr.pointer) + { + HOST_WIDE_INT la, lb; + la = gfc_mpz_get_hwi (comp->ts.u.cl->length->value.integer); + lb = gfc_mpz_get_hwi (cons->expr->ts.u.cl->length->value.integer); + gfc_error ("Unequal character lengths (%wd/%wd) for pointer " + "component %qs in constructor at %L", + la, lb, comp->name, &cons->expr->where); + t = false; + } + if (cons->expr->expr_type == EXPR_VARIABLE + && cons->expr->rank != 0 && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER) { /* Wrap the parameter in an array constructor (EXPR_ARRAY) @@ -1472,6 +1487,8 @@ resolve_structure_cons (gfc_expr *expr, int init) t = false; break; }; + if (cons->expr->shape == NULL) + continue; mpz_set_ui (len, 1); mpz_add (len, len, comp->as->upper[n]->value.integer); mpz_sub (len, len, comp->as->lower[n]->value.integer); @@ -2380,8 +2397,9 @@ resolve_elemental_actual (gfc_expr *expr, gfc_code *c) if (rank > 0 && esym && expr == NULL) for (eformal = esym->formal, arg = arg0; arg && eformal; arg = arg->next, eformal = eformal->next) - if ((eformal->sym->attr.intent == INTENT_OUT - || eformal->sym->attr.intent == INTENT_INOUT) + if (eformal->sym + && (eformal->sym->attr.intent == INTENT_OUT + || eformal->sym->attr.intent == INTENT_INOUT) && arg->expr && arg->expr->rank == 0) { gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of " @@ -4958,7 +4976,7 @@ gfc_resolve_dim_arg (gfc_expr *dim) static void resolve_assoc_var (gfc_symbol* sym, bool resolve_target); -static void +static bool find_array_spec (gfc_expr *e) { gfc_array_spec *as; @@ -4986,7 +5004,11 @@ find_array_spec (gfc_expr *e) { case REF_ARRAY: if (as == NULL) - gfc_internal_error ("find_array_spec(): Missing spec"); + { + gfc_error ("Invalid array reference of a non-array entity at %L", + &ref->u.ar.where); + return false; + } ref->u.ar.as = as; as = NULL; @@ -5010,6 +5032,8 @@ find_array_spec (gfc_expr *e) if (as != NULL) gfc_internal_error ("find_array_spec(): unused as(2)"); + + return true; } @@ -5328,7 +5352,8 @@ gfc_resolve_ref (gfc_expr *expr) for (ref = expr->ref; ref; ref = ref->next) if (ref->type == REF_ARRAY && ref->u.ar.as == NULL) { - find_array_spec (expr); + if (!find_array_spec (expr)) + return false; break; } @@ -8090,12 +8115,13 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec) goto failure; case DIMEN_RANGE: - if (ar->start[i] == 0 || ar->end[i] == 0) + /* F2018:R937: + * allocate-coshape-spec is [ lower-bound-expr : ] upper-bound-expr + */ + if (ar->start[i] == 0 || ar->end[i] == 0 || ar->stride[i] != NULL) { - /* If ar->stride[i] is NULL, we issued a previous error. */ - if (ar->stride[i] == NULL) - gfc_error ("Bad array specification in ALLOCATE statement " - "at %L", &e->where); + gfc_error ("Bad coarray specification in ALLOCATE statement " + "at %L", &e->where); goto failure; } else if (gfc_dep_compare_expr (ar->start[i], ar->end[i]) == 1) @@ -9226,8 +9252,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) if (!sym->ts.u.cl) sym->ts.u.cl = target->ts.u.cl; - if (sym->ts.deferred && target->expr_type == EXPR_VARIABLE - && target->symtree->n.sym->attr.dummy + if (sym->ts.deferred && sym->ts.u.cl == target->ts.u.cl) { sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL); @@ -9246,8 +9271,11 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) || sym->ts.u.cl->length->expr_type != EXPR_CONSTANT) && target->expr_type != EXPR_VARIABLE) { - sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL); - sym->ts.deferred = 1; + if (!sym->ts.deferred) + { + sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL); + sym->ts.deferred = 1; + } /* This is reset in trans-stmt.cc after the assignment of the target expression to the associate name. */ @@ -11534,7 +11562,7 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns) || comp1->attr.proc_pointer) continue; - /* Make an assigment for this component. */ + /* Make an assignment for this component. */ this_code = build_assignment (EXEC_ASSIGN, (*code)->expr1, (*code)->expr2, comp1, comp2, (*code)->loc); @@ -11810,6 +11838,23 @@ deferred_op_assign (gfc_code **code, gfc_namespace *ns) } +static bool +check_team (gfc_expr *team, const char *intrinsic) +{ + if (team->rank != 0 + || team->ts.type != BT_DERIVED + || team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV + || team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE) + { + gfc_error ("TEAM argument to %qs at %L must be a scalar expression " + "of type TEAM_TYPE", intrinsic, &team->where); + return false; + } + + return true; +} + + /* Given a block of code, recursively resolve everything pointed to by this code block. */ @@ -11943,8 +11988,17 @@ start: case EXEC_END_NESTED_BLOCK: case EXEC_CYCLE: case EXEC_PAUSE: + break; + case EXEC_STOP: case EXEC_ERROR_STOP: + if (code->expr2 != NULL + && (code->expr2->ts.type != BT_LOGICAL + || code->expr2->rank != 0)) + gfc_error ("QUIET specifier at %L must be a scalar LOGICAL", + &code->expr2->where); + break; + case EXEC_EXIT: case EXEC_CONTINUE: case EXEC_DT_END: @@ -11969,10 +12023,25 @@ start: break; case EXEC_FAIL_IMAGE: + break; + case EXEC_FORM_TEAM: + if (code->expr1 != NULL + && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank)) + gfc_error ("TEAM NUMBER argument to FORM TEAM at %L must be " + "a scalar INTEGER", &code->expr1->where); + check_team (code->expr2, "FORM TEAM"); + break; + case EXEC_CHANGE_TEAM: + check_team (code->expr1, "CHANGE TEAM"); + break; + case EXEC_END_TEAM: + break; + case EXEC_SYNC_TEAM: + check_team (code->expr1, "SYNC TEAM"); break; case EXEC_ENTRY: @@ -15121,7 +15190,10 @@ resolve_fl_derived (gfc_symbol *sym) /* Nothing more to do for unlimited polymorphic entities. */ if (data->ts.u.derived->attr.unlimited_polymorphic) - return true; + { + add_dt_to_dt_list (sym); + return true; + } else if (vptr->ts.u.derived == NULL) { gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived); @@ -15440,6 +15512,13 @@ resolve_symbol (gfc_symbol *sym) if (sym->attr.unlimited_polymorphic) return; + if (UNLIKELY (flag_openmp && strcmp (sym->name, "omp_all_memory") == 0)) + { + gfc_error ("%<omp_all_memory%>, declared at %L, may only be used in " + "the OpenMP DEPEND clause", &sym->declared_at); + return; + } + if (sym->attr.flavor == FL_UNKNOWN || (sym->attr.flavor == FL_PROCEDURE && !sym->attr.intrinsic && !sym->attr.generic && !sym->attr.external diff --git a/gcc/fortran/scanner.cc b/gcc/fortran/scanner.cc index 4df6576..2dff251 100644 --- a/gcc/fortran/scanner.cc +++ b/gcc/fortran/scanner.cc @@ -409,9 +409,7 @@ add_path_to_list (gfc_directorylist **list, const char *path, *list = dir; dir->use_for_modules = use_for_modules; dir->warn = warn; - dir->path = XCNEWVEC (char, strlen (p) + 2); - strcpy (dir->path, p); - strcat (dir->path, "/"); /* make '/' last character */ + dir->path = xstrdup (p); } /* defer_warn is set to true while parsing the commandline. */ @@ -476,8 +474,9 @@ open_included_file (const char *name, gfc_directorylist *list, if (module && !p->use_for_modules) continue; - fullname = (char *) alloca(strlen (p->path) + strlen (name) + 1); + fullname = (char *) alloca(strlen (p->path) + strlen (name) + 2); strcpy (fullname, p->path); + strcat (fullname, "/"); strcat (fullname, name); f = gfc_open_file (fullname); @@ -1915,7 +1914,7 @@ load_line (FILE *input, gfc_char_t **pbuf, int *pbuflen, const int *first_char) /* For truncation and tab warnings, set seen_comment to false if one has either an OpenMP or OpenACC directive - or a !GCC$ attribute. If - OpenMP is enabled, use '!$' as as conditional compilation sentinel + OpenMP is enabled, use '!$' as conditional compilation sentinel and OpenMP directive ('!$omp'). */ if (seen_comment && first_comment && flag_openmp && comment_ix + 1 == i && c == '$') diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc index 3881370..f992c31 100644 --- a/gcc/fortran/simplify.cc +++ b/gcc/fortran/simplify.cc @@ -233,6 +233,18 @@ is_constant_array_expr (gfc_expr *e) if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e)) return false; + /* A non-zero-sized constant array shall have a non-empty constructor. */ + if (e->rank > 0 && e->shape != NULL && e->value.constructor == NULL) + { + mpz_init_set_ui (size, 1); + for (int j = 0; j < e->rank; j++) + mpz_mul (size, size, e->shape[j]); + bool not_size0 = (mpz_cmp_si (size, 0) != 0); + mpz_clear (size); + if (not_size0) + return false; + } + for (c = gfc_constructor_first (e->value.constructor); c; c = gfc_constructor_next (c)) if (c->expr->expr_type != EXPR_CONSTANT @@ -1644,6 +1656,9 @@ gfc_simplify_btest (gfc_expr *e, gfc_expr *bit) if (e->expr_type != EXPR_CONSTANT || bit->expr_type != EXPR_CONSTANT) return NULL; + if (!gfc_check_bitfcn (e, bit)) + return &gfc_bad_expr; + if (gfc_extract_int (bit, &b) || b < 0) return gfc_get_logical_expr (gfc_default_logical_kind, &e->where, false); @@ -2134,6 +2149,7 @@ gfc_simplify_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim) resultvec = XCNEWVEC (gfc_expr *, arraysize); + sstride[0] = 0; extent[0] = 1; count[0] = 0; @@ -2572,6 +2588,9 @@ gfc_simplify_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, if (arraysize == 0) goto final; + if (array->shape == NULL) + goto final; + arrayvec = XCNEWVEC (gfc_expr *, arraysize); array_ctor = gfc_constructor_first (array->value.constructor); for (i = 0; i < arraysize; i++) @@ -3089,6 +3108,10 @@ gfc_simplify_extends_type_of (gfc_expr *a, gfc_expr *mold) if (UNLIMITED_POLY (a) || UNLIMITED_POLY (mold)) return NULL; + if ((a->ts.type == BT_CLASS && !gfc_expr_attr (a).class_ok) + || (mold->ts.type == BT_CLASS && !gfc_expr_attr (mold).class_ok)) + return NULL; + /* Return .false. if the dynamic type can never be an extension. */ if ((a->ts.type == BT_CLASS && mold->ts.type == BT_CLASS && !gfc_type_is_extension_of @@ -3349,11 +3372,21 @@ gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y) if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) return NULL; + if (!gfc_check_bitfcn (x, y)) + return &gfc_bad_expr; + gfc_extract_int (y, &pos); k = gfc_validate_kind (x->ts.type, x->ts.kind, false); result = gfc_copy_expr (x); + /* Drop any separate memory representation of x to avoid potential + inconsistencies in result. */ + if (result->representation.string) + { + free (result->representation.string); + result->representation.string = NULL; + } convert_mpz_to_unsigned (result->value.integer, gfc_integer_kinds[k].bit_size); @@ -3380,6 +3413,9 @@ gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z) || z->expr_type != EXPR_CONSTANT) return NULL; + if (!gfc_check_ibits (x, y, z)) + return &gfc_bad_expr; + gfc_extract_int (y, &pos); gfc_extract_int (z, &len); @@ -3434,11 +3470,21 @@ gfc_simplify_ibset (gfc_expr *x, gfc_expr *y) if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) return NULL; + if (!gfc_check_bitfcn (x, y)) + return &gfc_bad_expr; + gfc_extract_int (y, &pos); k = gfc_validate_kind (x->ts.type, x->ts.kind, false); result = gfc_copy_expr (x); + /* Drop any separate memory representation of x to avoid potential + inconsistencies in result. */ + if (result->representation.string) + { + free (result->representation.string); + result->representation.string = NULL; + } convert_mpz_to_unsigned (result->value.integer, gfc_integer_kinds[k].bit_size); @@ -3499,17 +3545,15 @@ gfc_expr * gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind) { gfc_expr *result; - int back, len, lensub; - int i, j, k, count, index = 0, start; + bool back; + HOST_WIDE_INT len, lensub, start, last, i, index = 0; + int k, delta; if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT || ( b != NULL && b->expr_type != EXPR_CONSTANT)) return NULL; - if (b != NULL && b->value.logical != 0) - back = 1; - else - back = 0; + back = (b != NULL && b->value.logical != 0); k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind); if (k == -1) @@ -3526,111 +3570,40 @@ gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind) return result; } - if (back == 0) + if (lensub == 0) { - if (lensub == 0) - { - mpz_set_si (result->value.integer, 1); - return result; - } - else if (lensub == 1) - { - for (i = 0; i < len; i++) - { - for (j = 0; j < lensub; j++) - { - if (y->value.character.string[j] - == x->value.character.string[i]) - { - index = i + 1; - goto done; - } - } - } - } + if (back) + index = len + 1; else - { - for (i = 0; i < len; i++) - { - for (j = 0; j < lensub; j++) - { - if (y->value.character.string[j] - == x->value.character.string[i]) - { - start = i; - count = 0; - - for (k = 0; k < lensub; k++) - { - if (y->value.character.string[k] - == x->value.character.string[k + start]) - count++; - } - - if (count == lensub) - { - index = start + 1; - goto done; - } - } - } - } - } + index = 1; + goto done; + } + if (!back) + { + last = len + 1 - lensub; + start = 0; + delta = 1; } else { - if (lensub == 0) - { - mpz_set_si (result->value.integer, len + 1); - return result; - } - else if (lensub == 1) + last = -1; + start = len - lensub; + delta = -1; + } + + for (; start != last; start += delta) + { + for (i = 0; i < lensub; i++) { - for (i = 0; i < len; i++) - { - for (j = 0; j < lensub; j++) - { - if (y->value.character.string[j] - == x->value.character.string[len - i]) - { - index = len - i + 1; - goto done; - } - } - } + if (x->value.character.string[start + i] + != y->value.character.string[i]) + break; } - else + if (i == lensub) { - for (i = 0; i < len; i++) - { - for (j = 0; j < lensub; j++) - { - if (y->value.character.string[j] - == x->value.character.string[len - i]) - { - start = len - i; - if (start <= len - lensub) - { - count = 0; - for (k = 0; k < lensub; k++) - if (y->value.character.string[k] - == x->value.character.string[k + start]) - count++; - - if (count == lensub) - { - index = start + 1; - goto done; - } - } - else - { - continue; - } - } - } - } + index = start + 1; + goto done; } } @@ -8162,7 +8135,18 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) set even for array expressions, in order to pass this information into gfc_target_interpret_expr. */ if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element)) - result->value.character.length = mold_element->value.character.length; + { + result->value.character.length = mold_element->value.character.length; + + /* Let the typespec of the result inherit the string length. + This is crucial if a resulting array has size zero. */ + if (mold_element->ts.u.cl->length) + result->ts.u.cl->length = gfc_copy_expr (mold_element->ts.u.cl->length); + else + result->ts.u.cl->length = + gfc_get_int_expr (gfc_charlen_int_kind, NULL, + mold_element->value.character.length); + } /* Set the number of elements in the result, and determine its size. */ @@ -8410,7 +8394,7 @@ gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim, return NULL; /* If no coarray argument has been passed or when the first argument - is actually a distance argment. */ + is actually a distance argument. */ if (coarray == NULL || !gfc_is_coarray (coarray)) { gfc_expr *result; diff --git a/gcc/fortran/target-memory.cc b/gcc/fortran/target-memory.cc index 361907b..7ce7d73 100644 --- a/gcc/fortran/target-memory.cc +++ b/gcc/fortran/target-memory.cc @@ -365,7 +365,8 @@ gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer, static size_t -interpret_array (unsigned char *buffer, size_t buffer_size, gfc_expr *result) +interpret_array (unsigned char *buffer, size_t buffer_size, gfc_expr *result, + bool convert_widechar) { gfc_constructor_base base = NULL; size_t array_size = 1; @@ -390,7 +391,7 @@ interpret_array (unsigned char *buffer, size_t buffer_size, gfc_expr *result) gfc_constructor_append_expr (&base, e, &result->where); ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e, - true); + convert_widechar); } result->value.constructor = base; @@ -580,7 +581,7 @@ gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size, gfc_expr *result, bool convert_widechar) { if (result->expr_type == EXPR_ARRAY) - return interpret_array (buffer, buffer_size, result); + return interpret_array (buffer, buffer_size, result, convert_widechar); switch (result->ts.type) { diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 2f0c8a4..0513495 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -172,7 +172,7 @@ static tree gfc_get_cfi_dim_item (tree desc, tree idx, unsigned field_idx) { tree tmp = gfc_get_cfi_descriptor_field (desc, CFI_FIELD_DIM); - tmp = gfc_build_array_ref (tmp, idx, NULL); + tmp = gfc_build_array_ref (tmp, idx, NULL_TREE, true); tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), field_idx); gcc_assert (field != NULL_TREE); return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), @@ -424,7 +424,7 @@ gfc_conv_descriptor_dimension (tree desc, tree dim) tmp = gfc_get_descriptor_dimension (desc); - return gfc_build_array_ref (tmp, dim, NULL); + return gfc_build_array_ref (tmp, dim, NULL_TREE, true); } @@ -3664,10 +3664,52 @@ build_class_array_ref (gfc_se *se, tree base, tree index) } +/* Indicates that the tree EXPR is a reference to an array that can’t + have any negative stride. */ + +static bool +non_negative_strides_array_p (tree expr) +{ + if (expr == NULL_TREE) + return false; + + tree type = TREE_TYPE (expr); + if (POINTER_TYPE_P (type)) + type = TREE_TYPE (type); + + if (TYPE_LANG_SPECIFIC (type)) + { + gfc_array_kind array_kind = GFC_TYPE_ARRAY_AKIND (type); + + if (array_kind == GFC_ARRAY_ALLOCATABLE + || array_kind == GFC_ARRAY_ASSUMED_SHAPE_CONT) + return true; + } + + /* An array with descriptor can have negative strides. + We try to be conservative and return false by default here + if we don’t recognize a contiguous array instead of + returning false if we can identify a non-contiguous one. */ + if (!GFC_ARRAY_TYPE_P (type)) + return false; + + /* If the array was originally a dummy with a descriptor, strides can be + negative. */ + if (DECL_P (expr) + && DECL_LANG_SPECIFIC (expr) + && GFC_DECL_SAVED_DESCRIPTOR (expr) + && GFC_DECL_SAVED_DESCRIPTOR (expr) != expr) + return non_negative_strides_array_p (GFC_DECL_SAVED_DESCRIPTOR (expr)); + + return true; +} + + /* Build a scalarized reference to an array. */ static void -gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar) +gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar, + bool tmp_array = false) { gfc_array_info *info; tree decl = NULL_TREE; @@ -3717,7 +3759,10 @@ gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar) decl = info->descriptor; } - se->expr = gfc_build_array_ref (base, index, decl); + bool non_negative_stride = tmp_array + || non_negative_strides_array_p (info->descriptor); + se->expr = gfc_build_array_ref (base, index, decl, + non_negative_stride); } @@ -3727,7 +3772,7 @@ void gfc_conv_tmp_array_ref (gfc_se * se) { se->string_length = se->ss->info->string_length; - gfc_conv_scalarized_array_ref (se, NULL); + gfc_conv_scalarized_array_ref (se, NULL, true); gfc_advance_se_ss_chain (se); } @@ -3779,7 +3824,9 @@ build_array_ref (tree desc, tree offset, tree decl, tree vptr) tmp = gfc_conv_array_data (desc); tmp = build_fold_indirect_ref_loc (input_location, tmp); - tmp = gfc_build_array_ref (tmp, offset, decl, vptr); + tmp = gfc_build_array_ref (tmp, offset, decl, + non_negative_strides_array_p (desc), + vptr); return tmp; } @@ -6267,10 +6314,17 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr) else gfc_conv_structure (&se, expr, 1); - CONSTRUCTOR_APPEND_ELT (v, build2 (RANGE_EXPR, gfc_array_index_type, - TYPE_MIN_VALUE (TYPE_DOMAIN (type)), - TYPE_MAX_VALUE (TYPE_DOMAIN (type))), - se.expr); + if (tree_int_cst_lt (TYPE_MAX_VALUE (TYPE_DOMAIN (type)), + TYPE_MIN_VALUE (TYPE_DOMAIN (type)))) + break; + else if (tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (type)), + TYPE_MAX_VALUE (TYPE_DOMAIN (type)))) + range = TYPE_MIN_VALUE (TYPE_DOMAIN (type)); + else + range = build2 (RANGE_EXPR, gfc_array_index_type, + TYPE_MIN_VALUE (TYPE_DOMAIN (type)), + TYPE_MAX_VALUE (TYPE_DOMAIN (type))); + CONSTRUCTOR_APPEND_ELT (v, range, se.expr); break; case EXPR_ARRAY: @@ -7716,7 +7770,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) lse.ss = loop.temp_ss; rse.ss = ss; - gfc_conv_scalarized_array_ref (&lse, NULL); + gfc_conv_tmp_array_ref (&lse); if (expr->ts.type == BT_CHARACTER) { gfc_conv_expr (&rse, expr); @@ -9102,6 +9156,10 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, continue; } + /* Do not broadcast a caf_token. These are local to the image. */ + if (attr->caf_token) + continue; + add_when_allocated = NULL_TREE; if (cmp_has_alloc_comps && !c->attr.pointer && !c->attr.proc_pointer) @@ -9134,10 +9192,13 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, if (attr->dimension) { tmp = gfc_get_element_type (TREE_TYPE (comp)); - ubound = gfc_full_array_size (&tmpblock, comp, - c->ts.type == BT_CLASS - ? CLASS_DATA (c)->as->rank - : c->as->rank); + if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp))) + ubound = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (comp)); + else + ubound = gfc_full_array_size (&tmpblock, comp, + c->ts.type == BT_CLASS + ? CLASS_DATA (c)->as->rank + : c->as->rank); } else { @@ -9145,26 +9206,39 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, ubound = build_int_cst (gfc_array_index_type, 1); } - cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node, - &ubound, 1, - GFC_ARRAY_ALLOCATABLE, false); + /* Treat strings like arrays. Or the other way around, do not + * generate an additional array layer for scalar components. */ + if (attr->dimension || c->ts.type == BT_CHARACTER) + { + cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node, + &ubound, 1, + GFC_ARRAY_ALLOCATABLE, false); - cdesc = gfc_create_var (cdesc, "cdesc"); - DECL_ARTIFICIAL (cdesc) = 1; + cdesc = gfc_create_var (cdesc, "cdesc"); + DECL_ARTIFICIAL (cdesc) = 1; - gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc), - gfc_get_dtype_rank_type (1, tmp)); - gfc_conv_descriptor_lbound_set (&tmpblock, cdesc, - gfc_index_zero_node, - gfc_index_one_node); - gfc_conv_descriptor_stride_set (&tmpblock, cdesc, - gfc_index_zero_node, - gfc_index_one_node); - gfc_conv_descriptor_ubound_set (&tmpblock, cdesc, - gfc_index_zero_node, ubound); + gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc), + gfc_get_dtype_rank_type (1, tmp)); + gfc_conv_descriptor_lbound_set (&tmpblock, cdesc, + gfc_index_zero_node, + gfc_index_one_node); + gfc_conv_descriptor_stride_set (&tmpblock, cdesc, + gfc_index_zero_node, + gfc_index_one_node); + gfc_conv_descriptor_ubound_set (&tmpblock, cdesc, + gfc_index_zero_node, ubound); + } + else + /* Prevent warning. */ + cdesc = NULL_TREE; if (attr->dimension) - comp = gfc_conv_descriptor_data_get (comp); + { + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp))) + comp = gfc_conv_descriptor_data_get (comp); + else + comp = gfc_build_addr_expr (NULL_TREE, comp); + } else { gfc_se se; @@ -9172,14 +9246,18 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, gfc_init_se (&se, NULL); comp = gfc_conv_scalar_to_descriptor (&se, comp, - c->ts.type == BT_CLASS - ? CLASS_DATA (c)->attr - : c->attr); - comp = gfc_build_addr_expr (NULL_TREE, comp); + c->ts.type == BT_CLASS + ? CLASS_DATA (c)->attr + : c->attr); + if (c->ts.type == BT_CHARACTER) + comp = gfc_build_addr_expr (NULL_TREE, comp); gfc_add_block_to_block (&tmpblock, &se.pre); } - gfc_conv_descriptor_data_set (&tmpblock, cdesc, comp); + if (attr->dimension || c->ts.type == BT_CHARACTER) + gfc_conv_descriptor_data_set (&tmpblock, cdesc, comp); + else + cdesc = comp; tree fndecl; diff --git a/gcc/fortran/trans-common.cc b/gcc/fortran/trans-common.cc index 7b4d198..7c8cba0 100644 --- a/gcc/fortran/trans-common.cc +++ b/gcc/fortran/trans-common.cc @@ -338,6 +338,13 @@ build_field (segment_info *h, tree union_type, record_layout_info rli) h->field = field; } +#if !defined (NO_DOT_IN_LABEL) +#define GFC_EQUIV_FMT "equiv.%d" +#elif !defined (NO_DOLLAR_IN_LABEL) +#define GFC_EQUIV_FMT "_Equiv$%d" +#else +#define GFC_EQUIV_FMT "_Equiv_%d" +#endif /* Get storage for local equivalence. */ @@ -356,7 +363,7 @@ build_equiv_decl (tree union_type, bool is_init, bool is_saved, bool is_auto) return decl; } - snprintf (name, sizeof (name), "equiv.%d", serial++); + snprintf (name, sizeof (name), GFC_EQUIV_FMT, serial++); decl = build_decl (input_location, VAR_DECL, get_identifier (name), union_type); DECL_ARTIFICIAL (decl) = 1; diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index 1112ca9..908a4c6 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -647,6 +647,9 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym) && sym->ns->proc_name->attr.flavor == FL_LABEL) /* This is a BLOCK construct. */ add_decl_as_local (decl); + else if (sym->ns->omp_affinity_iterators) + /* This is a block-local iterator. */ + add_decl_as_local (decl); else gfc_add_decl_to_parent_function (decl); } @@ -6471,7 +6474,7 @@ gfc_generate_return (void) NULL_TREE, and a 'return' is generated without a variable. The following generates a 'return __result_XXX' where XXX is the function name. */ - if (sym == sym->result && sym->attr.function) + if (sym == sym->result && sym->attr.function && !flag_f2c) { result = gfc_get_fake_result_decl (sym, 0); result = fold_build2_loc (input_location, MODIFY_EXPR, diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index eb6a78c..850007f 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -1777,7 +1777,7 @@ trans_scalar_class_assign (stmtblock_t *block, gfc_se *lse, gfc_se *rse) bool not_call_expr = TREE_CODE (rse->expr) != CALL_EXPR; bool not_lhs_array_type; - /* Temporaries arising from depencies in assignment get cast as a + /* Temporaries arising from dependencies in assignment get cast as a character type of the dynamic size of the rhs. Use the vptr copy for this case. */ tmp = TREE_TYPE (lse->expr); @@ -2612,7 +2612,7 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, /* For BIND(C), a BT_CHARACTER is not an ARRAY_TYPE. */ if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE) { - tmp = gfc_build_array_ref (tmp, start.expr, NULL); + tmp = gfc_build_array_ref (tmp, start.expr, NULL_TREE, true); se->expr = gfc_build_addr_expr (type, tmp); } } @@ -2805,9 +2805,9 @@ conv_parent_component_references (gfc_se * se, gfc_ref * ref) dt = ref->u.c.sym; c = ref->u.c.component; - /* Return if the component is in the parent type. */ + /* Return if the component is in this type, i.e. not in the parent type. */ for (cmp = dt->components; cmp; cmp = cmp->next) - if (strcmp (c->name, cmp->name) == 0) + if (c == cmp) return; /* Build a gfc_ref to recursively call gfc_conv_component_ref. */ @@ -2867,6 +2867,8 @@ tree gfc_maybe_dereference_var (gfc_symbol *sym, tree var, bool descriptor_only_p, bool is_classarray) { + if (!POINTER_TYPE_P (TREE_TYPE (var))) + return var; if (is_CFI_desc (sym, NULL)) return build_fold_indirect_ref_loc (input_location, var); @@ -2934,7 +2936,7 @@ gfc_maybe_dereference_var (gfc_symbol *sym, tree var, bool descriptor_only_p, || CLASS_DATA (sym)->attr.class_pointer)) var = build_fold_indirect_ref_loc (input_location, var); /* And the case where a non-dummy, non-result, non-function, - non-allotable and non-pointer classarray is present. This case was + non-allocable and non-pointer classarray is present. This case was previously covered by the first if, but with introducing the condition !is_classarray there, that case has to be covered explicitly. */ @@ -5608,8 +5610,11 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym) itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR ? CFI_type_cfunptr : CFI_type_cptr); else - switch (e->ts.type) - { + { + if (e->expr_type == EXPR_NULL && e->ts.type == BT_UNKNOWN) + e->ts = fsym->ts; + switch (e->ts.type) + { case BT_INTEGER: case BT_LOGICAL: case BT_REAL: @@ -5647,7 +5652,8 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym) case BT_UNKNOWN: // FIXME: Really unreachable? Or reachable for type(*) ? If so, CFI_type_other? gcc_unreachable (); - } + } + } tmp = gfc_get_cfi_desc_type (cfi); gfc_add_modify (&block, tmp, @@ -5678,7 +5684,7 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym) Note that allocatable implies 'len=:'. */ if (e->ts.type != BT_ASSUMED && e->ts.type != BT_CHARACTER ) { - /* Length is known at compile time; use use 'block' for it. */ + /* Length is known at compile time; use 'block' for it. */ tmp = size_in_bytes (gfc_typenode_for_spec (&e->ts)); tmp2 = gfc_get_cfi_desc_elem_len (cfi); gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), tmp)); @@ -5700,7 +5706,8 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym) gfc_init_block (&block2); /* Set elem_len, which may be only known at run time. */ - if (e->ts.type == BT_CHARACTER) + if (e->ts.type == BT_CHARACTER + && (e->expr_type != EXPR_NULL || gfc_strlen != NULL_TREE)) { gcc_assert (gfc_strlen); tmp = gfc_strlen; @@ -8086,6 +8093,13 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, slen, dlen); + /* Pre-evaluate pointers unless one of the IF arms will be optimized away. */ + if (!CONSTANT_CLASS_P (cond2)) + { + dest = gfc_evaluate_now (dest, block); + src = gfc_evaluate_now (src, block); + } + /* Copy and pad with spaces. */ tmp3 = build_call_expr_loc (input_location, builtin_decl_explicit (BUILT_IN_MEMMOVE), @@ -9187,8 +9201,8 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray) return gfc_finish_block (&block); } -void -gfc_conv_union_initializer (vec<constructor_elt, va_gc> *v, +static void +gfc_conv_union_initializer (vec<constructor_elt, va_gc> *&v, gfc_component *un, gfc_expr *init) { gfc_constructor *ctor; diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index fccf0a9..9d91278 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -692,7 +692,7 @@ gfc_build_intrinsic_lib_fndecls (void) { /* If we have soft-float types, we create the decls for their C99-like library functions. For now, we only handle _Float128 - q-suffixed functions. */ + q-suffixed or IEC 60559 f128-suffixed functions. */ tree type, complex_type, func_1, func_2, func_cabs, func_frexp; tree func_iround, func_lround, func_llround, func_scalbn, func_cpow; @@ -739,7 +739,10 @@ gfc_build_intrinsic_lib_fndecls (void) builtin_decl_for_float_type(). The others are all constructed by gfc_get_intrinsic_lib_fndecl(). */ #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \ - quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST); + quad_decls[BUILT_IN_ ## ID] \ + = define_quad_builtin (gfc_real16_use_iec_60559 \ + ? NAME "f128" : NAME "q", func_ ## TYPE, \ + CONST); #include "mathbuiltins.def" @@ -751,8 +754,9 @@ gfc_build_intrinsic_lib_fndecls (void) /* There is one built-in we defined manually, because it gets called with builtin_decl_for_precision() or builtin_decl_for_float_type() even though it is not an OTHER_BUILTIN: it is SQRT. */ - quad_decls[BUILT_IN_SQRT] = define_quad_builtin ("sqrtq", func_1, true); - + quad_decls[BUILT_IN_SQRT] + = define_quad_builtin (gfc_real16_use_iec_60559 + ? "sqrtf128" : "sqrtq", func_1, true); } /* Add GCC builtin functions. */ @@ -875,7 +879,8 @@ gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr) ts->type == BT_COMPLEX ? "c" : "", m->name, "l"); else if (gfc_real_kinds[n].c_float128) snprintf (name, sizeof (name), "%s%s%s", - ts->type == BT_COMPLEX ? "c" : "", m->name, "q"); + ts->type == BT_COMPLEX ? "c" : "", m->name, + gfc_real_kinds[n].use_iec_60559 ? "f128" : "q"); else gcc_unreachable (); } @@ -2620,7 +2625,7 @@ conv_intrinsic_image_status (gfc_se *se, gfc_expr *expr) else gcc_unreachable (); - se->expr = tmp; + se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp); } static void @@ -2662,7 +2667,7 @@ conv_intrinsic_team_number (gfc_se *se, gfc_expr *expr) else gcc_unreachable (); - se->expr = tmp; + se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp); } @@ -7255,12 +7260,13 @@ gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity) /* Combine the results. */ if (parity) - se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, result_type, - call1, call2); + se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, + integer_type_node, call1, call2); else - se->expr = fold_build2_loc (input_location, PLUS_EXPR, result_type, - call1, call2); + se->expr = fold_build2_loc (input_location, PLUS_EXPR, + integer_type_node, call1, call2); + se->expr = convert (result_type, se->expr); return; } @@ -8098,12 +8104,14 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr) class object. The class object may be a non-pointer object, e.g. located on the stack, or a memory location pointed to, e.g. a parameter, i.e., an indirect_ref. */ - if (arg->rank < 0 - || (arg->rank > 0 && !VAR_P (argse.expr) - && ((INDIRECT_REF_P (TREE_OPERAND (argse.expr, 0)) - && GFC_DECL_CLASS (TREE_OPERAND ( - TREE_OPERAND (argse.expr, 0), 0))) - || GFC_DECL_CLASS (TREE_OPERAND (argse.expr, 0))))) + if (POINTER_TYPE_P (TREE_TYPE (argse.expr)) + && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (argse.expr)))) + byte_size + = gfc_class_vtab_size_get (build_fold_indirect_ref (argse.expr)); + else if (GFC_CLASS_TYPE_P (TREE_TYPE (argse.expr))) + byte_size = gfc_class_vtab_size_get (argse.expr); + else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (argse.expr)) + && TREE_CODE (argse.expr) == COMPONENT_REF) byte_size = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0)); else if (arg->rank > 0 || (arg->rank == 0 @@ -8113,7 +8121,7 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr) byte_size = gfc_class_vtab_size_get ( GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl)); else - byte_size = gfc_class_vtab_size_get (argse.expr); + gcc_unreachable (); } else { @@ -9781,7 +9789,7 @@ conv_intrinsic_ieee_builtin (gfc_se * se, gfc_expr * expr, enum built_in_function code, int nargs) { tree args[2]; - gcc_assert ((unsigned) nargs <= sizeof(args)/sizeof(args[0])); + gcc_assert ((unsigned) nargs <= ARRAY_SIZE (args)); conv_ieee_function_args (se, expr, args, nargs); se->expr = build_call_expr_loc_array (input_location, @@ -11211,24 +11219,31 @@ conv_co_collective (gfc_code *code) return gfc_finish_block (&block); } + gfc_symbol *derived = code->ext.actual->expr->ts.type == BT_DERIVED + ? code->ext.actual->expr->ts.u.derived : NULL; + /* Handle the array. */ gfc_init_se (&argse, NULL); - if (code->ext.actual->expr->rank == 0) - { - symbol_attribute attr; - gfc_clear_attr (&attr); - gfc_init_se (&argse, NULL); - gfc_conv_expr (&argse, code->ext.actual->expr); - gfc_add_block_to_block (&block, &argse.pre); - gfc_add_block_to_block (&post_block, &argse.post); - array = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr); - array = gfc_build_addr_expr (NULL_TREE, array); - } - else + if (!derived || !derived->attr.alloc_comp + || code->resolved_isym->id != GFC_ISYM_CO_BROADCAST) { - argse.want_pointer = 1; - gfc_conv_expr_descriptor (&argse, code->ext.actual->expr); - array = argse.expr; + if (code->ext.actual->expr->rank == 0) + { + symbol_attribute attr; + gfc_clear_attr (&attr); + gfc_init_se (&argse, NULL); + gfc_conv_expr (&argse, code->ext.actual->expr); + gfc_add_block_to_block (&block, &argse.pre); + gfc_add_block_to_block (&post_block, &argse.post); + array = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr); + array = gfc_build_addr_expr (NULL_TREE, array); + } + else + { + argse.want_pointer = 1; + gfc_conv_expr_descriptor (&argse, code->ext.actual->expr); + array = argse.expr; + } } gfc_add_block_to_block (&block, &argse.pre); @@ -11289,9 +11304,6 @@ conv_co_collective (gfc_code *code) gcc_unreachable (); } - gfc_symbol *derived = code->ext.actual->expr->ts.type == BT_DERIVED - ? code->ext.actual->expr->ts.u.derived : NULL; - if (derived && derived->attr.alloc_comp && code->resolved_isym->id == GFC_ISYM_CO_BROADCAST) /* The derived type has the attribute 'alloc_comp'. */ diff --git a/gcc/fortran/trans-io.cc b/gcc/fortran/trans-io.cc index 732221f..9f86815 100644 --- a/gcc/fortran/trans-io.cc +++ b/gcc/fortran/trans-io.cc @@ -737,7 +737,6 @@ set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock, static void gfc_convert_array_to_string (gfc_se * se, gfc_expr * e) { - tree size; if (e->rank == 0) { @@ -755,12 +754,13 @@ gfc_convert_array_to_string (gfc_se * se, gfc_expr * e) array = sym->backend_decl; type = TREE_TYPE (array); + tree elts_count; if (GFC_ARRAY_TYPE_P (type)) - size = GFC_TYPE_ARRAY_SIZE (type); + elts_count = GFC_TYPE_ARRAY_SIZE (type); else { gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); - size = gfc_conv_array_stride (array, rank); + tree stride = gfc_conv_array_stride (array, rank); tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, gfc_conv_array_ubound (array, rank), @@ -768,23 +768,49 @@ gfc_convert_array_to_string (gfc_se * se, gfc_expr * e) tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, tmp, gfc_index_one_node); + elts_count = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, tmp, stride); + } + gcc_assert (elts_count); + + tree elt_size = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + elt_size = fold_convert (gfc_array_index_type, elt_size); + + tree size; + if (TREE_CODE (se->expr) == ARRAY_REF) + { + tree index = TREE_OPERAND (se->expr, 1); + index = fold_convert (gfc_array_index_type, index); + + elts_count = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + elts_count, index); + size = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, tmp, size); + gfc_array_index_type, elts_count, elt_size); + } + else + { + gcc_assert (TREE_CODE (se->expr) == INDIRECT_REF); + tree ptr = TREE_OPERAND (se->expr, 0); + + gcc_assert (TREE_CODE (ptr) == POINTER_PLUS_EXPR); + tree offset = fold_convert_loc (input_location, gfc_array_index_type, + TREE_OPERAND (ptr, 1)); + + size = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, elts_count, elt_size); + size = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, size, offset); } gcc_assert (size); - size = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, size, - TREE_OPERAND (se->expr, 1)); se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); - tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); - size = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, size, - fold_convert (gfc_array_index_type, tmp)); se->string_length = fold_convert (gfc_charlen_type_node, size); return; } + tree size; gfc_conv_array_parameter (se, e, true, NULL, NULL, &size); se->string_length = fold_convert (gfc_charlen_type_node, size); } diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc index 9eabf68..de27ed5 100644 --- a/gcc/fortran/trans-openmp.cc +++ b/gcc/fortran/trans-openmp.cc @@ -169,6 +169,48 @@ gfc_omp_array_data (tree decl, bool type_only) return decl; } +/* Return the byte-size of the passed array descriptor. */ + +tree +gfc_omp_array_size (tree decl, gimple_seq *pre_p) +{ + stmtblock_t block; + if (POINTER_TYPE_P (TREE_TYPE (decl))) + decl = build_fold_indirect_ref (decl); + tree type = TREE_TYPE (decl); + gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); + bool allocatable = (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE + || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER + || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT); + gfc_init_block (&block); + tree size = gfc_full_array_size (&block, decl, + GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl))); + size = fold_convert (size_type_node, size); + tree elemsz = gfc_get_element_type (TREE_TYPE (decl)); + if (TREE_CODE (elemsz) == ARRAY_TYPE && TYPE_STRING_FLAG (elemsz)) + elemsz = gfc_conv_descriptor_elem_len (decl); + else + elemsz = TYPE_SIZE_UNIT (elemsz); + size = fold_build2 (MULT_EXPR, size_type_node, size, elemsz); + if (!allocatable) + gimplify_and_add (gfc_finish_block (&block), pre_p); + else + { + tree var = create_tmp_var (size_type_node); + gfc_add_expr_to_block (&block, build2 (MODIFY_EXPR, sizetype, var, size)); + tree tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + gfc_conv_descriptor_data_get (decl), + null_pointer_node); + tmp = build3_loc (input_location, COND_EXPR, void_type_node, tmp, + gfc_finish_block (&block), + build2 (MODIFY_EXPR, sizetype, var, size_zero_node)); + gimplify_and_add (tmp, pre_p); + size = var; + } + return size; +} + + /* True if OpenMP should privatize what this DECL points to rather than the DECL itself. */ @@ -808,6 +850,11 @@ gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src) gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR); + /* Privatize pointer, only; cf. gfc_omp_predetermined_sharing. */ + if (DECL_P (OMP_CLAUSE_DECL (clause)) + && GFC_DECL_ASSOCIATE_VAR_P (OMP_CLAUSE_DECL (clause))) + return build2 (MODIFY_EXPR, TREE_TYPE (dest), dest, src); + if (DECL_ARTIFICIAL (OMP_CLAUSE_DECL (clause)) && DECL_LANG_SPECIFIC (OMP_CLAUSE_DECL (clause)) && GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause))) @@ -1321,6 +1368,11 @@ gfc_omp_clause_dtor (tree clause, tree decl) tree type = TREE_TYPE (decl), tem; tree decl_type = TREE_TYPE (OMP_CLAUSE_DECL (clause)); + /* Only pointer was privatized; cf. gfc_omp_clause_copy_ctor. */ + if (DECL_P (OMP_CLAUSE_DECL (clause)) + && GFC_DECL_ASSOCIATE_VAR_P (OMP_CLAUSE_DECL (clause))) + return NULL_TREE; + if (DECL_ARTIFICIAL (OMP_CLAUSE_DECL (clause)) && DECL_LANG_SPECIFIC (OMP_CLAUSE_DECL (clause)) && GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_DECL (clause))) @@ -1597,7 +1649,8 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc) tree size = create_tmp_var (gfc_array_index_type); tree elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type)); elemsz = fold_convert (gfc_array_index_type, elemsz); - if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER + if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE + || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT) { stmtblock_t cond_block; @@ -1910,7 +1963,8 @@ gfc_trans_omp_variable_list (enum omp_clause_code code, tree t = gfc_trans_omp_variable (namelist->sym, declare_simd); if (t != error_mark_node) { - tree node = build_omp_clause (input_location, code); + tree node; + node = build_omp_clause (input_location, code); OMP_CLAUSE_DECL (node) = t; list = gfc_trans_add_clause (node, list); @@ -2483,7 +2537,7 @@ static tree handle_iterator (gfc_namespace *ns, stmtblock_t *iter_block, tree block) { tree list = NULL_TREE; - for (gfc_symbol *sym = ns->proc_name; sym; sym = sym->tlink) + for (gfc_symbol *sym = ns->omp_affinity_iterators; sym; sym = sym->tlink) { gfc_constructor *c; gfc_se se; @@ -2604,6 +2658,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_HAS_DEVICE_ADDR: + clause_code = OMP_CLAUSE_HAS_DEVICE_ADDR; + goto add_clause; case OMP_LIST_NONTEMPORAL: clause_code = OMP_CLAUSE_NONTEMPORAL; goto add_clause; @@ -2694,7 +2751,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, OMP_CLAUSE_LINEAR); OMP_CLAUSE_DECL (node) = t; omp_clause_linear_kind kind; - switch (n->u.linear_op) + switch (n->u.linear.op) { case OMP_LINEAR_DEFAULT: kind = OMP_CLAUSE_LINEAR_DEFAULT; @@ -2712,6 +2769,8 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, gcc_unreachable (); } OMP_CLAUSE_LINEAR_KIND (node) = kind; + OMP_CLAUSE_LINEAR_OLD_LINEAR_MODIFIER (node) + = n->u.linear.old_modifier; if (last_step_expr && last_step == NULL_TREE) { if (!declare_simd) @@ -2856,27 +2915,28 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, continue; } - if (!n->sym->attr.referenced) + if (n->sym && !n->sym->attr.referenced) continue; tree node = build_omp_clause (input_location, list == OMP_LIST_DEPEND ? OMP_CLAUSE_DEPEND : OMP_CLAUSE_AFFINITY); - if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL) + if (n->sym == NULL) /* omp_all_memory */ + OMP_CLAUSE_DECL (node) = null_pointer_node; + else if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL) { tree decl = gfc_trans_omp_variable (n->sym, false); if (gfc_omp_privatize_by_reference (decl)) decl = build_fold_indirect_ref (decl); - if (n->u.depend_op == OMP_DEPEND_DEPOBJ - && POINTER_TYPE_P (TREE_TYPE (decl))) - decl = build_fold_indirect_ref (decl); if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) { decl = gfc_conv_descriptor_data_get (decl); gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl))); decl = build_fold_indirect_ref (decl); } + else if (n->sym->attr.allocatable || n->sym->attr.pointer) + decl = build_fold_indirect_ref (decl); else if (DECL_P (decl)) TREE_ADDRESSABLE (decl) = 1; OMP_CLAUSE_DECL (node) = decl; @@ -2912,6 +2972,9 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, case OMP_DEPEND_INOUT: OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_INOUT; break; + case OMP_DEPEND_INOUTSET: + OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_INOUTSET; + break; case OMP_DEPEND_MUTEXINOUTSET: OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_MUTEXINOUTSET; @@ -3196,7 +3259,8 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, /* We have to check for n->sym->attr.dimension because of scalar coarrays. */ - if (n->sym->attr.pointer && n->sym->attr.dimension) + if ((n->sym->attr.pointer || n->sym->attr.allocatable) + && n->sym->attr.dimension) { stmtblock_t cond_block; tree size @@ -3288,9 +3352,15 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, /* An array element or array section which is not part of a derived type, etc. */ bool element = n->expr->ref->u.ar.type == AR_ELEMENT; - gfc_trans_omp_array_section (block, n, decl, element, - GOMP_MAP_POINTER, node, node2, - node3, node4); + tree type = TREE_TYPE (decl); + gomp_map_kind k = GOMP_MAP_POINTER; + if (!openacc + && !GFC_DESCRIPTOR_TYPE_P (type) + && !(POINTER_TYPE_P (type) + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))) + k = GOMP_MAP_FIRSTPRIVATE_POINTER; + gfc_trans_omp_array_section (block, n, decl, element, k, + node, node2, node3, node4); } else if (n->expr && n->expr->expr_type == EXPR_VARIABLE @@ -4420,7 +4490,9 @@ gfc_trans_oacc_construct (gfc_code *code) gfc_start_block (&block); oacc_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, code->loc, false, true); + pushlevel (); stmt = gfc_trans_omp_code (code->block->next, true); + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); stmt = build2_loc (gfc_get_location (&code->loc), construct_code, void_type_node, stmt, oacc_clauses); gfc_add_expr_to_block (&block, stmt); @@ -4988,6 +5060,7 @@ gfc_trans_omp_critical (gfc_code *code) name = get_identifier (code->ext.omp_clauses->critical_name); gfc_start_block (&block); stmt = make_node (OMP_CRITICAL); + SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc)); TREE_TYPE (stmt) = void_type_node; OMP_CRITICAL_BODY (stmt) = gfc_trans_code (code->block->next); OMP_CRITICAL_NAME (stmt) = name; @@ -5020,6 +5093,7 @@ gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock, unsigned ix; vec<tree, va_heap, vl_embed> *saved_doacross_steps = doacross_steps; gfc_expr_list *tile = do_clauses ? do_clauses->tile_list : clauses->tile_list; + gfc_code *orig_code = code; /* Both collapsed and tiled loops are lowered the same way. In OpenACC, those clauses are not compatible, so prioritize the tile @@ -5374,6 +5448,7 @@ gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock, default: gcc_unreachable (); } + SET_EXPR_LOCATION (stmt, gfc_get_location (&orig_code->loc)); TREE_TYPE (stmt) = void_type_node; OMP_FOR_BODY (stmt) = gfc_finish_block (&body); OMP_FOR_CLAUSES (stmt) = omp_clauses; @@ -5382,6 +5457,7 @@ gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock, OMP_FOR_INCR (stmt) = incr; if (orig_decls) OMP_FOR_ORIG_DECLS (stmt) = orig_decls; + OMP_FOR_NON_RECTANGULAR (stmt) = clauses->non_rectangular; gfc_add_expr_to_block (&block, stmt); vec_free (doacross_steps); @@ -5495,12 +5571,48 @@ gfc_trans_omp_depobj (gfc_code *code) if (n) { tree var; - if (n->expr) - var = gfc_convert_expr_to_tree (&block, n->expr); + if (!n->sym) /* omp_all_memory. */ + var = null_pointer_node; + else if (n->expr && n->expr->ref->u.ar.type != AR_FULL) + { + gfc_init_se (&se, NULL); + if (n->expr->ref->u.ar.type == AR_ELEMENT) + { + gfc_conv_expr_reference (&se, n->expr); + var = se.expr; + } + else + { + gfc_conv_expr_descriptor (&se, n->expr); + var = gfc_conv_array_data (se.expr); + } + gfc_add_block_to_block (&block, &se.pre); + gfc_add_block_to_block (&block, &se.post); + gcc_assert (POINTER_TYPE_P (TREE_TYPE (var))); + } else - var = gfc_get_symbol_decl (n->sym); - if (!POINTER_TYPE_P (TREE_TYPE (var))) - var = gfc_build_addr_expr (NULL, var); + { + var = gfc_get_symbol_decl (n->sym); + if (POINTER_TYPE_P (TREE_TYPE (var)) + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (var)))) + var = build_fold_indirect_ref (var); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (var))) + { + var = gfc_conv_descriptor_data_get (var); + gcc_assert (POINTER_TYPE_P (TREE_TYPE (var))); + } + else if ((n->sym->attr.allocatable || n->sym->attr.pointer) + && n->sym->attr.dummy) + var = build_fold_indirect_ref (var); + else if (!POINTER_TYPE_P (TREE_TYPE (var)) + || (n->sym->ts.f90_type == BT_VOID + && !POINTER_TYPE_P (TREE_TYPE (TREE_TYPE (var))) + && !GFC_ARRAY_TYPE_P (TREE_TYPE (TREE_TYPE (var))))) + { + TREE_ADDRESSABLE (var) = 1; + var = gfc_build_addr_expr (NULL, var); + } + } depobj = save_expr (depobj); tree r = build_fold_indirect_ref_loc (loc, depobj); gfc_add_expr_to_block (&block, @@ -5519,6 +5631,7 @@ gfc_trans_omp_depobj (gfc_code *code) case OMP_DEPEND_IN: k = GOMP_DEPEND_IN; break; case OMP_DEPEND_OUT: k = GOMP_DEPEND_OUT; break; case OMP_DEPEND_INOUT: k = GOMP_DEPEND_INOUT; break; + case OMP_DEPEND_INOUTSET: k = GOMP_DEPEND_INOUTSET; break; case OMP_DEPEND_MUTEXINOUTSET: k = GOMP_DEPEND_MUTEXINOUTSET; break; default: gcc_unreachable (); } @@ -5612,6 +5725,7 @@ gfc_trans_omp_masked (gfc_code *code, gfc_omp_clauses *clauses) gfc_start_block (&block); tree omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc); tree stmt = make_node (OMP_MASKED); + SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc)); TREE_TYPE (stmt) = void_type_node; OMP_MASKED_BODY (stmt) = body; OMP_MASKED_CLAUSES (stmt) = omp_clauses; @@ -5940,7 +6054,7 @@ gfc_split_omp_clauses (gfc_code *code, innermost = GFC_OMP_SPLIT_DO; break; case EXEC_OMP_MASKED_TASKLOOP: - mask = GFC_OMP_SPLIT_MASKED | GFC_OMP_SPLIT_TASKLOOP; + mask = GFC_OMP_MASK_MASKED | GFC_OMP_MASK_TASKLOOP; innermost = GFC_OMP_SPLIT_TASKLOOP; break; case EXEC_OMP_MASTER_TASKLOOP: @@ -6386,6 +6500,7 @@ gfc_trans_omp_do_simd (gfc_code *code, stmtblock_t *pblock, if (flag_openmp) { stmt = make_node (OMP_FOR); + SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc)); TREE_TYPE (stmt) = void_type_node; OMP_FOR_BODY (stmt) = body; OMP_FOR_CLAUSES (stmt) = omp_do_clauses; @@ -6558,6 +6673,7 @@ gfc_trans_omp_scope (gfc_code *code) tree omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, code->loc); tree stmt = make_node (OMP_SCOPE); + SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc)); TREE_TYPE (stmt) = void_type_node; OMP_SCOPE_BODY (stmt) = body; OMP_SCOPE_CLAUSES (stmt) = omp_clauses; @@ -6633,6 +6749,7 @@ gfc_trans_omp_taskgroup (gfc_code *code) gfc_start_block (&block); tree body = gfc_trans_code (code->block->next); tree stmt = make_node (OMP_TASKGROUP); + SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc)); TREE_TYPE (stmt) = void_type_node; OMP_TASKGROUP_BODY (stmt) = body; OMP_TASKGROUP_CLAUSES (stmt) = gfc_trans_omp_clauses (&block, @@ -6653,6 +6770,7 @@ gfc_trans_omp_taskwait (gfc_code *code) stmtblock_t block; gfc_start_block (&block); tree stmt = make_node (OMP_TASK); + SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc)); TREE_TYPE (stmt) = void_type_node; OMP_TASK_BODY (stmt) = NULL_TREE; OMP_TASK_CLAUSES (stmt) = gfc_trans_omp_clauses (&block, @@ -6730,6 +6848,7 @@ gfc_trans_omp_distribute (gfc_code *code, gfc_omp_clauses *clausesa) if (flag_openmp) { tree distribute = make_node (OMP_DISTRIBUTE); + SET_EXPR_LOCATION (distribute, gfc_get_location (&code->loc)); TREE_TYPE (distribute) = void_type_node; OMP_FOR_BODY (distribute) = stmt; OMP_FOR_CLAUSES (distribute) = omp_clauses; @@ -6950,6 +7069,7 @@ gfc_trans_omp_taskloop (gfc_code *code, gfc_exec_op op) if (flag_openmp) { tree taskloop = make_node (OMP_TASKLOOP); + SET_EXPR_LOCATION (taskloop, gfc_get_location (&code->loc)); TREE_TYPE (taskloop) = void_type_node; OMP_FOR_BODY (taskloop) = stmt; OMP_FOR_CLAUSES (taskloop) = omp_clauses; @@ -6995,6 +7115,7 @@ gfc_trans_omp_master_masked_taskloop (gfc_code *code, gfc_exec_op op) &clausesa[GFC_OMP_SPLIT_MASKED], code->loc); tree msk = make_node (OMP_MASKED); + SET_EXPR_LOCATION (msk, gfc_get_location (&code->loc)); TREE_TYPE (msk) = void_type_node; OMP_MASKED_BODY (msk) = stmt; OMP_MASKED_CLAUSES (msk) = clauses; diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc index 04f8147..fd6d294 100644 --- a/gcc/fortran/trans-stmt.cc +++ b/gcc/fortran/trans-stmt.cc @@ -652,11 +652,20 @@ gfc_trans_stop (gfc_code *code, bool error_stop) { gfc_se se; tree tmp; + tree quiet; /* Start a new block for this statement. */ gfc_init_se (&se, NULL); gfc_start_block (&se.pre); + if (code->expr2) + { + gfc_conv_expr_val (&se, code->expr2); + quiet = fold_convert (boolean_type_node, se.expr); + } + else + quiet = boolean_false_node; + if (code->expr1 == NULL) { tmp = build_int_cst (size_type_node, 0); @@ -669,7 +678,7 @@ gfc_trans_stop (gfc_code *code, bool error_stop) ? gfor_fndecl_caf_stop_str : gfor_fndecl_stop_string), 3, build_int_cst (pchar_type_node, 0), tmp, - boolean_false_node); + quiet); } else if (code->expr1->ts.type == BT_INTEGER) { @@ -683,7 +692,7 @@ gfc_trans_stop (gfc_code *code, bool error_stop) ? gfor_fndecl_caf_stop_numeric : gfor_fndecl_stop_numeric), 2, fold_convert (integer_type_node, se.expr), - boolean_false_node); + quiet); } else { @@ -698,7 +707,7 @@ gfc_trans_stop (gfc_code *code, bool error_stop) : gfor_fndecl_stop_string), 3, se.expr, fold_convert (size_type_node, se.string_length), - boolean_false_node); + quiet); } gfc_add_expr_to_block (&se.pre, tmp); @@ -1918,7 +1927,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) gfc_conv_expr_descriptor (&se, e); if (sym->ts.type == BT_CHARACTER - && !se.direct_byref && sym->ts.deferred + && sym->ts.deferred && !sym->attr.select_type_temporary && VAR_P (sym->ts.u.cl->backend_decl) && se.string_length != sym->ts.u.cl->backend_decl) @@ -7121,7 +7130,8 @@ gfc_trans_allocate (gfc_code * code) if (code->expr1 && code->expr2) { const char *msg = "Attempt to allocate an allocated object"; - tree slen, dlen, errmsg_str; + const char *oommsg = "Insufficient virtual memory"; + tree slen, dlen, errmsg_str, oom_str, oom_loc; stmtblock_t errmsg_block; gfc_init_block (&errmsg_block); @@ -7142,8 +7152,34 @@ gfc_trans_allocate (gfc_code * code) gfc_default_character_kind); dlen = gfc_finish_block (&errmsg_block); - tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - stat, build_int_cst (TREE_TYPE (stat), 0)); + tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, + stat, build_int_cst (TREE_TYPE (stat), + LIBERROR_ALLOCATION)); + + tmp = build3_v (COND_EXPR, tmp, + dlen, build_empty_stmt (input_location)); + + gfc_add_expr_to_block (&block, tmp); + + oom_str = gfc_create_var (pchar_type_node, "OOMMSG"); + oom_loc = gfc_build_localized_cstring_const (oommsg); + gfc_add_modify (&errmsg_block, oom_str, + gfc_build_addr_expr (pchar_type_node, oom_loc)); + + slen = build_int_cst (gfc_charlen_type_node, strlen (oommsg)); + dlen = gfc_get_expr_charlen (code->expr2); + slen = fold_build2_loc (input_location, MIN_EXPR, + TREE_TYPE (slen), dlen, slen); + + gfc_trans_string_copy (&errmsg_block, dlen, errmsg, + code->expr2->ts.kind, + slen, oom_str, + gfc_default_character_kind); + dlen = gfc_finish_block (&errmsg_block); + + tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, + stat, build_int_cst (TREE_TYPE (stat), + LIBERROR_NO_MEMORY)); tmp = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt (input_location)); diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc index a56337b..0ea7c74 100644 --- a/gcc/fortran/trans-types.cc +++ b/gcc/fortran/trans-types.cc @@ -72,6 +72,7 @@ tree gfc_float128_type_node = NULL_TREE; tree gfc_complex_float128_type_node = NULL_TREE; bool gfc_real16_is_float128 = false; +bool gfc_real16_use_iec_60559 = false; static GTY(()) tree gfc_desc_dim_type; static GTY(()) tree gfc_max_array_element_size; @@ -522,11 +523,19 @@ gfc_init_kinds (void) && (TARGET_GLIBC_MAJOR < 2 || (TARGET_GLIBC_MAJOR == 2 && TARGET_GLIBC_MINOR < 32))) { + if (TARGET_GLIBC_MAJOR == 2 && TARGET_GLIBC_MINOR >= 26) + { + gfc_real16_use_iec_60559 = true; + gfc_real_kinds[i].use_iec_60559 = 1; + } gfc_real16_is_float128 = true; gfc_real_kinds[i].c_float128 = 1; } } } + else if ((flag_convert & (GFC_CONVERT_R16_IEEE | GFC_CONVERT_R16_IBM)) != 0) + gfc_fatal_error ("%<-fconvert=r16_ieee%> or %<-fconvert=r16_ibm%> not " + "supported on this architecture"); /* Choose the default integer kind. We choose 4 unless the user directs us otherwise. Even if the user specified that the default integer kind is 8, @@ -875,6 +884,12 @@ gfc_build_real_type (gfc_real_info *info) /* TODO: see PR101835. */ info->c_float128 = 1; gfc_real16_is_float128 = true; + if (TARGET_GLIBC_MAJOR > 2 + || (TARGET_GLIBC_MAJOR == 2 && TARGET_GLIBC_MINOR >= 26)) + { + info->use_iec_60559 = 1; + gfc_real16_use_iec_60559 = true; + } } if (TYPE_PRECISION (float_type_node) == mode_precision) @@ -3417,7 +3432,7 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info) } rank = GFC_TYPE_ARRAY_RANK (type); - if (rank >= (int) (sizeof (info->dimen) / sizeof (info->dimen[0]))) + if (rank >= (int) (ARRAY_SIZE (info->dimen))) return false; etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type); diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h index 09a51e6..6a360de 100644 --- a/gcc/fortran/trans-types.h +++ b/gcc/fortran/trans-types.h @@ -58,6 +58,10 @@ extern GTY(()) tree gfc_charlen_type_node; and _Float128. */ extern bool gfc_real16_is_float128; +/* True if IEC 60559 *f128 APIs should be used for _Float128 rather than + libquadmath *q APIs. */ +extern bool gfc_real16_use_iec_60559; + enum gfc_packed { PACKED_NO = 0, PACKED_PARTIAL, diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc index 333dfa6..912a206 100644 --- a/gcc/fortran/trans.cc +++ b/gcc/fortran/trans.cc @@ -446,10 +446,14 @@ gfc_build_spanned_array_ref (tree base, tree offset, tree span) } -/* Build an ARRAY_REF with its natural type. */ +/* Build an ARRAY_REF with its natural type. + NON_NEGATIVE_OFFSET indicates if it’s true that OFFSET can’t be negative, + and thus that an ARRAY_REF can safely be generated. If it’s false, we + have to play it safe and use pointer arithmetic. */ tree -gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr) +gfc_build_array_ref (tree base, tree offset, tree decl, + bool non_negative_offset, tree vptr) { tree type = TREE_TYPE (base); tree span = NULL_TREE; @@ -495,10 +499,40 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr) pointer arithmetic. */ if (span != NULL_TREE) return gfc_build_spanned_array_ref (base, offset, span); - /* Otherwise use a straightforward array reference. */ - else + /* Else use a straightforward array reference if possible. */ + else if (non_negative_offset) return build4_loc (input_location, ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE); + /* Otherwise use pointer arithmetic. */ + else + { + gcc_assert (TREE_CODE (TREE_TYPE (base)) == ARRAY_TYPE); + tree min = NULL_TREE; + if (TYPE_DOMAIN (TREE_TYPE (base)) + && !integer_zerop (TYPE_MIN_VALUE (TYPE_DOMAIN (TREE_TYPE (base))))) + min = TYPE_MIN_VALUE (TYPE_DOMAIN (TREE_TYPE (base))); + + tree zero_based_index + = min ? fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + fold_convert (gfc_array_index_type, offset), + fold_convert (gfc_array_index_type, min)) + : fold_convert (gfc_array_index_type, offset); + + tree elt_size = fold_convert (gfc_array_index_type, + TYPE_SIZE_UNIT (type)); + + tree offset_bytes = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + zero_based_index, elt_size); + + tree base_addr = gfc_build_addr_expr (pvoid_type_node, base); + + tree ptr = fold_build_pointer_plus_loc (input_location, base_addr, + offset_bytes); + return build1_loc (input_location, INDIRECT_REF, type, + fold_convert (build_pointer_type (type), ptr)); + } } @@ -738,7 +772,7 @@ gfc_call_malloc (stmtblock_t * block, tree type, tree size) if (newmem == NULL) { if (stat) - *stat = LIBERROR_ALLOCATION; + *stat = LIBERROR_NO_MEMORY; else runtime_error ("Allocation would exceed memory limit"); } @@ -773,7 +807,7 @@ gfc_allocate_using_malloc (stmtblock_t * block, tree pointer, if (status != NULL_TREE) { tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, status, - build_int_cst (status_type, LIBERROR_ALLOCATION)); + build_int_cst (status_type, LIBERROR_NO_MEMORY)); gfc_add_expr_to_block (&on_error, tmp); } else diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 738c748..03d5288 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -619,7 +619,9 @@ tree gfc_get_extern_function_decl (gfc_symbol *, tree gfc_build_addr_expr (tree, tree); /* Build an ARRAY_REF. */ -tree gfc_build_array_ref (tree, tree, tree, tree vptr = NULL_TREE); +tree gfc_build_array_ref (tree, tree, tree, + bool non_negative_offset = false, + tree vptr = NULL_TREE); /* Build an array ref using pointer arithmetic. */ tree gfc_build_spanned_array_ref (tree base, tree offset, tree span); @@ -806,6 +808,7 @@ bool gfc_get_array_descr_info (const_tree, struct array_descr_info *); bool gfc_omp_is_allocatable_or_ptr (const_tree); tree gfc_omp_check_optional_argument (tree, bool); tree gfc_omp_array_data (tree, bool); +tree gfc_omp_array_size (tree, gimple_seq *); 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); |