diff options
| author | Ian Lance Taylor <iant@golang.org> | 2022-07-27 10:15:41 -0700 |
|---|---|---|
| committer | Ian Lance Taylor <iant@golang.org> | 2022-07-27 10:15:41 -0700 |
| commit | 9f62ed218fa656607740b386c0caa03e65dcd283 (patch) | |
| tree | 6bde49bc5e4c4241266b108e4277baef4b85535d /gcc/fortran | |
| parent | 71e955da39cea0ebffcfee3432effa622d14ca99 (diff) | |
| parent | 5eb9f117a361538834b9740d59219911680717d1 (diff) | |
| download | gcc-9f62ed218fa656607740b386c0caa03e65dcd283.zip gcc-9f62ed218fa656607740b386c0caa03e65dcd283.tar.gz gcc-9f62ed218fa656607740b386c0caa03e65dcd283.tar.bz2 | |
Merge from trunk revision 5eb9f117a361538834b9740d59219911680717d1.
Diffstat (limited to 'gcc/fortran')
36 files changed, 1931 insertions, 482 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 4a1371b..acd60ff 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,560 @@ +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 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 06e032e..d57059a 100644 --- a/gcc/fortran/arith.cc +++ b/gcc/fortran/arith.cc @@ -1489,6 +1489,9 @@ eval_intrinsic (gfc_intrinsic_op op, int unary; arith rc; + if (!op1) + return NULL; + gfc_clear_ts (&temp.ts); switch (op) @@ -1703,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 f1d92e0..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; } @@ -2420,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 fc97bb1..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) @@ -6353,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 2a2f990..5352008 100644 --- a/gcc/fortran/dump-parse-tree.cc +++ b/gcc/fortran/dump-parse-tree.cc @@ -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,6 +1684,7 @@ 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; @@ -1898,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 (); } @@ -2370,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; @@ -3538,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 c9c0ba4..be94c18 100644 --- a/gcc/fortran/expr.cc +++ b/gcc/fortran/expr.cc @@ -1594,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; 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 cb136f8..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; @@ -1394,6 +1399,7 @@ enum OMP_LIST_NONTEMPORAL, OMP_LIST_ALLOCATE, OMP_LIST_HAS_DEVICE_ADDR, + OMP_LIST_ENTER, OMP_LIST_NUM /* Must be the last. */ }; @@ -1533,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; @@ -2137,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; @@ -2662,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; @@ -3897,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..d34e0b5 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -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 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..c0932f6 100644 --- a/gcc/fortran/invoke.texi +++ b/gcc/fortran/invoke.texi @@ -1435,10 +1435,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 +1868,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 +2078,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/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..1aa3053 100644 --- a/gcc/fortran/match.cc +++ b/gcc/fortran/match.cc @@ -1606,21 +1606,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 +1634,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 +2857,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 +3002,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 +3025,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 +3039,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 +3061,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 +3096,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 +3185,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 +3223,7 @@ done: } new_st.expr1 = e; + new_st.expr2 = quiet; new_st.ext.stop_code = -1; return MATCH_YES; @@ -3169,6 +3234,7 @@ syntax: cleanup: gfc_free_expr (e); + gfc_free_expr (quiet); return MATCH_ERROR; } @@ -6650,7 +6716,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/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 19142c4..df9cdf4 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) @@ -956,6 +986,7 @@ enum omp_mask2 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 }; @@ -1150,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); @@ -1876,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) @@ -1884,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; @@ -1928,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 @@ -1974,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 " @@ -2062,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, @@ -2267,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; @@ -2274,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) @@ -2307,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) + { + 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; + } } - else if (!end_colon) + else { step = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, @@ -2322,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) @@ -2882,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) @@ -3628,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) @@ -3685,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 \ @@ -3768,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; @@ -3778,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; } } @@ -4489,7 +4666,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) @@ -4503,38 +4680,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)) { @@ -4557,14 +4736,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", @@ -4598,7 +4777,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); @@ -4910,8 +5092,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]; @@ -5232,7 +5413,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)) @@ -5419,10 +5600,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; @@ -5661,7 +5838,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); } @@ -6290,7 +6468,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", "HAS_DEVICE_ADDR" }; + "NONTEMPORAL", "ALLOCATE", "HAS_DEVICE_ADDR", "ENTER" }; STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM); if (omp_clauses == NULL) @@ -6499,6 +6677,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 @@ -6790,8 +6970,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", @@ -7079,10 +7261,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; @@ -7094,10 +7282,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; @@ -7171,8 +7365,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) @@ -7355,28 +7551,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) { @@ -7581,9 +7787,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); + } } @@ -8430,6 +8656,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) { @@ -8548,8 +8873,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 " @@ -8590,26 +8922,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/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/resolve.cc b/gcc/fortran/resolve.cc index 266e41e..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,7 +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 + if (sym->ts.deferred && sym->ts.u.cl == target->ts.u.cl) { sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL); @@ -9245,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. */ @@ -11533,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); @@ -11809,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. */ @@ -11942,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: @@ -11968,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: @@ -15120,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); @@ -15439,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 6483f9c..fb72599 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; @@ -3092,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 @@ -3352,6 +3372,9 @@ 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); @@ -3383,6 +3406,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); @@ -3437,6 +3463,9 @@ 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); @@ -3502,17 +3531,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) @@ -3529,111 +3556,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; } } @@ -8424,7 +8380,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/trans-array.cc b/gcc/fortran/trans-array.cc index cfb6eac..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); diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index 6493cc2..908a4c6 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -6474,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 e680de1..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 (); } @@ -8099,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 @@ -8114,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 { @@ -9782,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, 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 4d56a771..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; @@ -1911,16 +1964,7 @@ gfc_trans_omp_variable_list (enum omp_clause_code code, if (t != error_mark_node) { tree node; - /* For HAS_DEVICE_ADDR of an array descriptor, firstprivatize the - descriptor such that the bounds are available; its data component - is unmodified; it is handled as device address inside target. */ - if (code == OMP_CLAUSE_HAS_DEVICE_ADDR - && (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (t)) - || (POINTER_TYPE_P (TREE_TYPE (t)) - && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (t)))))) - node = build_omp_clause (input_location, OMP_CLAUSE_FIRSTPRIVATE); - else - node = build_omp_clause (input_location, code); + node = build_omp_clause (input_location, code); OMP_CLAUSE_DECL (node) = t; list = gfc_trans_add_clause (node, list); @@ -2707,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; @@ -2725,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) @@ -2869,14 +2915,16 @@ 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)) @@ -2924,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; @@ -3208,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 @@ -3300,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 @@ -4432,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); @@ -5000,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; @@ -5032,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 @@ -5386,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; @@ -5394,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); @@ -5507,7 +5571,9 @@ gfc_trans_omp_depobj (gfc_code *code) if (n) { tree var; - if (n->expr && n->expr->ref->u.ar.type != AR_FULL) + 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) @@ -5565,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 (); } @@ -5658,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; @@ -5986,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: @@ -6432,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; @@ -6604,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; @@ -6679,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, @@ -6699,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, @@ -6776,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; @@ -6996,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; @@ -7041,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 30b6bd5..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); @@ -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 3cdc529..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,6 +523,11 @@ 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; } @@ -878,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) @@ -3420,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); |