diff options
Diffstat (limited to 'gcc/fortran')
28 files changed, 2321 insertions, 426 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 5501bca..4fd2183 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,379 @@ +2025-12-08 Harald Anlauf <anlauf@gmx.de> + Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/123025 + * decl.cc (match_char_length): Add a check for the + obsolete '*' style of character declarations in the + alternate branch of checking so we dont miss two + use cases: + +2025-12-06 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/122693 + * array.cc (gfc_match_array_constructor): Stash and restore + gfc_current_ns after the call to 'gfc_match_type_spec'. + +2025-12-06 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/122670 + * decl.cc (gfc_get_pdt_instance): Ensure that, in an interface + body, PDT instances imported implicitly if the template has + been explicitly imported. + * module.cc (read_module): If a PDT template appears in a use + only statement, implicitly add the instances as well. + +2025-12-06 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/122669 + * resolve.cc (resolve_allocate_deallocate): Mold expressions + with an array reference and a constant size must be resolved + for each allocate object. + +2025-12-06 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/122578 + * primary.cc (gfc_match_varspec): Try to resolve a typebound + generic procedure selector expression to provide the associate + name with a type. Also, resolve component calls. In both cases, + make a copy of the selector expression to guard against changes + made by gfc_resolve_expr. + +2025-12-05 Harald Anlauf <anlauf@gmx.de> + + PR fortran/122977 + * expr.cc (gfc_is_simply_contiguous): For an associate variable + check whether the associate target is contiguous. + * resolve.cc (resolve_symbol): Skip array type check for an + associate variable when the target has the contiguous attribute. + +2025-12-05 Tobias Burnus <tburnus@baylibre.com> + + * openmp.cc (resolve_omp_clauses): Permit zero with + DYN_GROUPPRIVATE clause. + * trans-openmp.cc (fallback): Generate TREE code + for DYN_GROUPPRIVATE and remove 'sorry'. + +2025-12-03 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/103371 + * decl.cc (gfc_get_pdt_instance): Remove the requirement that + PDT components be of the same type as the enclosing type. Apply + initializers other than the default to PDT components. + * primary.cc (gfc_match_rvalue): Make combination of the two + actual_arglists conditional on 'type_spec_list' having been + seen as well together with applying component names to all the + arguments. + * trans-decl.cc (gfc_init_default_dt): Add 'pdt_ok' to the args + and use it to signal that a PDT can be default initialized. + (gfc_init_default_pdt): New function to check that a pdt is OK + for default intialization before calling gfc_init_default_dt. + (gfc_trans_deferred_vars): Use gfc_init_default_pdt. + * trans.h: Add bool 'pdt_ok' to prototype with defaul value of + false. + +2025-12-01 Christopher Albert <albert@tugraz.at> + Harald Anlauf <anlauf@gcc.gnu.org> + + PR fortran/107721 + PR fortran/102417 + * arith.cc (eval_intrinsic): Call gfc_check_constructor_type on + array constructor operands with explicit type-spec to ensure + element type conversion before operations. Resolve character + array constructors before CONCAT operations. + (reduce_binary_ac, reduce_binary_ca, reduce_binary_aa): Preserve + character length info in result arrays. + * array.cc (check_constructor_type): Simplify non-constant + expressions before type checking to handle parenthesized elements. + Handle nested character array constructors with explicit type-spec + when outer constructor has no type-spec. + (gfc_resolve_character_array_constructor): Recursively propagate + type-spec to nested array constructors. If the nested constructor + has an explicit type-spec, resolve it first before propagating + the outer type-spec. + +2025-12-01 Tobias Burnus <tburnus@baylibre.com> + + * gfortran.texi (Default exponents): Remove spurious @menu entry. + +2025-11-30 Andrew Pinski <andrew.pinski@oss.qualcomm.com> + + * lang.opt.urls: Regenerate. + +2025-11-28 Tobias Burnus <tburnus@baylibre.com> + + PR c/122892 + * openmp.cc (gfc_resolve_omp_allocate): Reject non-local + static variables with cgroup/pteam/thread allocators. + * parse.cc: Permit OMP ALLOCATE in BLOCK DATA. + +2025-11-26 Tobias Burnus <tburnus@baylibre.com> + + * dump-parse-tree.cc (show_attr): Handle OpenMP's 'local' clause + and the 'groupprivate' directive. + (show_omp_clauses): Handle dyn_groupprivate. + * frontend-passes.cc (gfc_code_walker): Walk dyn_groupprivate. + * gfortran.h (enum gfc_statement): Add ST_OMP_GROUPPRIVATE. + (enum gfc_omp_fallback, gfc_add_omp_groupprivate, + gfc_add_omp_declare_target_local): New. + * match.h (gfc_match_omp_groupprivate): New. + * module.cc (enum ab_attribute, mio_symbol_attribute, load_commons, + write_common_0): Handle 'groupprivate' + declare target's 'local'. + * openmp.cc (gfc_omp_directives): Add 'groupprivate'. + (gfc_free_omp_clauses): Free dyn_groupprivate. + (enum omp_mask2): Add OMP_CLAUSE_LOCAL and OMP_CLAUSE_DYN_GROUPPRIVATE. + (gfc_match_omp_clauses): Match them. + (OMP_TARGET_CLAUSES): Add OMP_CLAUSE_DYN_GROUPPRIVATE. + (OMP_DECLARE_TARGET_CLAUSES): Add OMP_CLAUSE_LOCAL. + (gfc_match_omp_declare_target): Handle groupprivate + fixes. + (gfc_match_omp_threadprivate): Code move to and calling now ... + (gfc_match_omp_thread_group_private): ... this new function. + Also handle groupprivate. + (gfc_match_omp_groupprivate): New. + (resolve_omp_clauses): Resolve dyn_groupprivate. + * parse.cc (decode_omp_directive): Match groupprivate. + (case_omp_decl, parse_spec, gfc_ascii_statement): Handle it. + * resolve.cc (resolve_symbol): Handle groupprivate. + * symbol.cc (gfc_check_conflict, gfc_copy_attr): Handle 'local' + and 'groupprivate'. + (gfc_add_omp_groupprivate, gfc_add_omp_declare_target_local): New. + * trans-common.cc (build_common_decl, + accumulate_equivalence_attributes): Print 'sorry' for + groupprivate and declare target's local. + * trans-decl.cc (add_attributes_to_decl): Likewise.. + * trans-openmp.cc (gfc_trans_omp_clauses): Print 'sorry' for + dyn_groupprivate. + (fallback): Process declare target with link/local as + done for 'enter'. + +2025-11-26 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/104650 + * decl.cc (gfc_get_pdt_instance): If the PDT template has + finalizers, make a new f2k_derived namespace for this intance + and copy the template namespace into it. Set the instance + template_sym field to point to the template. + * expr.cc (gfc_check_pointer_assign): Allow array value pointer + lvalues to point to scalar null expressions in initialization. + * gfortran.h : Add the template_sym field to gfc_symbol. + * resolve.cc (gfc_resolve_finalizers): For a pdt_type, copy the + final subroutines with the same type argument into the pdt_type + finalizer list. Prevent final subroutine type checking and + creation of the vtab for pdt_templates. + * symbol.cc (gfc_free_symbol): Do not call gfc_free_namespace + for pdt_type with finalizers. Instead, free the finalizers and + the namespace. + +2025-11-24 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/122766 + * decl.cc (gfc_match_decl_type_spec): A pdt_type found while + parsing a contains section can only arise from the typespec of + a function declaration. This can be retained in the typespec. + Once we are parsing the function, the first reference to this + derived type will find that it has no symtree. Provide it with + one so that gfc_use_derived does not complain and, again,retain + it in the typespec. + +2025-11-18 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/32365 + * parse.cc (parse_executable): Reject declaration/OpenMP + specification statements seen after executable code + unconditionally, keeping the legacy DATA diagnostic as + a warning. + +2025-11-17 Harald Anlauf <anlauf@gmx.de> + + PR fortran/122709 + * resolve.cc (resolve_assoc_var): If the associate target is a + contiguous pointer, so is the associate variable. + +2025-11-17 Thomas Koenig <tkoenig@gcc.gnu.org> + + * gfortran.texi: Remove section "Experimental features for future + Fortran revisions". Move documentation of UNSIGNED into Extensions. + Mention flang compatibility. + +2025-11-17 Jakub Jelinek <jakub@redhat.com> + + * parse.cc (gfc_parse_file): Avoid arithmetics or + bitwise operations between enumerators from different enums. + +2025-11-14 Yuao Ma <c8ef@outlook.com> + + * trans-expr.cc (conv_dummy_value): Add check for NULL allocatable. + +2025-11-14 Harald Anlauf <anlauf@gmx.de> + + PR fortran/117070 + * array.cc (check_constructor): Allow procedures as potential + target of a procedure pointer. + +2025-11-13 Andrew Stubbs <ams@codesourcery.com> + Kwok Cheung Yeung <kcyeung@baylibre.com> + Thomas Schwinge <tschwinge@baylibre.com> + + * openmp.cc (is_predefined_allocator): Use GOMP_OMP_PREDEF_ALLOC_MAX + and GOMP_OMPX_PREDEF_ALLOC_MIN/MAX instead of hardcoded values in the + comment. + +2025-11-13 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE> + + PR other/122638 + * gfortran.texi (OpenMP): Fix syntax. + * intrinsic.texi (UINT): Fix syntax. + +2025-11-13 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/96255 + * match.cc (apply_typespec_to_iterator): Call gfc_set_sym_referenced + for both new and shadow iterator symbols. + +2025-11-12 Tobias Burnus <tburnus@baylibre.com> + + PR libgomp/119677 + * intrinsic.texi (OpenMP Modules): Add omp_default_device. + * openmp.cc (gfc_resolve_omp_context_selector): Accept + omp_default_device as conforming device number. + +2025-11-11 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/96255 + * resolve.cc (gfc_resolve_forall): Delete outer_sym + +2025-11-11 Christopher Albert <albert@tugraz.at> + + PR fortran/90519 + * trans-expr.cc (strip_parentheses): New helper function to strip + INTRINSIC_PARENTHESES operators from expressions. + (is_runtime_conformable): Use strip_parentheses to handle cases + like a = (a) when checking for self-assignment. + (gfc_trans_assignment_1): Strip parentheses before checking if + expr2 is a variable, ensuring deep_copy is enabled for cases like + a = (a). Also strip parentheses when checking for self-assignment + to avoid use-after-free in finalization. + (gfc_trans_scalar_assign): Add comment about parentheses handling. + * class.cc (generate_finalization_wrapper): Create separate result + symbol for finalizer wrapper functions instead of self-referencing + the procedure symbol, avoiding ICE in gimplify_call_expr. + +2025-11-11 Jerry DeLisle <jvdelisle@gcc.gnu.org> + Steve Kargl <kargl@gcc.gnu.org> + + PR fortran/96255 + * gfortran.h (gfc_forall_iterator): Add bool shadow field. + * match.cc (apply_typespec_to_iterator): New helper function to + consolidate shadow variable creation logic. + (match_forall_header): Add type-spec parsing for DO CONCURRENT + and FORALL. Create shadow variables when type-spec differs from + outer scope. Replace duplicated code with apply_typespec_to_iterator. + * resolve.cc (replace_in_expr_recursive): New function to recursively + walk expressions and replace symbol references. + (replace_in_code_recursive): New function to recursively walk code + blocks and replace symbol references. + (gfc_replace_forall_variable): New entry point for shadow variable + substitution. + (gfc_resolve_assign_in_forall): Skip many-to-one assignment warning + for DO CONCURRENT. + (gfc_count_forall_iterators): Handle both EXEC_FORALL and + EXEC_DO_CONCURRENT with assertion. + (gfc_resolve_forall): Skip F2018 obsolescence warning for DO + CONCURRENT. Fix memory allocation check. Add NULL checks for shadow + variables. Implement shadow variable walker. + (gfc_resolve_code): Set gfc_do_concurrent_flag for DO CONCURRENT + constructs to enable constraint checking. + +2025-11-10 Sandra Loosemore <sloosemore@baylibre.com> + + PR other/122243 + * lang.opt.urls: Regenerated. + +2025-11-08 Harald Anlauf <anlauf@gmx.de> + + PR fortran/113338 + * decl.cc (gfc_verify_c_interop_param): Allow further types of + dummy argument without the VALUE attribute as specified in + F2018 18.3.6 item (5). + +2025-11-08 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/121628 + * trans-array.cc (seen_derived_types): Move to file scope and + preserve/restore around generate_element_copy_wrapper. + * trans-intrinsic.cc (conv_intrinsic_atomic_op): Reuse + gfc_trans_force_lval when forcing addressable CAF temps. + +2025-11-06 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/121628 + * trans-array.cc (get_copy_helper_function_type): New function to + create function type for element copy helpers. + (get_copy_helper_pointer_type): New function to create pointer type + for element copy helpers. + (generate_element_copy_wrapper): New function to generate runtime + helper for element-wise deep copying of recursive types. + (structure_alloc_comps): Detect recursive allocatable array + components and use runtime helper instead of inline recursion. + Add includes for cgraph.h and function.h. + * trans-decl.cc (gfor_fndecl_cfi_deep_copy_array): New declaration + for runtime deep copy helper. + (gfc_build_builtin_function_decls): Initialize the runtime helper + declaration. + * trans-intrinsic.cc (conv_intrinsic_atomic_op): Enhance handling of + constant values in coarray atomic operations by detecting and + materializing address-of-constant expressions. + * trans.h (gfor_fndecl_cfi_deep_copy_array): Add external declaration. + +2025-11-05 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/122566 + * decl.cc (gfc_get_pdt_instance): Add non-PDT type exstention. + +2025-11-05 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/122501 + PR fortran/122524 + * primary.cc (gfc_convert_to_structure_constructor): Correct + whitespace issue. + (gfc_match_rvalue): Remove the attempt to match specific procs + before filling out PDT constructor. Instead, defer this until + resolution with the condition that there not be a following + arglist and more than one procedure in the generic interface. + +2025-11-05 Tobias Burnus <tburnus@baylibre.com> + + PR fortran/122570 + * openmp.cc (resolve_omp_metadirective): Fix 'skip' of + never matchable metadirective variants. + +2025-11-04 Harald Anlauf <anlauf@gmx.de> + + PR fortran/122564 + * resolve.cc (resolve_locality_spec): Delete temporary hash_set. + +2025-11-04 Paul-Antoine Arras <parras@baylibre.com> + + PR fortran/122369 + PR fortran/122508 + * gfortran.h (gfc_rebind_label): Declare new function. + * parse.cc (parse_omp_metadirective_body): Rebind labels to the outer + region. Maintain a vector of metadirective regions. + (gfc_parse_file): Initialise it. + * parse.h (GFC_PARSE_H): Declare it. + * symbol.cc (gfc_get_st_label): Look for existing labels in outer + metadirective regions. + (gfc_rebind_label): Define new function. + (gfc_define_st_label): Accept duplicate labels in metadirective body. + (gfc_reference_st_label): Accept shared DO termination labels in + metadirective body. + +2025-11-03 Steve Kargl <kargls@comcast.net> + + PR fortran/122513 + * resolve.cc (check_default_none_expr): Do not allow an + iterator in a locality spec. Allow a named constant to be + used within the loop. + 2025-11-01 Harald Anlauf <anlauf@gmx.de> PR fortran/78640 diff --git a/gcc/fortran/arith.cc b/gcc/fortran/arith.cc index 82a8b6f..142f1b0 100644 --- a/gcc/fortran/arith.cc +++ b/gcc/fortran/arith.cc @@ -1565,6 +1565,8 @@ reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind, &op1->where); r->shape = gfc_copy_shape (op1->shape, op1->rank); + if (c->expr->ts.type == BT_CHARACTER) + r->ts.u.cl = c->expr->ts.u.cl; } else { @@ -1572,6 +1574,8 @@ reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), r = gfc_get_array_expr (op1->ts.type, op1->ts.kind, &op1->where); r->shape = gfc_get_shape (op1->rank); + if (op1->ts.type == BT_CHARACTER) + r->ts.u.cl = op1->ts.u.cl; } r->rank = op1->rank; r->corank = op1->corank; @@ -1629,6 +1633,8 @@ reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind, &op2->where); r->shape = gfc_copy_shape (op2->shape, op2->rank); + if (c->expr->ts.type == BT_CHARACTER) + r->ts.u.cl = c->expr->ts.u.cl; } else { @@ -1636,6 +1642,8 @@ reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), r = gfc_get_array_expr (op2->ts.type, op2->ts.kind, &op2->where); r->shape = gfc_get_shape (op2->rank); + if (op2->ts.type == BT_CHARACTER) + r->ts.u.cl = op2->ts.u.cl; } r->rank = op2->rank; r->corank = op2->corank; @@ -1697,11 +1705,15 @@ reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), { /* Handle zero-sized arrays. */ r = gfc_get_array_expr (op1->ts.type, op1->ts.kind, &op1->where); + if (op1->ts.type == BT_CHARACTER) + r->ts.u.cl = op1->ts.u.cl; } else { r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind, &op1->where); + if (c->expr->ts.type == BT_CHARACTER) + r->ts.u.cl = c->expr->ts.u.cl; } r->shape = gfc_copy_shape (op1->shape, op1->rank); r->rank = op1->rank; @@ -1921,6 +1933,29 @@ eval_intrinsic (gfc_intrinsic_op op, || !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2))) goto runtime; + /* For array constructors with explicit type-spec, ensure elements are + converted to the specified type before any operations. This handles + cases like [integer :: ([1.0])] ** 2 where parentheses would otherwise + cause the type-spec to be lost during constant folding. */ + if (op1->expr_type == EXPR_ARRAY && op1->ts.type != BT_UNKNOWN) + gfc_check_constructor_type (op1); + if (op2 != NULL && op2->expr_type == EXPR_ARRAY && op2->ts.type != BT_UNKNOWN) + gfc_check_constructor_type (op2); + + /* For CONCAT operations, also resolve character array constructors to + ensure elements are padded to the specified length before concatenation. + This ensures [character(16):: 'a','b'] // '|' pads to 16 chars first. */ + if (op == INTRINSIC_CONCAT) + { + if (op1->expr_type == EXPR_ARRAY && op1->ts.type == BT_CHARACTER + && op1->ts.u.cl && op1->ts.u.cl->length_from_typespec) + gfc_resolve_character_array_constructor (op1); + if (op2 != NULL && op2->expr_type == EXPR_ARRAY + && op2->ts.type == BT_CHARACTER + && op2->ts.u.cl && op2->ts.u.cl->length_from_typespec) + gfc_resolve_character_array_constructor (op2); + } + if (unary) rc = reduce_unary (eval.f2, op1, &result); else diff --git a/gcc/fortran/array.cc b/gcc/fortran/array.cc index 8f00049..471f0cb 100644 --- a/gcc/fortran/array.cc +++ b/gcc/fortran/array.cc @@ -1344,6 +1344,7 @@ gfc_match_array_constructor (gfc_expr **result) match m; const char *end_delim; bool seen_ts; + gfc_namespace *old_ns = gfc_current_ns; head = NULL; seen_ts = false; @@ -1368,6 +1369,8 @@ gfc_match_array_constructor (gfc_expr **result) /* Try to match an optional "type-spec ::" */ gfc_clear_ts (&ts); m = gfc_match_type_spec (&ts); + gfc_current_ns = old_ns; + if (m == MATCH_YES) { seen_ts = (gfc_match (" ::") == MATCH_YES); @@ -1549,10 +1552,37 @@ check_constructor_type (gfc_constructor_base base, bool convert) { e = c->expr; + /* Simplify non-constant expressions (like parenthesized arrays) so type + conversion can work on the simplified result. This handles cases like + [integer :: ([1.0])] where ([1.0]) is an EXPR_OP that needs to be + simplified to an EXPR_ARRAY before type conversion. */ + if (convert && e->expr_type != EXPR_CONSTANT + && e->expr_type != EXPR_ARRAY) + gfc_simplify_expr (e, 0); + if (e->expr_type == EXPR_ARRAY) { - if (!check_constructor_type (e->value.constructor, convert)) - return false; + /* If the outer constructor has no type-spec (convert=false) and + the nested array has an explicit type-spec, process it separately + so its elements get converted according to its type-spec. This + handles cases like [[character(16) :: ['a','b']]] where the outer + constructor has no type-spec but the inner one does. + gfc_check_constructor_type will also update the global + constructor_ts and cons_state which propagates the type info + to the outer constructor. + For character types, length_from_typespec indicates an explicit + type-spec was provided. */ + if (!convert && e->ts.type == BT_CHARACTER + && e->ts.u.cl && e->ts.u.cl->length_from_typespec) + { + if (!gfc_check_constructor_type (e)) + return false; + } + else + { + if (!check_constructor_type (e->value.constructor, convert)) + return false; + } continue; } @@ -1644,6 +1674,12 @@ check_constructor (gfc_constructor_base ctor, bool (*check_function) (gfc_expr * if (!e) continue; + /* Allow procedures as potential target of a procedure pointer. */ + if (e->expr_type == EXPR_VARIABLE + && e->ts.type == BT_PROCEDURE + && e->symtree->n.sym->attr.flavor == FL_PROCEDURE) + continue; + if (e->expr_type != EXPR_ARRAY) { if (!(*check_function)(e)) @@ -2255,10 +2291,14 @@ gfc_resolve_character_array_constructor (gfc_expr *expr) { gfc_constructor *p; HOST_WIDE_INT found_length; + bool has_ts; gcc_assert (expr->expr_type == EXPR_ARRAY); gcc_assert (expr->ts.type == BT_CHARACTER); + /* Check if we have an explicit type-spec with length. */ + has_ts = expr->ts.u.cl && expr->ts.u.cl->length_from_typespec; + if (expr->ts.u.cl == NULL) { for (p = gfc_constructor_first (expr->value.constructor); @@ -2361,28 +2401,56 @@ got_charlen: if (found_length != -1) for (p = gfc_constructor_first (expr->value.constructor); p; p = gfc_constructor_next (p)) - if (p->expr->expr_type == EXPR_CONSTANT) - { - gfc_expr *cl = NULL; - HOST_WIDE_INT current_length = -1; - bool has_ts; + { + /* For non-constant expressions (like EXPR_OP from concatenation), + try to simplify them first so we can then pad/truncate. */ + if (p->expr->expr_type != EXPR_CONSTANT + && p->expr->ts.type == BT_CHARACTER) + gfc_simplify_expr (p->expr, 0); - if (p->expr->ts.u.cl && p->expr->ts.u.cl->length) + if (p->expr->expr_type == EXPR_CONSTANT) { - cl = p->expr->ts.u.cl->length; - gfc_extract_hwi (cl, ¤t_length); + gfc_expr *cl = NULL; + HOST_WIDE_INT current_length = -1; + + if (p->expr->ts.u.cl && p->expr->ts.u.cl->length) + { + cl = p->expr->ts.u.cl->length; + gfc_extract_hwi (cl, ¤t_length); + } + + /* If gfc_extract_int above set current_length, we implicitly + know the type is BT_INTEGER and it's EXPR_CONSTANT. */ + + if (! cl + || (current_length != -1 && current_length != found_length)) + gfc_set_constant_character_len (found_length, p->expr, + has_ts ? -1 : found_length); } - - /* If gfc_extract_int above set current_length, we implicitly - know the type is BT_INTEGER and it's EXPR_CONSTANT. */ - - has_ts = expr->ts.u.cl->length_from_typespec; - - if (! cl - || (current_length != -1 && current_length != found_length)) - gfc_set_constant_character_len (found_length, p->expr, - has_ts ? -1 : found_length); - } + else if (p->expr->expr_type == EXPR_ARRAY) + { + /* For nested array constructors, propagate the type-spec and + recursively resolve. This handles cases like + [character(16) :: ['a','b']] // "|". The inner constructor + may have BT_UNKNOWN type initially. */ + if (p->expr->ts.type == BT_UNKNOWN + || p->expr->ts.type == BT_CHARACTER) + { + if (p->expr->ts.type == BT_CHARACTER + && p->expr->ts.u.cl + && p->expr->ts.u.cl->length_from_typespec) + { + /* If the inner array has an explicit type-spec, we must + honor it first (e.g. truncate/pad to its length), + before coercing it to the outer length. */ + gfc_resolve_character_array_constructor (p->expr); + } + + p->expr->ts = expr->ts; + gfc_resolve_character_array_constructor (p->expr); + } + } + } } return true; diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc index a1c6faf..079240c 100644 --- a/gcc/fortran/class.cc +++ b/gcc/fortran/class.cc @@ -1733,10 +1733,12 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, { gfc_symbol *final, *array, *fini_coarray, *byte_stride, *sizes, *strides; gfc_symbol *ptr = NULL, *idx, *idx2, *is_contiguous, *offset, *nelem; + gfc_symbol *result = NULL; gfc_component *comp; gfc_namespace *sub_ns; gfc_code *last_code, *block; char *name; + char *result_name; bool finalizable_comp = false; gfc_expr *ancestor_wrapper = NULL, *rank; gfc_iterator *iter; @@ -1824,7 +1826,6 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, final->attr.function = 1; final->attr.pure = 0; final->attr.recursive = 1; - final->result = final; final->ts.type = BT_INTEGER; final->ts.kind = 4; final->attr.artificial = 1; @@ -1832,6 +1833,26 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, final->attr.if_source = IFSRC_DECL; if (ns->proc_name->attr.flavor == FL_MODULE) final->module = ns->proc_name->name; + + /* Create a separate result symbol instead of using final->result = final. + Self-referencing result symbols (final->result = final) create a cycle + in the symbol structure that causes an ICE in gimplify_call_expr when + the finalizer wrapper is used as a procedure pointer initializer. */ + result_name = xasprintf ("__result_%s", tname); + if (gfc_get_symbol (result_name, sub_ns, &result) != 0) + gfc_internal_error ("Failed to create finalizer result symbol"); + free (result_name); + + if (!gfc_add_flavor (&result->attr, FL_VARIABLE, result->name, + &gfc_current_locus) + || !gfc_add_result (&result->attr, result->name, &gfc_current_locus)) + gfc_internal_error ("Failed to set finalizer result attributes"); + + result->ts = final->ts; + result->attr.artificial = 1; + gfc_set_sym_referenced (result); + gfc_commit_symbol (result); + final->result = result; gfc_set_sym_referenced (final); gfc_commit_symbol (final); @@ -1959,7 +1980,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, /* Set return value to 0. */ last_code = gfc_get_code (EXEC_ASSIGN); - last_code->expr1 = gfc_lval_expr_from_sym (final); + last_code->expr1 = gfc_lval_expr_from_sym (result); last_code->expr2 = gfc_get_int_expr (4, NULL, 0); sub_ns->code = last_code; diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc index 5b222cd..0e55171 100644 --- a/gcc/fortran/decl.cc +++ b/gcc/fortran/decl.cc @@ -1217,6 +1217,10 @@ match_char_length (gfc_expr **expr, bool *deferred, bool obsolescent_check) goto syntax; } + if (obsolescent_check + && !gfc_notify_std (GFC_STD_F95_OBS, "Old-style character length at %C")) + return MATCH_ERROR; + return MATCH_YES; syntax: @@ -1537,9 +1541,47 @@ gfc_verify_c_interop_param (gfc_symbol *sym) { if (sym->ns->proc_name->attr.is_bind_c == 1) { + bool f2018_allowed = gfc_option.allow_std & ~GFC_STD_OPT_F08; + bool f2018_added = false; + is_c_interop = (gfc_verify_c_interop(&(sym->ts)) ? 1 : 0); - if (is_c_interop != 1) + /* F2018:18.3.6 has the following text: + "(5) any dummy argument without the VALUE attribute corresponds to + a formal parameter of the prototype that is of a pointer type, and + either + • the dummy argument is interoperable with an entity of the + referenced type (ISO/IEC 9899:2011, 6.2.5, 7.19, and 7.20.1) of + the formal parameter (this is equivalent to the F2008 text), + • the dummy argument is a nonallocatable nonpointer variable of + type CHARACTER with assumed character length and the formal + parameter is a pointer to CFI_cdesc_t, + • the dummy argument is allocatable, assumed-shape, assumed-rank, + or a pointer without the CONTIGUOUS attribute, and the formal + parameter is a pointer to CFI_cdesc_t, or + • the dummy argument is assumed-type and not allocatable, + assumed-shape, assumed-rank, or a pointer, and the formal + parameter is a pointer to void," */ + if (is_c_interop == 0 && !sym->attr.value && f2018_allowed) + { + bool as_ar = (sym->as + && (sym->as->type == AS_ASSUMED_SHAPE + || sym->as->type == AS_ASSUMED_RANK)); + bool cond1 = (sym->ts.type == BT_CHARACTER + && !(sym->ts.u.cl && sym->ts.u.cl->length) + && !sym->attr.allocatable + && !sym->attr.pointer); + bool cond2 = (sym->attr.allocatable + || as_ar + || (IS_POINTER (sym) && !sym->attr.contiguous)); + bool cond3 = (sym->ts.type == BT_ASSUMED + && !sym->attr.allocatable + && !sym->attr.pointer + && !as_ar); + f2018_added = cond1 || cond2 || cond3; + } + + if (is_c_interop != 1 && !f2018_added) { /* Make personalized messages to give better feedback. */ if (sym->ts.type == BT_DERIVED) @@ -3931,6 +3973,7 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, gfc_expr *kind_expr; gfc_component *c1, *c2; match m; + gfc_symtree *s = NULL; type_param_spec_list = NULL; @@ -3944,8 +3987,7 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, if (gfc_current_state () == COMP_DERIVED && !(gfc_state_stack->previous && gfc_state_stack->previous->state == COMP_DERIVED) - && gfc_current_block ()->attr.pdt_template - && !strcmp (gfc_current_block ()->name, (*sym)->name)) + && gfc_current_block ()->attr.pdt_template) { if (ext_param_list) *ext_param_list = gfc_copy_actual_arglist (param_list); @@ -4141,10 +4183,29 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, goto error_return; } + /* If we are in an interface body, the instance will not have been imported. + Make sure that it is imported implicitly. */ + s = gfc_find_symtree (gfc_current_ns->sym_root, pdt->name); + if (gfc_current_ns->proc_name + && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY + && s && s->import_only && pdt->attr.imported) + { + s = gfc_find_symtree (gfc_current_ns->sym_root, instance->name); + if (!s) + { + gfc_get_sym_tree (instance->name, gfc_current_ns, &s, false, + &gfc_current_locus); + s->n.sym = instance; + } + s->n.sym->attr.imported = 1; + s->import_only = 1; + } + m = MATCH_YES; if (instance->attr.flavor == FL_DERIVED - && instance->attr.pdt_type) + && instance->attr.pdt_type + && instance->components) { instance->refs++; if (ext_param_list) @@ -4162,6 +4223,16 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, instance->attr.pdt_type = 1; instance->declared_at = gfc_current_locus; + /* In resolution, the finalizers are copied, according to the type of the + argument, to the instance finalizers. However, they are retained by the + template and procedures are freed there. */ + if (pdt->f2k_derived && pdt->f2k_derived->finalizers) + { + instance->f2k_derived = gfc_get_namespace (NULL, 0); + instance->template_sym = pdt; + *instance->f2k_derived = *pdt->f2k_derived; + } + /* Add the components, replacing the parameters in all expressions with the expressions for their values in 'type_param_spec_list'. */ c1 = pdt->components; @@ -4191,30 +4262,36 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, to obtain the instance of the extended type. */ if (gfc_current_state () != COMP_DERIVED && c1 == pdt->components - && (c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS) - && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template + && c1->ts.type == BT_DERIVED + && c1->ts.u.derived && gfc_get_derived_super_type (*sym) == c2->ts.u.derived) { - gfc_formal_arglist *f; + if (c1->ts.u.derived->attr.pdt_template) + { + gfc_formal_arglist *f; - old_param_spec_list = type_param_spec_list; + old_param_spec_list = type_param_spec_list; - /* Obtain a spec list appropriate to the extended type..*/ - actual_param = gfc_copy_actual_arglist (type_param_spec_list); - type_param_spec_list = actual_param; - for (f = c1->ts.u.derived->formal; f && f->next; f = f->next) - actual_param = actual_param->next; - if (actual_param) - { - gfc_free_actual_arglist (actual_param->next); - actual_param->next = NULL; - } + /* Obtain a spec list appropriate to the extended type..*/ + actual_param = gfc_copy_actual_arglist (type_param_spec_list); + type_param_spec_list = actual_param; + for (f = c1->ts.u.derived->formal; f && f->next; f = f->next) + actual_param = actual_param->next; + if (actual_param) + { + gfc_free_actual_arglist (actual_param->next); + actual_param->next = NULL; + } - /* Now obtain the PDT instance for the extended type. */ - c2->param_list = type_param_spec_list; - m = gfc_get_pdt_instance (type_param_spec_list, &c2->ts.u.derived, - &c2->param_list); - type_param_spec_list = old_param_spec_list; + /* Now obtain the PDT instance for the extended type. */ + c2->param_list = type_param_spec_list; + m = gfc_get_pdt_instance (type_param_spec_list, + &c2->ts.u.derived, + &c2->param_list); + type_param_spec_list = old_param_spec_list; + } + else + c2->ts = c1->ts; c2->ts.u.derived->refs++; gfc_set_sym_referenced (c2->ts.u.derived); @@ -4393,7 +4470,25 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, type_param_spec_list = old_param_spec_list; if (!(c2->attr.pointer || c2->attr.allocatable)) - c2->initializer = gfc_default_initializer (&c2->ts); + { + if (!c1->initializer + || c1->initializer->expr_type != EXPR_FUNCTION) + c2->initializer = gfc_default_initializer (&c2->ts); + else + { + gfc_symtree *s; + c2->initializer = gfc_copy_expr (c1->initializer); + s = gfc_find_symtree (pdt->ns->sym_root, + gfc_dt_lower_string (c2->ts.u.derived->name)); + if (s) + c2->initializer->symtree = s; + c2->initializer->ts = c2->ts; + if (!s) + gfc_insert_parameter_exprs (c2->initializer, + type_param_spec_list); + gfc_simplify_expr (params->expr, 1); + } + } if (c2->attr.allocatable) instance->attr.alloc_comp = 1; @@ -4780,6 +4875,31 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) return m; } + /* This picks up function declarations with a PDT typespec. Since a + pdt_type has been generated, there is no more to do. Within the + function body, this type must be used for the typespec so that + the "being used before it is defined warning" does not arise. */ + if (ts->type == BT_DERIVED + && sym && sym->attr.pdt_type + && (gfc_current_state () == COMP_CONTAINS + || (gfc_current_state () == COMP_FUNCTION + && gfc_current_block ()->ts.type == BT_DERIVED + && gfc_current_block ()->ts.u.derived == sym + && !gfc_find_symtree (gfc_current_ns->sym_root, + sym->name)))) + { + if (gfc_current_state () == COMP_FUNCTION) + { + gfc_symtree *pdt_st; + pdt_st = gfc_new_symtree (&gfc_current_ns->sym_root, + sym->name); + pdt_st->n.sym = sym; + sym->refs++; + } + ts->u.derived = sym; + return MATCH_YES; + } + /* Defer association of the derived type until the end of the specification block. However, if the derived type can be found, add it to the typespec. */ @@ -4816,7 +4936,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) dt_sym = gfc_find_dt_in_generic (sym); /* Host associated PDTs can get confused with their constructors - because they ar instantiated in the template's namespace. */ + because they are instantiated in the template's namespace. */ if (!dt_sym) { if (gfc_find_symbol (dt_name, NULL, 1, &dt_sym)) diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc index eda0659..2a4ebb0 100644 --- a/gcc/fortran/dump-parse-tree.cc +++ b/gcc/fortran/dump-parse-tree.cc @@ -843,6 +843,8 @@ show_attr (symbol_attribute *attr, const char * module) fputs (" VALUE", dumpfile); if (attr->volatile_) fputs (" VOLATILE", dumpfile); + if (attr->omp_groupprivate) + fputs (" GROUPPRIVATE", dumpfile); if (attr->threadprivate) fputs (" THREADPRIVATE", dumpfile); if (attr->temporary) @@ -938,6 +940,8 @@ show_attr (symbol_attribute *attr, const char * module) fputs (" OMP-DECLARE-TARGET", dumpfile); if (attr->omp_declare_target_link) fputs (" OMP-DECLARE-TARGET-LINK", dumpfile); + if (attr->omp_declare_target_local) + fputs (" OMP-DECLARE-TARGET-LOCAL", dumpfile); if (attr->omp_declare_target_indirect) fputs (" OMP-DECLARE-TARGET-INDIRECT", dumpfile); if (attr->omp_device_type == OMP_DEVICE_TYPE_HOST) @@ -2211,6 +2215,20 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses) fputs (" DEPEND(source)", dumpfile); if (omp_clauses->doacross_source) fputs (" DOACROSS(source:)", dumpfile); + if (omp_clauses->dyn_groupprivate) + { + fputs (" DYN_GROUPPRIVATE(", dumpfile); + if (omp_clauses->fallback != OMP_FALLBACK_NONE) + fputs ("FALLBACK(", dumpfile); + if (omp_clauses->fallback == OMP_FALLBACK_ABORT) + fputs ("ABORT):", dumpfile); + else if (omp_clauses->fallback == OMP_FALLBACK_DEFAULT_MEM) + fputs ("DEFAULT_MEM):", dumpfile); + else if (omp_clauses->fallback == OMP_FALLBACK_NULL) + fputs ("NULL):", dumpfile); + show_expr (omp_clauses->dyn_groupprivate); + fputc (')', dumpfile); + } if (omp_clauses->capture) fputs (" CAPTURE", dumpfile); if (omp_clauses->depobj_update != OMP_DEPEND_UNSET) diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc index a11ff79..054276e 100644 --- a/gcc/fortran/expr.cc +++ b/gcc/fortran/expr.cc @@ -4577,7 +4577,8 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue, return false; } - if (lvalue->rank != rvalue->rank && !rank_remap) + if (lvalue->rank != rvalue->rank && !rank_remap + && !(rvalue->expr_type == EXPR_NULL && is_init_expr)) { gfc_error ("Different ranks in pointer assignment at %L", &lvalue->where); return false; @@ -6405,6 +6406,14 @@ gfc_is_simply_contiguous (gfc_expr *expr, bool strict, bool permit_element) || (sym->as && sym->as->type == AS_ASSUMED_SHAPE)))) return false; + /* An associate variable may point to a non-contiguous target. */ + if (ar && ar->type == AR_FULL + && sym->attr.associate_var && !sym->attr.contiguous + && sym->assoc + && sym->assoc->target) + return gfc_is_simply_contiguous (sym->assoc->target, strict, + permit_element); + if (!ar || ar->type == AR_FULL) return true; diff --git a/gcc/fortran/frontend-passes.cc b/gcc/fortran/frontend-passes.cc index 595c509..b699231 100644 --- a/gcc/fortran/frontend-passes.cc +++ b/gcc/fortran/frontend-passes.cc @@ -5645,6 +5645,7 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn, WALK_SUBEXPR (co->ext.omp_clauses->num_tasks); WALK_SUBEXPR (co->ext.omp_clauses->priority); WALK_SUBEXPR (co->ext.omp_clauses->detach); + WALK_SUBEXPR (co->ext.omp_clauses->dyn_groupprivate); WALK_SUBEXPR (co->ext.omp_clauses->novariants); WALK_SUBEXPR (co->ext.omp_clauses->nocontext); for (idx = 0; idx < ARRAY_SIZE (list_types); idx++) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 19473df..72aecfb 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -311,6 +311,7 @@ enum gfc_statement ST_OMP_TASKLOOP, ST_OMP_END_TASKLOOP, ST_OMP_SCAN, ST_OMP_DEPOBJ, ST_OMP_TASKLOOP_SIMD, ST_OMP_END_TASKLOOP_SIMD, ST_OMP_ORDERED_DEPEND, ST_OMP_REQUIRES, ST_PROCEDURE, ST_GENERIC, ST_CRITICAL, ST_END_CRITICAL, + ST_OMP_GROUPPRIVATE, ST_GET_FCN_CHARACTERISTICS, ST_LOCK, ST_UNLOCK, ST_EVENT_POST, ST_EVENT_WAIT, ST_FAIL_IMAGE, ST_FORM_TEAM, ST_CHANGE_TEAM, ST_END_TEAM, ST_SYNC_TEAM, ST_OMP_PARALLEL_MASTER, @@ -1042,8 +1043,10 @@ typedef struct /* Mentioned in OMP DECLARE TARGET. */ unsigned omp_declare_target:1; unsigned omp_declare_target_link:1; + unsigned omp_declare_target_local:1; unsigned omp_declare_target_indirect:1; ENUM_BITFIELD (gfc_omp_device_type) omp_device_type:2; + unsigned omp_groupprivate:1; unsigned omp_allocate:1; /* Mentioned in OACC DECLARE. */ @@ -1488,6 +1491,7 @@ enum OMP_LIST_TASK_REDUCTION, OMP_LIST_DEVICE_RESIDENT, OMP_LIST_LINK, + OMP_LIST_LOCAL, OMP_LIST_USE_DEVICE, OMP_LIST_CACHE, OMP_LIST_IS_DEVICE_PTR, @@ -1614,6 +1618,14 @@ enum gfc_omp_bind_type OMP_BIND_THREAD }; +enum gfc_omp_fallback +{ + OMP_FALLBACK_NONE, + OMP_FALLBACK_ABORT, + OMP_FALLBACK_DEFAULT_MEM, + OMP_FALLBACK_NULL +}; + typedef struct gfc_omp_assumptions { int n_absent, n_contains; @@ -1649,6 +1661,7 @@ typedef struct gfc_omp_clauses struct gfc_expr *detach; struct gfc_expr *depobj; struct gfc_expr *dist_chunk_size; + struct gfc_expr *dyn_groupprivate; struct gfc_expr *message; struct gfc_expr *novariants; struct gfc_expr *nocontext; @@ -1681,6 +1694,7 @@ typedef struct gfc_omp_clauses ENUM_BITFIELD (gfc_omp_at_type) at:2; ENUM_BITFIELD (gfc_omp_severity_type) severity:2; ENUM_BITFIELD (gfc_omp_sched_kind) dist_sched_kind:3; + ENUM_BITFIELD (gfc_omp_fallback) fallback:2; /* OpenACC. */ struct gfc_expr *async_expr; @@ -1958,6 +1972,7 @@ typedef struct gfc_symbol /* List of PDT parameter expressions */ struct gfc_actual_arglist *param_list; + struct gfc_symbol *template_sym; struct gfc_expr *value; /* Parameter/Initializer value */ gfc_array_spec *as; @@ -2117,6 +2132,8 @@ typedef struct gfc_common_head char use_assoc, saved, threadprivate; unsigned char omp_declare_target : 1; unsigned char omp_declare_target_link : 1; + unsigned char omp_declare_target_local : 1; + unsigned char omp_groupprivate : 1; ENUM_BITFIELD (gfc_omp_device_type) omp_device_type:2; /* Provide sufficient space to hold "symbol.symbol.eq.1234567890". */ char name[2*GFC_MAX_SYMBOL_LEN + 1 + 14 + 1]; @@ -3101,6 +3118,8 @@ typedef struct gfc_forall_iterator { gfc_expr *var, *start, *end, *stride; gfc_loop_annot annot; + /* index-name shadows a variable from outer scope. */ + bool shadow; struct gfc_forall_iterator *next; } gfc_forall_iterator; @@ -3714,6 +3733,9 @@ bool gfc_add_threadprivate (symbol_attribute *, const char *, locus *); bool gfc_add_omp_declare_target (symbol_attribute *, const char *, locus *); bool gfc_add_omp_declare_target_link (symbol_attribute *, const char *, locus *); +bool gfc_add_omp_declare_target_local (symbol_attribute *, const char *, + locus *); +bool gfc_add_omp_groupprivate (symbol_attribute *, const char *, locus *); bool gfc_add_target (symbol_attribute *, locus *); bool gfc_add_dummy (symbol_attribute *, const char *, locus *); bool gfc_add_generic (symbol_attribute *, const char *, locus *); @@ -3760,6 +3782,7 @@ gfc_st_label *gfc_get_st_label (int); void gfc_free_st_label (gfc_st_label *); void gfc_define_st_label (gfc_st_label *, gfc_sl_type, locus *); bool gfc_reference_st_label (gfc_st_label *, gfc_sl_type); +gfc_st_label *gfc_rebind_label (gfc_st_label *, int); gfc_namespace *gfc_get_namespace (gfc_namespace *, int); gfc_symtree *gfc_new_symtree (gfc_symtree **, const char *); diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi index 841f613..0f7572b 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -1186,7 +1186,6 @@ extensions. @menu * Extensions implemented in GNU Fortran:: * Extensions not implemented in GNU Fortran:: -* Experimental features for future Fortran versions:: @end menu @@ -1242,6 +1241,7 @@ additional compatibility extensions along with those enabled by * Extended I/O specifiers:: * Legacy PARAMETER statements:: * Default exponents:: +* Unsigned integers:: @end menu @node Old-style kind specifications @@ -1839,7 +1839,7 @@ in free form; and the @code{c$}, @code{*$} and @code{!$} sentinels in fixed form, @command{gfortran} needs to be invoked with the @option{-fopenmp} option. This option also arranges for automatic linking of the OpenMP runtime library. -@xref{,,,libgomp,GNU Offloading and Multi Processing Runtime Library}. +@xref{Top,,,libgomp,GNU Offloading and Multi Processing Runtime Library}. The OpenMP Fortran runtime library routines are provided both in a form of a Fortran 90 module named @code{omp_lib} and in a form of @@ -1900,7 +1900,7 @@ sentinels in free form; and the @code{c$}, @code{*$} and @code{!$} sentinels in fixed form, @command{gfortran} needs to be invoked with the @option{-fopenacc} option. This option also arranges for automatic linking of the OpenACC runtime library. -@xref{,,,libgomp,GNU Offloading and Multi Processing Runtime Library}. +@xref{Top,,,libgomp,GNU Offloading and Multi Processing Runtime Library}. The OpenACC Fortran runtime library routines are provided both in a form of a Fortran 90 module named @code{openacc} and in a form of a @@ -2535,6 +2535,141 @@ For compatibility, GNU Fortran supports a default exponent of zero in real constants with @option{-fdec}. For example, @code{9e} would be interpreted as @code{9e0}, rather than an error. +@node Unsigned integers +@subsection Unsigned integers +@cindex Unsigned integers +If the @option{-funsigned} option is given, GNU Fortran supports +unsigned integers according to +@uref{https://j3-fortran.org/doc/year/24/24-116.txt, J3/24-116}. The +data type is called @code{UNSIGNED}. For an unsigned type with @code{n} +bits, it implements integer arithmetic modulo @code{2**n}, comparable +to the @code{unsigned} data type in C. + +The data type has @code{KIND} numbers comparable to other Fortran data +types, which can be selected via the @code{SELECTED_UNSIGNED_KIND} +function. + +Mixed arithmetic, comparisons and assignment between @code{UNSIGNED} +and other types are only possible via explicit conversion. Conversion +from @code{UNSIGNED} to other types is done via type conversion +functions like @code{INT} or @code{REAL}. Conversion from other types +to @code{UNSIGNED} is done via @code{UINT}. Unsigned variables cannot be +used as index variables in @code{DO} loops or as array indices. + +Unsigned numbers have a trailing @code{u} as suffix, optionally followed +by a @code{KIND} number separated by an underscore. + +Input and output can be done using the @samp{I}, @samp{B}, @samp{O} +and @samp{Z} descriptors, plus unformatted I/O. + +Unsigned integers as implemented in gfortran are compatible with flang. + +Here is a small, somewhat contrived example of their use: +@smallexample +program main + use iso_fortran_env, only : uint64 + unsigned(kind=uint64) :: v + v = huge(v) - 32u_uint64 + print *,v +end program main +@end smallexample +@noindent +which outputs the number 18446744073709551583. + +Arithmetic operations work on unsigned integers, also for +exponentiation. As an extension to J3/24-116.txt, unary minus +and exponentiation of unsigned integers are permitted unless +@code{-pedantic} is in force. + +In intrinsic procedures, unsigned arguments are typically permitted +for arguments for the data to be processed, analogous to the +use of @code{REAL} arguments. Unsigned values are prohibited +as index variables in @code{DO} loops and as array indices. + +Unsigned numbers can be read and written using list-directed, +formatted and unformatted I/O. For formatted I/O, the @samp{B}, +@samp{I}, @samp{O} and @samp{Z} descriptors are valid. Negative +values and values that would overflow are rejected with +@code{-pedantic}. + +@code{SELECT CASE} is supported for unsigned integers. + +The following intrinsics take unsigned arguments: +@itemize @bullet +@item @code{BGE}, @pxref{BGE} +@item @code{BGT}, @pxref{BGT} +@item @code{BIT_SIZE}, @pxref{BIT_SIZE} +@item @code{BLE}, @pxref{BLE} +@item @code{BLT}, @pxref{BLT} +@item @code{CMPLX}, @pxref{CMPLX} +@item @code{CSHIFT}, @pxref{CSHIFT} +@item @code{DIGITS}, @pxref{DIGITS} +@item @code{DOT_PRODUCT}, @pxref{DOT_PRODUCT} +@item @code{DSHIFTL}, @pxref{DSHIFTL} +@item @code{DSHIFTR}, @pxref{DSHIFTR} +@item @code{EOSHIFT}, @pxref{EOSHIFT} +@item @code{FINDLOC}, @pxref{FINDLOC} +@item @code{HUGE}, @pxref{HUGE} +@item @code{IALL}, @pxref{IALL} +@item @code{IAND}, @pxref{IAND} +@item @code{IANY}, @pxref{IANY} +@item @code{IBCLR}, @pxref{IBCLR} +@item @code{IBITS}, @pxref{IBITS} +@item @code{IBSET}, @pxref{IBSET} +@item @code{IEOR}, @pxref{IEOR} +@item @code{INT}, @pxref{INT} +@item @code{IOR}, @pxref{IOR} +@item @code{IPARITY}, @pxref{IPARITY} +@item @code{ISHFT}, @pxref{ISHFT} +@item @code{ISHFTC}, @pxref{ISHFTC} +@item @code{MATMUL}, @pxref{MATMUL} +@item @code{MAX}, @pxref{MAX} +@item @code{MAXLOC}, @pxref{MAXLOC} +@item @code{MAXVAL}, @pxref{MAXVAL} +@item @code{MERGE}, @pxref{MERGE} +@item @code{MERGE_BITS}, @pxref{MERGE_BITS} +@item @code{MIN}, @pxref{MIN} +@item @code{MINLOC}, @pxref{MINLOC} +@item @code{MINVAL}, @pxref{MINVAL} +@item @code{MOD}, @pxref{MOD} +@item @code{MODULO}, @pxref{MODULO} +@item @code{MVBITS}, @pxref{MVBITS} +@item @code{NOT}, @pxref{NOT} +@item @code{OUT_OF_RANGE}, @pxref{OUT_OF_RANGE} +@item @code{PRODUCT}, @pxref{PRODUCT} +@item @code{RANDOM_NUMBER}, @pxref{RANDOM_NUMBER} +@item @code{RANGE}, @pxref{RANGE} +@item @code{REAL}, @pxref{REAL} +@item @code{SHIFTA}, @pxref{SHIFTA} +@item @code{SHIFTL}, @pxref{SHIFTL} +@item @code{SHIFTR}, @pxref{SHIFTR} +@item @code{SUM}, @pxref{SUM} +@item @code{TRANSPOSE}, @pxref{TRANSPOSE} +@item @code{TRANSFER}, @pxref{TRANSFER} +@end itemize + +The following intrinsics are enabled with @option{-funsigned}: +@itemize @bullet +@item @code{UINT}, @pxref{UINT} +@item @code{UMASKL}, @pxref{UMASKL} +@item @code{UMASKR}, @pxref{UMASKR} +@item @code{SELECTED_UNSIGNED_KIND}, @pxref{SELECTED_UNSIGNED_KIND} +@end itemize + +The following constants have been added to the intrinsic +@code{ISO_C_BINDING} module: @code{c_unsigned}, +@code{c_unsigned_short}, @code{c_unsigned_char}, +@code{c_unsigned_long}, @code{c_unsigned_long_long}, +@code{c_uintmax_t}, @code{c_uint8_t}, @code{c_uint16_t}, +@code{c_uint32_t}, @code{c_uint64_t}, @code{c_uint128_t}, +@code{c_uint_fast8_t}, @code{c_uint_fast16_t}, @code{c_uint_fast32_t}, +@code{c_uint_fast64_t}, @code{c_uint_fast128_t}, +@code{c_uint_least8_t}, @code{c_uint_least16_t}, @code{c_uint_least32_t}, +@code{c_uint_least64_t} and @code{c_uint_least128_t}. + +The following constants have been added to the intrinsic +@code{ISO_FORTRAN_ENV} module: @code{uint8}, @code{uint16}, +@code{uint32} and @code{uint64}. @node Extensions not implemented in GNU Fortran @section Extensions not implemented in GNU Fortran @@ -2715,157 +2850,6 @@ descriptor occurred, use @code{INQUIRE} to get the file position, count the characters up to the next @code{NEW_LINE} and then start reading from the position marked previously. -@node Experimental features for future Fortran versions -@section Experimental features future Fortran versions -@cindex Future Fortran versions - -GNU Fortran supports some experimental features that have been -proposed and accepted by the J3 standards committee. These -exist to give users a chance to try them out, and to provide -a reference implementation. - -As these features have not been included in the worklist for Fortran -202Y by WG5, there is a chance that a version in any upcoming standard -will differ from what GNU Fortran currently implements. These -features are therefore currently classified as an extension. - -@menu -* Unsigned integers:: -@end menu - -@node Unsigned integers -@subsection Unsigned integers -@cindex Unsigned integers -If the @option{-funsigned} option is given, GNU Fortran supports -unsigned integers according to -@uref{https://j3-fortran.org/doc/year/24/24-116.txt, J3/24-116}. The -data type is called @code{UNSIGNED}. For an unsigned type with @code{n} -bits, it implements integer arithmetic modulo @code{2**n}, comparable -to the @code{unsigned} data type in C. - -The data type has @code{KIND} numbers comparable to other Fortran data -types, which can be selected via the @code{SELECTED_UNSIGNED_KIND} -function. - -Mixed arithmetic, comparisons and assignment between @code{UNSIGNED} -and other types are only possible via explicit conversion. Conversion -from @code{UNSIGNED} to other types is done via type conversion -functions like @code{INT} or @code{REAL}. Conversion from other types -to @code{UNSIGNED} is done via @code{UINT}. Unsigned variables cannot be -used as index variables in @code{DO} loops or as array indices. - -Unsigned numbers have a trailing @code{u} as suffix, optionally followed -by a @code{KIND} number separated by an underscore. - -Input and output can be done using the @samp{I}, @samp{B}, @samp{O} -and @samp{Z} descriptors, plus unformatted I/O. - -Here is a small, somewhat contrived example of their use: -@smallexample -program main - use iso_fortran_env, only : uint64 - unsigned(kind=uint64) :: v - v = huge(v) - 32u_uint64 - print *,v -end program main -@end smallexample -@noindent -which outputs the number 18446744073709551583. - -Arithmetic operations work on unsigned integers, also for -exponentiation. As an extension to J3/24-116.txt, unary minus -and exponentiation of unsigned integers are permitted unless -@code{-pedantic} is in force. - -In intrinsic procedures, unsigned arguments are typically permitted -for arguments for the data to be processed, analogous to the -use of @code{REAL} arguments. Unsigned values are prohibited -as index variables in @code{DO} loops and as array indices. - -Unsigned numbers can be read and written using list-directed, -formatted and unformatted I/O. For formatted I/O, the @samp{B}, -@samp{I}, @samp{O} and @samp{Z} descriptors are valid. Negative -values and values that would overflow are rejected with -@code{-pedantic}. - -@code{SELECT CASE} is supported for unsigned integers. - -The following intrinsics take unsigned arguments: -@itemize @bullet -@item @code{BGE}, @pxref{BGE} -@item @code{BGT}, @pxref{BGT} -@item @code{BIT_SIZE}, @pxref{BIT_SIZE} -@item @code{BLE}, @pxref{BLE} -@item @code{BLT}, @pxref{BLT} -@item @code{CMPLX}, @pxref{CMPLX} -@item @code{CSHIFT}, @pxref{CSHIFT} -@item @code{DIGITS}, @pxref{DIGITS} -@item @code{DOT_PRODUCT}, @pxref{DOT_PRODUCT} -@item @code{DSHIFTL}, @pxref{DSHIFTL} -@item @code{DSHIFTR}, @pxref{DSHIFTR} -@item @code{EOSHIFT}, @pxref{EOSHIFT} -@item @code{FINDLOC}, @pxref{FINDLOC} -@item @code{HUGE}, @pxref{HUGE} -@item @code{IALL}, @pxref{IALL} -@item @code{IAND}, @pxref{IAND} -@item @code{IANY}, @pxref{IANY} -@item @code{IBCLR}, @pxref{IBCLR} -@item @code{IBITS}, @pxref{IBITS} -@item @code{IBSET}, @pxref{IBSET} -@item @code{IEOR}, @pxref{IEOR} -@item @code{INT}, @pxref{INT} -@item @code{IOR}, @pxref{IOR} -@item @code{IPARITY}, @pxref{IPARITY} -@item @code{ISHFT}, @pxref{ISHFT} -@item @code{ISHFTC}, @pxref{ISHFTC} -@item @code{MATMUL}, @pxref{MATMUL} -@item @code{MAX}, @pxref{MAX} -@item @code{MAXLOC}, @pxref{MAXLOC} -@item @code{MAXVAL}, @pxref{MAXVAL} -@item @code{MERGE}, @pxref{MERGE} -@item @code{MERGE_BITS}, @pxref{MERGE_BITS} -@item @code{MIN}, @pxref{MIN} -@item @code{MINLOC}, @pxref{MINLOC} -@item @code{MINVAL}, @pxref{MINVAL} -@item @code{MOD}, @pxref{MOD} -@item @code{MODULO}, @pxref{MODULO} -@item @code{MVBITS}, @pxref{MVBITS} -@item @code{NOT}, @pxref{NOT} -@item @code{OUT_OF_RANGE}, @pxref{OUT_OF_RANGE} -@item @code{PRODUCT}, @pxref{PRODUCT} -@item @code{RANDOM_NUMBER}, @pxref{RANDOM_NUMBER} -@item @code{RANGE}, @pxref{RANGE} -@item @code{REAL}, @pxref{REAL} -@item @code{SHIFTA}, @pxref{SHIFTA} -@item @code{SHIFTL}, @pxref{SHIFTL} -@item @code{SHIFTR}, @pxref{SHIFTR} -@item @code{SUM}, @pxref{SUM} -@item @code{TRANSPOSE}, @pxref{TRANSPOSE} -@item @code{TRANSFER}, @pxref{TRANSFER} -@end itemize - -The following intrinsics are enabled with @option{-funsigned}: -@itemize @bullet -@item @code{UINT}, @pxref{UINT} -@item @code{UMASKL}, @pxref{UMASKL} -@item @code{UMASKR}, @pxref{UMASKR} -@item @code{SELECTED_UNSIGNED_KIND}, @pxref{SELECTED_UNSIGNED_KIND} -@end itemize - -The following constants have been added to the intrinsic -@code{ISO_C_BINDING} module: @code{c_unsigned}, -@code{c_unsigned_short}, @code{c_unsigned_char}, -@code{c_unsigned_long}, @code{c_unsigned_long_long}, -@code{c_uintmax_t}, @code{c_uint8_t}, @code{c_uint16_t}, -@code{c_uint32_t}, @code{c_uint64_t}, @code{c_uint128_t}, -@code{c_uint_fast8_t}, @code{c_uint_fast16_t}, @code{c_uint_fast32_t}, -@code{c_uint_fast64_t}, @code{c_uint_fast128_t}, -@code{c_uint_least8_t}, @code{c_uint_least16_t}, @code{c_uint_least32_t}, -@code{c_uint_least64_t} and @code{c_uint_least128_t}. - -The following constants have been added to the intrinsic -@code{ISO_FORTRAN_ENV} module: @code{uint8}, @code{uint16}, -@code{uint32} and @code{uint64}. @c --------------------------------------------------------------------- @c --------------------------------------------------------------------- diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index b2d1e45..c4c000b 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -15546,7 +15546,7 @@ Fortran 2008 and later @node UINT @section @code{UINT} -- Convert to @code{UNSIGNED} type @fnindex UINT -@cindex, conversion, to unsigned +@cindex conversion, to unsigned @table @asis @item @emph{Synopsis}: @@ -16250,6 +16250,7 @@ The following scalar default-integer named constants: @table @asis @item @code{omp_initial_device} @item @code{omp_invalid_device} +@item @code{omp_default_device} @end table diff --git a/gcc/fortran/lang.opt.urls b/gcc/fortran/lang.opt.urls index 4a51f5a..cdb0ba8 100644 --- a/gcc/fortran/lang.opt.urls +++ b/gcc/fortran/lang.opt.urls @@ -1,8 +1,5 @@ ; Autogenerated by regenerate-opt-urls.py from gcc/fortran/lang.opt and generated HTML -A -UrlSuffix(gcc/Preprocessor-Options.html#index-A) - C UrlSuffix(gcc/Preprocessor-Options.html#index-C) LangUrlSuffix_Fortran(gfortran/Preprocessing-Options.html#index-C) @@ -20,7 +17,7 @@ H UrlSuffix(gcc/Preprocessor-Options.html#index-H) LangUrlSuffix_D(gdc/Code-Generation.html#index-H) LangUrlSuffix_Fortran(gfortran/Preprocessing-Options.html#index-H) I -UrlSuffix(gcc/Directory-Options.html#index-I) LangUrlSuffix_D(gdc/Directory-Options.html#index-I) +UrlSuffix(gcc/Directory-Options.html#index-I) LangUrlSuffix_D(gdc/Directory-Options.html#index-I) LangUrlSuffix_Algol68(ga68/Directory-options.html#index-I) J LangUrlSuffix_D(gdc/Directory-Options.html#index-J) @@ -428,7 +425,7 @@ fcoarray= LangUrlSuffix_Fortran(gfortran/Code-Gen-Options.html#index-fcoarray) fcheck= -LangUrlSuffix_Fortran(gfortran/Code-Gen-Options.html#index-fcheck) +LangUrlSuffix_Fortran(gfortran/Code-Gen-Options.html#index-fcheck) LangUrlSuffix_Algol68(ga68/Runtime-options.html#index-fcheck) fsecond-underscore LangUrlSuffix_Fortran(gfortran/Code-Gen-Options.html#index-fsecond-underscore) diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc index 8355a39..e009c82 100644 --- a/gcc/fortran/match.cc +++ b/gcc/fortran/match.cc @@ -2608,7 +2608,66 @@ cleanup: } -/* Match the header of a FORALL statement. */ +/* Apply type-spec to iterator and create shadow variable if needed. */ + +static void +apply_typespec_to_iterator (gfc_forall_iterator *iter, gfc_typespec *ts, + locus *loc) +{ + char *name; + gfc_expr *v; + gfc_symtree *st; + + /* When a type-spec is provided in DO CONCURRENT/FORALL, F2018 19.4(6) + requires the index-name to have scope limited to the construct, + shadowing any variable with the same name from outer scope. + If the index-name was not previously declared, we can simply set its + type. Otherwise, create a shadow variable with "_" prefix. */ + iter->shadow = false; + v = iter->var; + if (v->ts.type == BT_UNKNOWN) + { + /* Variable not declared in outer scope - just set the type. */ + v->ts.type = v->symtree->n.sym->ts.type = BT_INTEGER; + v->ts.kind = v->symtree->n.sym->ts.kind = ts->kind; + gfc_set_sym_referenced (v->symtree->n.sym); + } + else + { + /* Variable exists in outer scope - must create shadow to comply + with F2018 19.4(6) scoping rules. */ + name = (char *) alloca (strlen (v->symtree->name) + 2); + strcpy (name, "_"); + strcat (name, v->symtree->name); + if (gfc_get_sym_tree (name, NULL, &st, false) != 0) + gfc_internal_error ("Failed to create shadow variable symtree for " + "DO CONCURRENT type-spec at %L", loc); + + v = gfc_get_expr (); + v->where = gfc_current_locus; + v->expr_type = EXPR_VARIABLE; + v->ts.type = st->n.sym->ts.type = ts->type; + v->ts.kind = st->n.sym->ts.kind = ts->kind; + st->n.sym->forall_index = true; + v->symtree = st; + gfc_replace_expr (iter->var, v); + iter->shadow = true; + gfc_set_sym_referenced (st->n.sym); + } + + /* Convert iterator bounds to the specified type. */ + gfc_convert_type (iter->start, ts, 1); + gfc_convert_type (iter->end, ts, 1); + gfc_convert_type (iter->stride, ts, 1); +} + + +/* Match the header of a FORALL statement. In F2008 and F2018, the form of + the header is: + + ([ type-spec :: ] concurrent-control-list [, scalar-mask-expr ] ) + + where type-spec is INTEGER. */ static match match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask) @@ -2616,6 +2675,9 @@ match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask) gfc_forall_iterator *head, *tail, *new_iter; gfc_expr *msk; match m; + gfc_typespec ts; + bool seen_ts = false; + locus loc; gfc_gobble_whitespace (); @@ -2625,12 +2687,40 @@ match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask) if (gfc_match_char ('(') != MATCH_YES) return MATCH_NO; + /* Check for an optional type-spec. */ + gfc_clear_ts (&ts); + loc = gfc_current_locus; + m = gfc_match_type_spec (&ts); + if (m == MATCH_YES) + { + seen_ts = (gfc_match (" ::") == MATCH_YES); + + if (seen_ts) + { + if (!gfc_notify_std (GFC_STD_F2008, "FORALL or DO CONCURRENT " + "construct includes type specification " + "at %L", &loc)) + goto cleanup; + + if (ts.type != BT_INTEGER) + { + gfc_error ("Type-spec at %L must be an INTEGER type", &loc); + goto cleanup; + } + } + } + else if (m == MATCH_ERROR) + goto syntax; + m = match_forall_iterator (&new_iter); if (m == MATCH_ERROR) goto cleanup; if (m == MATCH_NO) goto syntax; + if (seen_ts) + apply_typespec_to_iterator (new_iter, &ts, &loc); + head = tail = new_iter; for (;;) @@ -2644,6 +2734,9 @@ match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask) if (m == MATCH_YES) { + if (seen_ts) + apply_typespec_to_iterator (new_iter, &ts, &loc); + tail->next = new_iter; tail = new_iter; continue; diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 410361c..314be6b 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -174,6 +174,7 @@ match gfc_match_omp_do_simd (void); match gfc_match_omp_loop (void); match gfc_match_omp_error (void); match gfc_match_omp_flush (void); +match gfc_match_omp_groupprivate (void); match gfc_match_omp_interop (void); match gfc_match_omp_masked (void); match gfc_match_omp_masked_taskloop (void); diff --git a/gcc/fortran/module.cc b/gcc/fortran/module.cc index c489dec..9b845b5 100644 --- a/gcc/fortran/module.cc +++ b/gcc/fortran/module.cc @@ -2092,7 +2092,8 @@ enum ab_attribute AB_ARRAY_OUTER_DEPENDENCY, AB_MODULE_PROCEDURE, AB_OACC_DECLARE_CREATE, AB_OACC_DECLARE_COPYIN, AB_OACC_DECLARE_DEVICEPTR, AB_OACC_DECLARE_DEVICE_RESIDENT, AB_OACC_DECLARE_LINK, - AB_OMP_DECLARE_TARGET_LINK, AB_PDT_KIND, AB_PDT_LEN, AB_PDT_TYPE, + AB_OMP_DECLARE_TARGET_LINK, AB_OMP_DECLARE_TARGET_LOCAL, + AB_PDT_KIND, AB_PDT_LEN, AB_PDT_TYPE, AB_PDT_COMP, AB_PDT_TEMPLATE, AB_PDT_ARRAY, AB_PDT_STRING, AB_OACC_ROUTINE_LOP_GANG, AB_OACC_ROUTINE_LOP_WORKER, AB_OACC_ROUTINE_LOP_VECTOR, AB_OACC_ROUTINE_LOP_SEQ, @@ -2102,7 +2103,7 @@ enum ab_attribute AB_OMP_REQ_MEM_ORDER_SEQ_CST, AB_OMP_REQ_MEM_ORDER_ACQ_REL, AB_OMP_REQ_MEM_ORDER_ACQUIRE, AB_OMP_REQ_MEM_ORDER_RELEASE, AB_OMP_REQ_MEM_ORDER_RELAXED, AB_OMP_DEVICE_TYPE_NOHOST, - AB_OMP_DEVICE_TYPE_HOST, AB_OMP_DEVICE_TYPE_ANY + AB_OMP_DEVICE_TYPE_HOST, AB_OMP_DEVICE_TYPE_ANY, AB_OMP_GROUPPRIVATE }; static const mstring attr_bits[] = @@ -2166,6 +2167,8 @@ static const mstring attr_bits[] = minit ("OACC_DECLARE_DEVICE_RESIDENT", AB_OACC_DECLARE_DEVICE_RESIDENT), minit ("OACC_DECLARE_LINK", AB_OACC_DECLARE_LINK), minit ("OMP_DECLARE_TARGET_LINK", AB_OMP_DECLARE_TARGET_LINK), + minit ("OMP_DECLARE_TARGET_LOCAL", AB_OMP_DECLARE_TARGET_LOCAL), + minit ("OMP_GROUPPRIVATE", AB_OMP_GROUPPRIVATE), minit ("PDT_KIND", AB_PDT_KIND), minit ("PDT_LEN", AB_PDT_LEN), minit ("PDT_TYPE", AB_PDT_TYPE), @@ -2399,6 +2402,10 @@ mio_symbol_attribute (symbol_attribute *attr) MIO_NAME (ab_attribute) (AB_OACC_DECLARE_LINK, attr_bits); if (attr->omp_declare_target_link) MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET_LINK, attr_bits); + if (attr->omp_declare_target_local) + MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET_LOCAL, attr_bits); + if (attr->omp_groupprivate) + MIO_NAME (ab_attribute) (AB_OMP_GROUPPRIVATE, attr_bits); if (attr->pdt_kind) MIO_NAME (ab_attribute) (AB_PDT_KIND, attr_bits); if (attr->pdt_len) @@ -2654,6 +2661,12 @@ mio_symbol_attribute (symbol_attribute *attr) case AB_OMP_DECLARE_TARGET_LINK: attr->omp_declare_target_link = 1; break; + case AB_OMP_DECLARE_TARGET_LOCAL: + attr->omp_declare_target_local = 1; + break; + case AB_OMP_GROUPPRIVATE: + attr->omp_groupprivate = 1; + break; case AB_ARRAY_OUTER_DEPENDENCY: attr->array_outer_dependency =1; break; @@ -5268,6 +5281,8 @@ load_commons (void) if (flags & 2) p->threadprivate = 1; p->omp_device_type = (gfc_omp_device_type) ((flags >> 2) & 3); + if ((flags >> 4) & 1) + p->omp_groupprivate = 1; p->use_assoc = 1; /* Get whether this was a bind(c) common or not. */ @@ -5827,6 +5842,20 @@ read_module (void) || startswith (name, "__vtype_"))) p = name; + /* Include pdt_types if their associated pdt_template is in a + USE, ONLY list. */ + if (p == NULL && name[0] == 'P' + && startswith (name, "Pdt") + && module_list) + { + gfc_use_list *ml = module_list; + for (; ml; ml = ml->next) + if (ml->rename + && !strncmp (&name[3], ml->rename->use_name, + strlen (ml->rename->use_name))) + p = name; + } + /* Skip symtree nodes not in an ONLY clause, unless there is an existing symtree loaded from another USE statement. */ if (p == NULL) @@ -6191,6 +6220,7 @@ write_common_0 (gfc_symtree *st, bool this_module) if (p->threadprivate) flags |= 2; flags |= p->omp_device_type << 2; + flags |= p->omp_groupprivate << 4; mio_integer (&flags); /* Write out whether the common block is bind(c) or not. */ diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc index f5db9a8..abc27d5 100644 --- a/gcc/fortran/openmp.cc +++ b/gcc/fortran/openmp.cc @@ -84,6 +84,7 @@ static const struct gfc_omp_directive gfc_omp_directives[] = { /* {"flatten", GFC_OMP_DIR_EXECUTABLE, ST_OMP_FLATTEN}, */ {"flush", GFC_OMP_DIR_EXECUTABLE, ST_OMP_FLUSH}, /* {"fuse", GFC_OMP_DIR_EXECUTABLE, ST_OMP_FLUSE}, */ + {"groupprivate", GFC_OMP_DIR_DECLARATIVE, ST_OMP_GROUPPRIVATE}, /* {"interchange", GFC_OMP_DIR_EXECUTABLE, ST_OMP_INTERCHANGE}, */ {"interop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_INTEROP}, {"loop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_LOOP}, @@ -195,6 +196,7 @@ gfc_free_omp_clauses (gfc_omp_clauses *c) gfc_free_expr (c->num_teams_lower); gfc_free_expr (c->num_teams_upper); gfc_free_expr (c->device); + gfc_free_expr (c->dyn_groupprivate); gfc_free_expr (c->thread_limit); gfc_free_expr (c->dist_chunk_size); gfc_free_expr (c->grainsize); @@ -1172,6 +1174,8 @@ enum omp_mask2 OMP_CLAUSE_NOVARIANTS, /* OpenMP 5.1 */ OMP_CLAUSE_NOCONTEXT, /* OpenMP 5.1 */ OMP_CLAUSE_INTEROP, /* OpenMP 5.1 */ + OMP_CLAUSE_LOCAL, /* OpenMP 6.0 */ + OMP_CLAUSE_DYN_GROUPPRIVATE, /* OpenMP 6.1 */ /* This must come last. */ OMP_MASK2_LAST }; @@ -3096,6 +3100,22 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, else continue; } + if ((mask & OMP_CLAUSE_DYN_GROUPPRIVATE) + && gfc_match_dupl_check (!c->dyn_groupprivate, + "dyn_groupprivate", true) == MATCH_YES) + { + if (gfc_match ("fallback ( abort ) : ") == MATCH_YES) + c->fallback = OMP_FALLBACK_ABORT; + else if (gfc_match ("fallback ( default_mem ) : ") == MATCH_YES) + c->fallback = OMP_FALLBACK_DEFAULT_MEM; + else if (gfc_match ("fallback ( null ) : ") == MATCH_YES) + c->fallback = OMP_FALLBACK_NULL; + if (gfc_match_expr (&c->dyn_groupprivate) != MATCH_YES) + return MATCH_ERROR; + if (gfc_match (" )") != MATCH_YES) + goto error; + continue; + } break; case 'e': if ((mask & OMP_CLAUSE_ENTER)) @@ -3567,6 +3587,10 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, &c->lists[OMP_LIST_LINK]) == MATCH_YES)) continue; + if ((mask & OMP_CLAUSE_LOCAL) + && (gfc_match_omp_to_link ("local (", &c->lists[OMP_LIST_LOCAL]) + == MATCH_YES)) + continue; break; case 'm': if ((mask & OMP_CLAUSE_MAP) @@ -5064,7 +5088,8 @@ cleanup: | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULTMAP \ | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_IN_REDUCTION \ | OMP_CLAUSE_THREAD_LIMIT | OMP_CLAUSE_ALLOCATE \ - | OMP_CLAUSE_HAS_DEVICE_ADDR | OMP_CLAUSE_USES_ALLOCATORS) + | OMP_CLAUSE_HAS_DEVICE_ADDR | OMP_CLAUSE_USES_ALLOCATORS \ + | OMP_CLAUSE_DYN_GROUPPRIVATE) #define OMP_TARGET_DATA_CLAUSES \ (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \ | OMP_CLAUSE_USE_DEVICE_PTR | OMP_CLAUSE_USE_DEVICE_ADDR) @@ -5092,7 +5117,7 @@ cleanup: (omp_mask (OMP_CLAUSE_THREADS) | OMP_CLAUSE_SIMD) #define OMP_DECLARE_TARGET_CLAUSES \ (omp_mask (OMP_CLAUSE_ENTER) | OMP_CLAUSE_LINK | OMP_CLAUSE_DEVICE_TYPE \ - | OMP_CLAUSE_TO | OMP_CLAUSE_INDIRECT) + | OMP_CLAUSE_TO | OMP_CLAUSE_INDIRECT | OMP_CLAUSE_LOCAL) #define OMP_ATOMIC_CLAUSES \ (omp_mask (OMP_CLAUSE_ATOMIC) | OMP_CLAUSE_CAPTURE | OMP_CLAUSE_HINT \ | OMP_CLAUSE_MEMORDER | OMP_CLAUSE_COMPARE | OMP_CLAUSE_FAIL \ @@ -6113,7 +6138,7 @@ gfc_match_omp_declare_target (void) gfc_buffer_error (false); static const int to_enter_link_lists[] - = { OMP_LIST_TO, OMP_LIST_ENTER, OMP_LIST_LINK }; + = { OMP_LIST_TO, OMP_LIST_ENTER, OMP_LIST_LINK, OMP_LIST_LOCAL }; for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists) && (list = to_enter_link_lists[listn], true); ++listn) for (n = c->lists[list]; n; n = n->next) @@ -6122,6 +6147,8 @@ gfc_match_omp_declare_target (void) else if (n->u.common->head) n->u.common->head->mark = 0; + if (c->device_type == OMP_DEVICE_TYPE_UNSET) + c->device_type = OMP_DEVICE_TYPE_ANY; for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists) && (list = to_enter_link_lists[listn], true); ++listn) for (n = c->lists[list]; n; n = n->next) @@ -6130,105 +6157,161 @@ gfc_match_omp_declare_target (void) if (n->sym->attr.in_common) gfc_error_now ("OMP DECLARE TARGET variable at %L is an " "element of a COMMON block", &n->where); + else if (n->sym->attr.omp_groupprivate && list != OMP_LIST_LOCAL) + gfc_error_now ("List item %qs at %L not appear in the %qs clause " + "as it was previously specified in a GROUPPRIVATE " + "directive", n->sym->name, &n->where, + list == OMP_LIST_LINK + ? "link" : list == OMP_LIST_TO ? "to" : "enter"); else if (n->sym->mark) gfc_error_now ("Variable at %L mentioned multiple times in " "clauses of the same OMP DECLARE TARGET directive", &n->where); - else if (n->sym->attr.omp_declare_target - && n->sym->attr.omp_declare_target_link - && list != OMP_LIST_LINK) + else if ((n->sym->attr.omp_declare_target_link + || n->sym->attr.omp_declare_target_local) + && list != OMP_LIST_LINK + && list != OMP_LIST_LOCAL) gfc_error_now ("OMP DECLARE TARGET variable at %L previously " - "mentioned in LINK clause and later in %s clause", - &n->where, list == OMP_LIST_TO ? "TO" : "ENTER"); + "mentioned in %s clause and later in %s clause", + &n->where, + n->sym->attr.omp_declare_target_link ? "LINK" + : "LOCAL", + list == OMP_LIST_TO ? "TO" : "ENTER"); else if (n->sym->attr.omp_declare_target - && !n->sym->attr.omp_declare_target_link - && list == OMP_LIST_LINK) + && (list == OMP_LIST_LINK || list == OMP_LIST_LOCAL)) gfc_error_now ("OMP DECLARE TARGET variable at %L previously " "mentioned in TO or ENTER clause and later in " - "LINK clause", &n->where); - else if (gfc_add_omp_declare_target (&n->sym->attr, n->sym->name, - &n->sym->declared_at)) + "%s clause", &n->where, + list == OMP_LIST_LINK ? "LINK" : "LOCAL"); + else { + if (list == OMP_LIST_TO || list == OMP_LIST_ENTER) + gfc_add_omp_declare_target (&n->sym->attr, n->sym->name, + &n->sym->declared_at); if (list == OMP_LIST_LINK) gfc_add_omp_declare_target_link (&n->sym->attr, n->sym->name, &n->sym->declared_at); + if (list == OMP_LIST_LOCAL) + gfc_add_omp_declare_target_local (&n->sym->attr, n->sym->name, + &n->sym->declared_at); + } + if (n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET + && n->sym->attr.omp_device_type != c->device_type) + { + const char *dt = "any"; + if (n->sym->attr.omp_device_type == OMP_DEVICE_TYPE_NOHOST) + dt = "nohost"; + else if (n->sym->attr.omp_device_type == OMP_DEVICE_TYPE_HOST) + dt = "host"; + if (n->sym->attr.omp_groupprivate) + gfc_error_now ("List item %qs at %L set in previous OMP " + "GROUPPRIVATE directive to the different " + "DEVICE_TYPE %qs", n->sym->name, &n->where, dt); + else + gfc_error_now ("List item %qs at %L set in previous OMP " + "DECLARE TARGET directive to the different " + "DEVICE_TYPE %qs", n->sym->name, &n->where, dt); } - if (c->device_type != OMP_DEVICE_TYPE_UNSET) - { - if (n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET - && n->sym->attr.omp_device_type != c->device_type) - gfc_error_now ("List item %qs at %L set in previous OMP DECLARE " - "TARGET directive to a different DEVICE_TYPE", - n->sym->name, &n->where); - n->sym->attr.omp_device_type = c->device_type; - } - if (c->indirect) + n->sym->attr.omp_device_type = c->device_type; + if (c->indirect && c->device_type != OMP_DEVICE_TYPE_ANY) { - if (n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET - && n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_ANY) - gfc_error_now ("DEVICE_TYPE must be ANY when used with " - "INDIRECT at %L", &n->where); - n->sym->attr.omp_declare_target_indirect = c->indirect; + gfc_error_now ("DEVICE_TYPE must be ANY when used with INDIRECT " + "at %L", &n->where); + c->indirect = 0; } - + n->sym->attr.omp_declare_target_indirect = c->indirect; + if (list == OMP_LIST_LINK && c->device_type == OMP_DEVICE_TYPE_NOHOST) + gfc_error_now ("List item %qs at %L set with NOHOST specified may " + "not appear in a LINK clause", n->sym->name, + &n->where); n->sym->mark = 1; } - else if (n->u.common->omp_declare_target - && n->u.common->omp_declare_target_link - && list != OMP_LIST_LINK) - gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously " - "mentioned in LINK clause and later in %s clause", - &n->where, list == OMP_LIST_TO ? "TO" : "ENTER"); - else if (n->u.common->omp_declare_target - && !n->u.common->omp_declare_target_link - && list == OMP_LIST_LINK) - gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously " - "mentioned in TO or ENTER clause and later in " - "LINK clause", &n->where); - else if (n->u.common->head && n->u.common->head->mark) - gfc_error_now ("COMMON at %L mentioned multiple times in " - "clauses of the same OMP DECLARE TARGET directive", - &n->where); - else - { - n->u.common->omp_declare_target = 1; - n->u.common->omp_declare_target_link = (list == OMP_LIST_LINK); + else /* common block */ + { + if (n->u.common->omp_groupprivate && list != OMP_LIST_LOCAL) + gfc_error_now ("Common block %</%s/%> at %L not appear in the %qs " + "clause as it was previously specified in a " + "GROUPPRIVATE directive", + n->u.common->name, &n->where, + list == OMP_LIST_LINK + ? "link" : list == OMP_LIST_TO ? "to" : "enter"); + else if (n->u.common->head && n->u.common->head->mark) + gfc_error_now ("Common block %</%s/%> at %L mentioned multiple " + "times in clauses of the same OMP DECLARE TARGET " + "directive", n->u.common->name, &n->where); + else if ((n->u.common->omp_declare_target_link + || n->u.common->omp_declare_target_local) + && list != OMP_LIST_LINK + && list != OMP_LIST_LOCAL) + gfc_error_now ("Common block %</%s/%> at %L previously mentioned " + "in %s clause and later in %s clause", + n->u.common->name, &n->where, + n->u.common->omp_declare_target_link ? "LINK" + : "LOCAL", + list == OMP_LIST_TO ? "TO" : "ENTER"); + else if (n->u.common->omp_declare_target + && (list == OMP_LIST_LINK || list == OMP_LIST_LOCAL)) + gfc_error_now ("Common block %</%s/%> at %L previously mentioned " + "in TO or ENTER clause and later in %s clause", + n->u.common->name, &n->where, + list == OMP_LIST_LINK ? "LINK" : "LOCAL"); if (n->u.common->omp_device_type != OMP_DEVICE_TYPE_UNSET && n->u.common->omp_device_type != c->device_type) - gfc_error_now ("COMMON at %L set in previous OMP DECLARE " - "TARGET directive to a different DEVICE_TYPE", - &n->where); + { + const char *dt = "any"; + if (n->u.common->omp_device_type == OMP_DEVICE_TYPE_NOHOST) + dt = "nohost"; + else if (n->u.common->omp_device_type == OMP_DEVICE_TYPE_HOST) + dt = "host"; + if (n->u.common->omp_groupprivate) + gfc_error_now ("Common block %</%s/%> at %L set in previous OMP " + "GROUPPRIVATE directive to the different " + "DEVICE_TYPE %qs", n->u.common->name, &n->where, + dt); + else + gfc_error_now ("Common block %</%s/%> at %L set in previous OMP " + "DECLARE TARGET directive to the different " + "DEVICE_TYPE %qs", n->u.common->name, &n->where, + dt); + } n->u.common->omp_device_type = c->device_type; + if (c->indirect && c->device_type != OMP_DEVICE_TYPE_ANY) + { + gfc_error_now ("DEVICE_TYPE must be ANY when used with INDIRECT " + "at %L", &n->where); + c->indirect = 0; + } + if (list == OMP_LIST_LINK && c->device_type == OMP_DEVICE_TYPE_NOHOST) + gfc_error_now ("Common block %</%s/%> at %L set with NOHOST " + "specified may not appear in a LINK clause", + n->u.common->name, &n->where); + + if (list == OMP_LIST_TO || list == OMP_LIST_ENTER) + n->u.common->omp_declare_target = 1; + if (list == OMP_LIST_LINK) + n->u.common->omp_declare_target_link = 1; + if (list == OMP_LIST_LOCAL) + n->u.common->omp_declare_target_local = 1; + for (s = n->u.common->head; s; s = s->common_next) { s->mark = 1; - if (gfc_add_omp_declare_target (&s->attr, s->name, - &s->declared_at)) - { - if (list == OMP_LIST_LINK) - gfc_add_omp_declare_target_link (&s->attr, s->name, - &s->declared_at); - } - if (s->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET - && s->attr.omp_device_type != c->device_type) - gfc_error_now ("List item %qs at %L set in previous OMP DECLARE" - " TARGET directive to a different DEVICE_TYPE", - s->name, &n->where); + if (list == OMP_LIST_TO || list == OMP_LIST_ENTER) + gfc_add_omp_declare_target (&s->attr, s->name, &n->where); + if (list == OMP_LIST_LINK) + gfc_add_omp_declare_target_link (&s->attr, s->name, &n->where); + if (list == OMP_LIST_LOCAL) + gfc_add_omp_declare_target_local (&s->attr, s->name, &n->where); s->attr.omp_device_type = c->device_type; - - if (c->indirect - && s->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET - && s->attr.omp_device_type != OMP_DEVICE_TYPE_ANY) - gfc_error_now ("DEVICE_TYPE must be ANY when used with " - "INDIRECT at %L", &n->where); s->attr.omp_declare_target_indirect = c->indirect; } } if ((c->device_type || c->indirect) && !c->lists[OMP_LIST_ENTER] && !c->lists[OMP_LIST_TO] - && !c->lists[OMP_LIST_LINK]) + && !c->lists[OMP_LIST_LINK] + && !c->lists[OMP_LIST_LOCAL]) gfc_warning_now (OPT_Wopenmp, "OMP DECLARE TARGET directive at %L with only " "DEVICE_TYPE or INDIRECT clauses is ignored", @@ -7108,32 +7191,44 @@ gfc_match_omp_metadirective (void) return match_omp_metadirective (false); } -match -gfc_match_omp_threadprivate (void) +/* Match 'omp threadprivate' or 'omp groupprivate'. */ +static match +gfc_match_omp_thread_group_private (bool is_groupprivate) { locus old_loc; char n[GFC_MAX_SYMBOL_LEN+1]; gfc_symbol *sym; match m; gfc_symtree *st; + struct sym_loc_t { gfc_symbol *sym; gfc_common_head *com; locus loc; }; + auto_vec<sym_loc_t> syms; old_loc = gfc_current_locus; - m = gfc_match (" ("); + m = gfc_match (" ( "); if (m != MATCH_YES) return m; for (;;) { + locus sym_loc = gfc_current_locus; m = gfc_match_symbol (&sym, 0); switch (m) { case MATCH_YES: if (sym->attr.in_common) - gfc_error_now ("Threadprivate variable at %C is an element of " - "a COMMON block"); - else if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at)) + gfc_error_now ("%qs variable at %L is an element of a COMMON block", + is_groupprivate ? "groupprivate" : "threadprivate", + &sym_loc); + else if (!is_groupprivate + && !gfc_add_threadprivate (&sym->attr, sym->name, &sym_loc)) goto cleanup; + else if (is_groupprivate) + { + if (!gfc_add_omp_groupprivate (&sym->attr, sym->name, &sym_loc)) + goto cleanup; + syms.safe_push ({sym, nullptr, sym_loc}); + } goto next_item; case MATCH_NO: break; @@ -7150,12 +7245,20 @@ gfc_match_omp_threadprivate (void) st = gfc_find_symtree (gfc_current_ns->common_root, n); if (st == NULL) { - gfc_error ("COMMON block /%s/ not found at %C", n); + gfc_error ("COMMON block /%s/ not found at %L", n, &sym_loc); goto cleanup; } - st->n.common->threadprivate = 1; + syms.safe_push ({nullptr, st->n.common, sym_loc}); + if (is_groupprivate) + st->n.common->omp_groupprivate = 1; + else + st->n.common->threadprivate = 1; for (sym = st->n.common->head; sym; sym = sym->common_next) - if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at)) + if (!is_groupprivate + && !gfc_add_threadprivate (&sym->attr, sym->name, &sym_loc)) + goto cleanup; + else if (is_groupprivate + && !gfc_add_omp_groupprivate (&sym->attr, sym->name, &sym_loc)) goto cleanup; next_item: @@ -7165,16 +7268,89 @@ gfc_match_omp_threadprivate (void) goto syntax; } + if (is_groupprivate) + { + gfc_omp_clauses *c; + m = gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_DEVICE_TYPE)); + if (m == MATCH_ERROR) + return MATCH_ERROR; + + if (c->device_type == OMP_DEVICE_TYPE_UNSET) + c->device_type = OMP_DEVICE_TYPE_ANY; + + for (size_t i = 0; i < syms.length (); i++) + if (syms[i].sym) + { + sym_loc_t &n = syms[i]; + if (n.sym->attr.in_common) + gfc_error_now ("Variable %qs at %L is an element of a COMMON " + "block", n.sym->name, &n.loc); + else if (n.sym->attr.omp_declare_target + || n.sym->attr.omp_declare_target_link) + gfc_error_now ("List item %qs at %L implies OMP DECLARE TARGET " + "with the LOCAL clause, but it has been specified" + " with a different clause before", + n.sym->name, &n.loc); + if (n.sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET + && n.sym->attr.omp_device_type != c->device_type) + { + const char *dt = "any"; + if (n.sym->attr.omp_device_type == OMP_DEVICE_TYPE_HOST) + dt = "host"; + else if (n.sym->attr.omp_device_type == OMP_DEVICE_TYPE_NOHOST) + dt = "nohost"; + gfc_error_now ("List item %qs at %L set in previous OMP DECLARE " + "TARGET directive to the different DEVICE_TYPE %qs", + n.sym->name, &n.loc, dt); + } + gfc_add_omp_declare_target_local (&n.sym->attr, n.sym->name, + &n.loc); + n.sym->attr.omp_device_type = c->device_type; + } + else /* Common block. */ + { + sym_loc_t &n = syms[i]; + if (n.com->omp_declare_target + || n.com->omp_declare_target_link) + gfc_error_now ("List item %</%s/%> at %L implies OMP DECLARE " + "TARGET with the LOCAL clause, but it has been " + "specified with a different clause before", + n.com->name, &n.loc); + if (n.com->omp_device_type != OMP_DEVICE_TYPE_UNSET + && n.com->omp_device_type != c->device_type) + { + const char *dt = "any"; + if (n.com->omp_device_type == OMP_DEVICE_TYPE_HOST) + dt = "host"; + else if (n.com->omp_device_type == OMP_DEVICE_TYPE_NOHOST) + dt = "nohost"; + gfc_error_now ("List item %qs at %L set in previous OMP DECLARE" + " TARGET directive to the different DEVICE_TYPE " + "%qs", n.com->name, &n.loc, dt); + } + n.com->omp_declare_target_local = 1; + n.com->omp_device_type = c->device_type; + for (gfc_symbol *s = n.com->head; s; s = s->common_next) + { + gfc_add_omp_declare_target_local (&s->attr, s->name, &n.loc); + s->attr.omp_device_type = c->device_type; + } + } + free (c); + } + if (gfc_match_omp_eos () != MATCH_YES) { - gfc_error ("Unexpected junk after OMP THREADPRIVATE at %C"); + gfc_error ("Unexpected junk after OMP %s at %C", + is_groupprivate ? "GROUPPRIVATE" : "THREADPRIVATE"); goto cleanup; } return MATCH_YES; syntax: - gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C"); + gfc_error ("Syntax error in !$OMP %s list at %C", + is_groupprivate ? "GROUPPRIVATE" : "THREADPRIVATE"); cleanup: gfc_current_locus = old_loc; @@ -7183,6 +7359,20 @@ cleanup: match +gfc_match_omp_groupprivate (void) +{ + return gfc_match_omp_thread_group_private (true); +} + + +match +gfc_match_omp_threadprivate (void) +{ + return gfc_match_omp_thread_group_private (false); +} + + +match gfc_match_omp_parallel (void) { return match_omp (EXEC_OMP_PARALLEL, OMP_PARALLEL_CLAUSES); @@ -8359,9 +8549,9 @@ resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns, } /* Assume that a constant expression in the range 1 (omp_default_mem_alloc) - to 8 (omp_thread_mem_alloc) range, or 200 (ompx_gnu_pinned_mem_alloc) is - fine. The original symbol name is already lost during matching via - gfc_match_expr. */ + to GOMP_OMP_PREDEF_ALLOC_MAX, or GOMP_OMPX_PREDEF_ALLOC_MIN to + GOMP_OMPX_PREDEF_ALLOC_MAX is fine. The original symbol name is already + lost during matching via gfc_match_expr. */ static bool is_predefined_allocator (gfc_expr *expr) { @@ -8492,7 +8682,8 @@ gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list) if (n->sym->attr.in_common || n->sym->attr.save || n->sym->ns->save_all || (n->sym->ns->proc_name && (n->sym->ns->proc_name->attr.flavor == FL_PROGRAM - || n->sym->ns->proc_name->attr.flavor == FL_MODULE))) + || n->sym->ns->proc_name->attr.flavor == FL_MODULE + || n->sym->ns->proc_name->attr.flavor == FL_BLOCK_DATA))) { bool com = n->sym->attr.in_common; if (!n->u2.allocator) @@ -8506,6 +8697,30 @@ gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list) &n->u2.allocator->where, com ? "/" : "", com ? n->sym->common_head->name : n->sym->name, com ? "/" : "", &n->where); + /* Only local static variables might use omp_cgroup_mem_alloc (6), + omp_pteam_mem_alloc (7), or omp_thread_mem_alloc (8). */ + else if ((!ns->proc_name + || ns->proc_name->attr.flavor == FL_PROGRAM + || ns->proc_name->attr.flavor == FL_BLOCK_DATA + || ns->proc_name->attr.flavor == FL_MODULE + || com) + && mpz_cmp_si (n->u2.allocator->value.integer, + 6 /* cgroup */) >= 0 + && mpz_cmp_si (n->u2.allocator->value.integer, + 8 /* thread */) <= 0) + { + const char *alloc_name[] = {"omp_cgroup_mem_alloc", + "omp_pteam_mem_alloc", + "omp_thread_mem_alloc" }; + gfc_error ("Predefined allocator %qs in ALLOCATOR clause at %L, " + "used for list item %<%s%s%s%> at %L, may only be used" + " for local static variables", + alloc_name[mpz_get_ui (n->u2.allocator->value.integer) + - 6 /* cgroup */], &n->u2.allocator->where, + com ? "/" : "", + com ? n->sym->common_head->name : n->sym->name, + com ? "/" : "", &n->where); + } while (n->sym->attr.in_common && n->next && n->next->sym && n->sym->common_head == n->next->sym->common_head) n = n->next; @@ -8554,7 +8769,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, "TO", "FROM", "INCLUSIVE", "EXCLUSIVE", "REDUCTION", "REDUCTION" /*inscan*/, "REDUCTION" /*task*/, "IN_REDUCTION", "TASK_REDUCTION", - "DEVICE_RESIDENT", "LINK", "USE_DEVICE", + "DEVICE_RESIDENT", "LINK", "LOCAL", "USE_DEVICE", "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR", "NONTEMPORAL", "ALLOCATE", "HAS_DEVICE_ADDR", "ENTER", "USES_ALLOCATORS", "INIT", "USE", "DESTROY", "INTEROP", "ADJUST_ARGS" }; @@ -8761,6 +8976,9 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, } if (omp_clauses->num_threads) resolve_positive_int_expr (omp_clauses->num_threads, "NUM_THREADS"); + if (omp_clauses->dyn_groupprivate) + resolve_nonnegative_int_expr (omp_clauses->dyn_groupprivate, + "DYN_GROUPPRIVATE"); if (omp_clauses->chunk_size) { gfc_expr *expr = omp_clauses->chunk_size; @@ -12290,12 +12508,14 @@ gfc_resolve_omp_context_selector (gfc_omp_set_selector *oss, continue; } /* Device number must be conforming, which includes - omp_initial_device (-1) and omp_invalid_device (-4). */ + omp_initial_device (-1), omp_invalid_device (-4), + and omp_default_device (-5). */ if (property_kind == OMP_TRAIT_PROPERTY_DEV_NUM_EXPR && otp->expr->expr_type == EXPR_CONSTANT && mpz_sgn (otp->expr->value.integer) < 0 && mpz_cmp_si (otp->expr->value.integer, -1) != 0 - && mpz_cmp_si (otp->expr->value.integer, -4) != 0) + && mpz_cmp_si (otp->expr->value.integer, -4) != 0 + && mpz_cmp_si (otp->expr->value.integer, -5) != 0) gfc_error ("property must be a conforming device number at %L", &otp->expr->where); break; @@ -12320,6 +12540,7 @@ static void resolve_omp_metadirective (gfc_code *code, gfc_namespace *ns) { gfc_omp_variant *variant = code->ext.omp_variants; + gfc_omp_variant *prev_variant = variant; while (variant) { @@ -12333,15 +12554,19 @@ resolve_omp_metadirective (gfc_code *code, gfc_namespace *ns) as the 'otherwise' clause should always match. */ if (variant == code->ext.omp_variants && !variant->next) break; - if (variant == code->ext.omp_variants) - code->ext.omp_variants = variant->next; gfc_omp_variant *tmp = variant; - variant = variant->next; + if (variant == code->ext.omp_variants) + variant = prev_variant = code->ext.omp_variants = variant->next; + else + variant = prev_variant->next = variant->next; gfc_free_omp_set_selector_list (tmp->selectors); free (tmp); } else - variant = variant->next; + { + prev_variant = variant; + variant = variant->next; + } } /* Replace metadirective by its body if only 'nothing' remains. */ if (!code->ext.omp_variants->next && code->ext.omp_variants->stmt == ST_NONE) diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc index b29f690..df8570b 100644 --- a/gcc/fortran/parse.cc +++ b/gcc/fortran/parse.cc @@ -60,6 +60,7 @@ bool gfc_in_omp_metadirective_body; /* Each metadirective body in the translation unit is given a unique number, used to ensure that labels in the body have unique names. */ int gfc_omp_metadirective_region_count; +vec<int> gfc_omp_metadirective_region_stack; /* TODO: Re-order functions to kill these forward decls. */ static void check_statement_label (gfc_statement); @@ -1194,6 +1195,9 @@ decode_omp_directive (void) case 'f': matcho ("flush", gfc_match_omp_flush, ST_OMP_FLUSH); break; + case 'g': + matchdo ("groupprivate", gfc_match_omp_groupprivate, ST_OMP_GROUPPRIVATE); + break; case 'i': matcho ("interop", gfc_match_omp_interop, ST_OMP_INTEROP); break; @@ -1989,7 +1993,8 @@ next_statement (void) #define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \ case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION: \ case ST_OMP_DECLARE_VARIANT: case ST_OMP_ALLOCATE: case ST_OMP_ASSUMES: \ - case ST_OMP_REQUIRES: case ST_OACC_ROUTINE: case ST_OACC_DECLARE + case ST_OMP_REQUIRES: case ST_OMP_GROUPPRIVATE: \ + case ST_OACC_ROUTINE: case ST_OACC_DECLARE /* OpenMP statements that are followed by a structured block. */ @@ -2908,6 +2913,9 @@ gfc_ascii_statement (gfc_statement st, bool strip_sentinel) case ST_OMP_FLUSH: p = "!$OMP FLUSH"; break; + case ST_OMP_GROUPPRIVATE: + p = "!$OMP GROUPPRIVATE"; + break; case ST_OMP_INTEROP: p = "!$OMP INTEROP"; break; @@ -4436,6 +4444,8 @@ loop: case ST_EQUIVALENCE: case ST_IMPLICIT: case ST_IMPLICIT_NONE: + case ST_OMP_ALLOCATE: + case ST_OMP_GROUPPRIVATE: case ST_OMP_THREADPRIVATE: case ST_PARAMETER: case ST_STRUCTURE_DECL: @@ -6542,6 +6552,9 @@ parse_omp_metadirective_body (gfc_statement omp_st) gfc_in_omp_metadirective_body = true; gfc_omp_metadirective_region_count++; + gfc_omp_metadirective_region_stack.safe_push ( + gfc_omp_metadirective_region_count); + switch (variant->stmt) { case_omp_structured_block: @@ -6603,6 +6616,28 @@ parse_omp_metadirective_body (gfc_statement omp_st) *variant->code = *gfc_state_stack->head; pop_state (); + gfc_omp_metadirective_region_stack.pop (); + int outer_omp_metadirective_region + = gfc_omp_metadirective_region_stack.last (); + + /* Rebind labels in the last statement -- which is the first statement + past the end of the metadirective body -- to the outer region. */ + if (gfc_statement_label) + gfc_statement_label = gfc_rebind_label (gfc_statement_label, + outer_omp_metadirective_region); + if ((new_st.op == EXEC_READ || new_st.op == EXEC_WRITE) + && new_st.ext.dt->format_label + && new_st.ext.dt->format_label != &format_asterisk) + new_st.ext.dt->format_label + = gfc_rebind_label (new_st.ext.dt->format_label, + outer_omp_metadirective_region); + if (new_st.label1) + new_st.label1 + = gfc_rebind_label (new_st.label1, outer_omp_metadirective_region); + if (new_st.here) + new_st.here + = gfc_rebind_label (new_st.here, outer_omp_metadirective_region); + gfc_commit_symbols (); gfc_warning_check (); if (variant->next) @@ -7106,6 +7141,15 @@ loop: accept_statement (st); goto done; + /* Specification statements cannot appear after executable statements. */ + case_decl: + case_omp_decl: + gfc_error ("%s statement at %C cannot appear after executable statements", + gfc_ascii_statement (st)); + reject_statement (); + st = next_statement (); + continue; + default: break; } @@ -7578,6 +7622,8 @@ gfc_parse_file (void) gfc_statement_label = NULL; gfc_omp_metadirective_region_count = 0; + gfc_omp_metadirective_region_stack.truncate (0); + gfc_omp_metadirective_region_stack.safe_push (0); gfc_in_omp_metadirective_body = false; gfc_matching_omp_context_selector = false; @@ -7765,45 +7811,53 @@ done: { case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST: omp_requires_mask - = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_SEQ_CST); + = (enum omp_requires) (omp_requires_mask + | int (OMP_MEMORY_ORDER_SEQ_CST)); break; case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL: omp_requires_mask - = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_ACQ_REL); + = (enum omp_requires) (omp_requires_mask + | int (OMP_MEMORY_ORDER_ACQ_REL)); break; case OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE: omp_requires_mask - = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_ACQUIRE); + = (enum omp_requires) (omp_requires_mask + | int (OMP_MEMORY_ORDER_ACQUIRE)); break; case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED: omp_requires_mask - = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_RELAXED); + = (enum omp_requires) (omp_requires_mask + | int (OMP_MEMORY_ORDER_RELAXED)); break; case OMP_REQ_ATOMIC_MEM_ORDER_RELEASE: omp_requires_mask - = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_RELEASE); + = (enum omp_requires) (omp_requires_mask + | int (OMP_MEMORY_ORDER_RELEASE)); break; } if (omp_target_seen) omp_requires_mask = (enum omp_requires) (omp_requires_mask - | OMP_REQUIRES_TARGET_USED); + | int (OMP_REQUIRES_TARGET_USED)); if (omp_requires & OMP_REQ_REVERSE_OFFLOAD) - omp_requires_mask = (enum omp_requires) (omp_requires_mask - | OMP_REQUIRES_REVERSE_OFFLOAD); + omp_requires_mask + = (enum omp_requires) (omp_requires_mask + | int (OMP_REQUIRES_REVERSE_OFFLOAD)); if (omp_requires & OMP_REQ_UNIFIED_ADDRESS) - omp_requires_mask = (enum omp_requires) (omp_requires_mask - | OMP_REQUIRES_UNIFIED_ADDRESS); + omp_requires_mask + = (enum omp_requires) (omp_requires_mask + | int (OMP_REQUIRES_UNIFIED_ADDRESS)); if (omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY) omp_requires_mask - = (enum omp_requires) (omp_requires_mask - | OMP_REQUIRES_UNIFIED_SHARED_MEMORY); + = (enum omp_requires) (omp_requires_mask + | int (OMP_REQUIRES_UNIFIED_SHARED_MEMORY)); if (omp_requires & OMP_REQ_SELF_MAPS) omp_requires_mask - = (enum omp_requires) (omp_requires_mask | OMP_REQUIRES_SELF_MAPS); + = (enum omp_requires) (omp_requires_mask | int (OMP_REQUIRES_SELF_MAPS)); if (omp_requires & OMP_REQ_DYNAMIC_ALLOCATORS) - omp_requires_mask = (enum omp_requires) (omp_requires_mask - | OMP_REQUIRES_DYNAMIC_ALLOCATORS); + omp_requires_mask + = (enum omp_requires) (omp_requires_mask + | int (OMP_REQUIRES_DYNAMIC_ALLOCATORS)); /* Do the parse tree dump. */ gfc_current_ns = flag_dump_fortran_original ? gfc_global_ns_list : NULL; diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h index 7bf0fa4..70ffcbd 100644 --- a/gcc/fortran/parse.h +++ b/gcc/fortran/parse.h @@ -22,6 +22,8 @@ along with GCC; see the file COPYING3. If not see #ifndef GFC_PARSE_H #define GFC_PARSE_H +#include "vec.h" + /* Enum for what the compiler is currently doing. */ enum gfc_compile_state { @@ -76,6 +78,7 @@ extern bool gfc_matching_function; extern bool gfc_matching_omp_context_selector; extern bool gfc_in_omp_metadirective_body; extern int gfc_omp_metadirective_region_count; +extern vec<int> gfc_omp_metadirective_region_stack; match gfc_match_prefix (gfc_typespec *); bool is_oacc (gfc_state_data *); diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc index 1dcb1c3..e5e84e8 100644 --- a/gcc/fortran/primary.cc +++ b/gcc/fortran/primary.cc @@ -2261,6 +2261,32 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, && !sym->attr.select_rank_temporary) inferred_type = true; + /* Try to resolve a typebound generic procedure so that the associate name + has a chance to get a type before being used in a second, nested associate + statement. Note that a copy is used for resolution so that failure does + not result in a mutilated selector expression further down the line. */ + if (tgt_expr && !sym->assoc->dangling + && tgt_expr->ts.type == BT_UNKNOWN + && tgt_expr->symtree + && tgt_expr->symtree->n.sym + && gfc_expr_attr (tgt_expr).generic + && ((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_template) + || (sym->ts.type == BT_CLASS + && CLASS_DATA (sym)->ts.u.derived->attr.pdt_template))) + { + gfc_expr *cpy = gfc_copy_expr (tgt_expr); + if (gfc_resolve_expr (cpy) + && cpy->ts.type != BT_UNKNOWN) + { + gfc_replace_expr (tgt_expr, cpy); + sym->ts = tgt_expr->ts; + } + else + gfc_free_expr (cpy); + if (gfc_expr_attr (tgt_expr).generic) + inferred_type = true; + } + /* For associate names, we may not yet know whether they are arrays or not. If the selector expression is unambiguously an array; eg. a full array or an array section, then the associate name must be an array and we can @@ -2493,6 +2519,20 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, && !gfc_find_derived_types (sym, gfc_current_ns, name)) primary->ts.type = BT_UNKNOWN; + /* Otherwise try resolving a copy of a component call. If it succeeds, + use that for the selector expression. */ + else if (tgt_expr && tgt_expr->expr_type == EXPR_COMPCALL) + { + gfc_expr *cpy = gfc_copy_expr (tgt_expr); + if (gfc_resolve_expr (cpy)) + { + gfc_replace_expr (tgt_expr, cpy); + sym->ts = tgt_expr->ts; + } + else + gfc_free_expr (cpy); + } + /* An inquiry reference might determine the type, otherwise we have an error. */ if (sym->ts.type == BT_UNKNOWN && !inquiry) @@ -3543,7 +3583,7 @@ gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **c } /* Find the current component in the structure definition and check - its access is not private. */ + its access is not private. */ if (comp) this_comp = gfc_find_component (sym, comp->name, false, false, NULL); else @@ -3836,8 +3876,6 @@ gfc_match_rvalue (gfc_expr **result) bool implicit_char; gfc_ref *ref; gfc_symtree *pdt_st; - gfc_symbol *found_specific = NULL; - m = gfc_match ("%%loc"); if (m == MATCH_YES) @@ -4085,29 +4123,21 @@ gfc_match_rvalue (gfc_expr **result) break; } - gfc_gobble_whitespace (); - found_specific = NULL; - - /* Even if 'name' is that of a PDT template, priority has to be given to - possible specific procedures in the generic interface. */ - gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &pdt_st); - if (sym->generic && sym->generic->next - && gfc_peek_ascii_char() != '(') - { - gfc_actual_arglist *arg = actual_arglist; - for (; arg && pdt_st; arg = arg->next) - gfc_resolve_expr (arg->expr); - found_specific = gfc_search_interface (sym->generic, 0, - &actual_arglist); - } - /* Check to see if this is a PDT constructor. The format of these constructors is rather unusual: name [(type_params)](component_values) where, component_values excludes the type_params. With the present gfortran representation this is rather awkward because the two are not - distinguished, other than by their attributes. */ - if (sym->attr.generic && pdt_st != NULL && found_specific == NULL) + distinguished, other than by their attributes. + + Even if 'name' is that of a PDT template, priority has to be given to + specific procedures, other than the constructor, in the generic + interface. */ + + gfc_gobble_whitespace (); + gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &pdt_st); + if (sym->attr.generic && pdt_st != NULL + && !(sym->generic->next && gfc_peek_ascii_char() != '(')) { gfc_symbol *pdt_sym; gfc_actual_arglist *ctr_arglist = NULL, *tmp; @@ -4172,12 +4202,8 @@ gfc_match_rvalue (gfc_expr **result) tmp = tmp->next; } - if (found_specific) - gfc_find_sym_tree (found_specific->name, - NULL, 1, &symtree); - else - gfc_find_sym_tree (gfc_dt_lower_string (pdt_sym->name), - NULL, 1, &symtree); + gfc_find_sym_tree (gfc_dt_lower_string (pdt_sym->name), + NULL, 1, &symtree); if (!symtree) { gfc_get_ha_sym_tree (gfc_dt_lower_string (pdt_sym->name) , @@ -4187,11 +4213,21 @@ gfc_match_rvalue (gfc_expr **result) symtree->n.sym->ts.type = BT_DERIVED; } - /* Append the type_params and the component_values. */ - for (tmp = ctr_arglist; tmp && tmp->next;) - tmp = tmp->next; - tmp->next = actual_arglist; - actual_arglist = ctr_arglist; + if (type_spec_list) + { + /* Append the type_params and the component_values. */ + for (tmp = ctr_arglist; tmp && tmp->next;) + tmp = tmp->next; + tmp->next = actual_arglist; + actual_arglist = ctr_arglist; + tmp = actual_arglist; + /* Can now add all the component names. */ + for (c = pdt_sym->components; c && tmp; c = c->next) + { + tmp->name = c->name; + tmp = tmp->next; + } + } } } diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 03e26f0..db6b52f 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -6151,7 +6151,7 @@ gfc_resolve_ref (gfc_expr *expr) } /* The F08 standard requires(See R425, R431, R435, and in particular - Note 6.7) that a PDT parameter reference be a scalar even if + Note 6.7) that a PDT parameter reference be a scalar even if the designator is an array." */ if (array_ref && last_pdt && last_pdt->attr.pdt_type && (ref->u.c.component->attr.pdt_kind @@ -8461,7 +8461,20 @@ check_default_none_expr (gfc_expr **e, int *, void *data) break; ns2 = ns2->parent; } - if (ns2 != NULL) + + /* A DO CONCURRENT iterator cannot appear in a locality spec. */ + if (sym->ns->code->ext.concur.forall_iterator) + { + gfc_forall_iterator *iter + = sym->ns->code->ext.concur.forall_iterator; + for (; iter; iter = iter->next) + if (iter->var->symtree + && strcmp(sym->name, iter->var->symtree->name) == 0) + return 0; + } + + /* A named constant is not a variable, so skip test. */ + if (ns2 != NULL && sym->attr.flavor != FL_PARAMETER) { gfc_error ("Variable %qs at %L not specified in a locality spec " "of DO CONCURRENT at %L but required due to " @@ -8741,6 +8754,8 @@ resolve_locality_spec (gfc_code *code, gfc_namespace *ns) plist = &((*plist)->next); } } + + delete data.sym_hash; } /* Resolve a list of FORALL iterators. The FORALL index-name is constrained @@ -9784,8 +9799,10 @@ done_errmsg: /* Resolving the expr3 in the loop over all objects to allocate would execute loop invariant code for each loop item. Therefore do it just once here. */ + mpz_t nelem; if (code->expr3 && code->expr3->mold - && code->expr3->ts.type == BT_DERIVED) + && code->expr3->ts.type == BT_DERIVED + && !(code->expr3->ref && gfc_array_size (code->expr3, &nelem))) { /* Default initialization via MOLD (non-polymorphic). */ gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts); @@ -10775,6 +10792,10 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) /* If the target is a good class object, so is the associate variable. */ if (sym->ts.type == BT_CLASS && gfc_expr_attr (target).class_ok) sym->attr.class_ok = 1; + + /* If the target is a contiguous pointer, so is the associate variable. */ + if (gfc_expr_attr (target).pointer && gfc_expr_attr (target).contiguous) + sym->attr.contiguous = 1; } @@ -12236,11 +12257,10 @@ static void gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr) { int n; + gfc_symbol *forall_index; for (n = 0; n < nvar; n++) { - gfc_symbol *forall_index; - forall_index = var_expr[n]->symtree->n.sym; /* Check whether the assignment target is one of the FORALL index @@ -12254,8 +12274,12 @@ gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr) /* If one of the FORALL index variables doesn't appear in the assignment variable, then there could be a many-to-one assignment. Emit a warning rather than an error because the - mask could be resolving this problem. */ - if (!find_forall_index (code->expr1, forall_index, 0)) + mask could be resolving this problem. + DO NOT emit this warning for DO CONCURRENT - reduction-like + many-to-one assignments are semantically valid (formalized with + the REDUCE locality-spec in Fortran 2023). */ + if (!find_forall_index (code->expr1, forall_index, 0) + && !gfc_do_concurrent_flag) gfc_warning (0, "The FORALL with index %qs is not used on the " "left side of the assignment at %L and so might " "cause multiple assignment to this object", @@ -12375,7 +12399,7 @@ gfc_count_forall_iterators (gfc_code *code) int max_iters, sub_iters, current_iters; gfc_forall_iterator *fa; - gcc_assert(code->op == EXEC_FORALL); + gcc_assert (code->op == EXEC_FORALL || code->op == EXEC_DO_CONCURRENT); max_iters = 0; current_iters = 0; @@ -12386,7 +12410,7 @@ gfc_count_forall_iterators (gfc_code *code) while (code) { - if (code->op == EXEC_FORALL) + if (code->op == EXEC_FORALL || code->op == EXEC_DO_CONCURRENT) { sub_iters = gfc_count_forall_iterators (code); if (sub_iters > max_iters) @@ -12399,8 +12423,160 @@ gfc_count_forall_iterators (gfc_code *code) } -/* Given a FORALL construct, first resolve the FORALL iterator, then call - gfc_resolve_forall_body to resolve the FORALL body. */ +/* Given a FORALL construct. + 1) Resolve the FORALL iterator. + 2) Check for shadow index-name(s) and update code block. + 3) call gfc_resolve_forall_body to resolve the FORALL body. */ + +/* Custom recursive expression walker that replaces symbols. + This ensures we visit ALL expressions including those in array subscripts. */ + +static void +replace_in_expr_recursive (gfc_expr *expr, gfc_symbol *old_sym, gfc_symtree *new_st) +{ + if (!expr) + return; + + /* Check if this is a variable reference to replace */ + if (expr->expr_type == EXPR_VARIABLE && expr->symtree->n.sym == old_sym) + { + expr->symtree = new_st; + expr->ts = new_st->n.sym->ts; + } + + /* Walk through reference chain (array subscripts, substrings, etc.) */ + for (gfc_ref *ref = expr->ref; ref; ref = ref->next) + { + if (ref->type == REF_ARRAY) + { + gfc_array_ref *ar = &ref->u.ar; + for (int i = 0; i < ar->dimen; i++) + { + replace_in_expr_recursive (ar->start[i], old_sym, new_st); + replace_in_expr_recursive (ar->end[i], old_sym, new_st); + replace_in_expr_recursive (ar->stride[i], old_sym, new_st); + } + } + else if (ref->type == REF_SUBSTRING) + { + replace_in_expr_recursive (ref->u.ss.start, old_sym, new_st); + replace_in_expr_recursive (ref->u.ss.end, old_sym, new_st); + } + } + + /* Walk through sub-expressions based on expression type */ + switch (expr->expr_type) + { + case EXPR_OP: + replace_in_expr_recursive (expr->value.op.op1, old_sym, new_st); + replace_in_expr_recursive (expr->value.op.op2, old_sym, new_st); + break; + + case EXPR_FUNCTION: + for (gfc_actual_arglist *a = expr->value.function.actual; a; a = a->next) + replace_in_expr_recursive (a->expr, old_sym, new_st); + break; + + case EXPR_ARRAY: + case EXPR_STRUCTURE: + for (gfc_constructor *c = gfc_constructor_first (expr->value.constructor); + c; c = gfc_constructor_next (c)) + { + replace_in_expr_recursive (c->expr, old_sym, new_st); + if (c->iterator) + { + replace_in_expr_recursive (c->iterator->start, old_sym, new_st); + replace_in_expr_recursive (c->iterator->end, old_sym, new_st); + replace_in_expr_recursive (c->iterator->step, old_sym, new_st); + } + } + break; + + default: + break; + } +} + + +/* Walk code tree and replace all variable references */ + +static void +replace_in_code_recursive (gfc_code *code, gfc_symbol *old_sym, gfc_symtree *new_st) +{ + if (!code) + return; + + for (gfc_code *c = code; c; c = c->next) + { + /* Replace in expressions associated with this code node */ + replace_in_expr_recursive (c->expr1, old_sym, new_st); + replace_in_expr_recursive (c->expr2, old_sym, new_st); + replace_in_expr_recursive (c->expr3, old_sym, new_st); + replace_in_expr_recursive (c->expr4, old_sym, new_st); + + /* Handle special code types with additional expressions */ + switch (c->op) + { + case EXEC_DO: + if (c->ext.iterator) + { + replace_in_expr_recursive (c->ext.iterator->start, old_sym, new_st); + replace_in_expr_recursive (c->ext.iterator->end, old_sym, new_st); + replace_in_expr_recursive (c->ext.iterator->step, old_sym, new_st); + } + break; + + case EXEC_CALL: + case EXEC_ASSIGN_CALL: + for (gfc_actual_arglist *a = c->ext.actual; a; a = a->next) + replace_in_expr_recursive (a->expr, old_sym, new_st); + break; + + case EXEC_SELECT: + for (gfc_code *b = c->block; b; b = b->block) + { + for (gfc_case *cp = b->ext.block.case_list; cp; cp = cp->next) + { + replace_in_expr_recursive (cp->low, old_sym, new_st); + replace_in_expr_recursive (cp->high, old_sym, new_st); + } + replace_in_code_recursive (b->next, old_sym, new_st); + } + break; + + case EXEC_FORALL: + case EXEC_DO_CONCURRENT: + for (gfc_forall_iterator *fa = c->ext.concur.forall_iterator; fa; fa = fa->next) + { + replace_in_expr_recursive (fa->start, old_sym, new_st); + replace_in_expr_recursive (fa->end, old_sym, new_st); + replace_in_expr_recursive (fa->stride, old_sym, new_st); + } + /* Don't recurse into nested FORALL/DO CONCURRENT bodies here, + they'll be handled separately */ + break; + + default: + break; + } + + /* Recurse into blocks */ + if (c->block) + replace_in_code_recursive (c->block->next, old_sym, new_st); + } +} + + +/* Replace all references to outer_sym with shadow_st in the given code. */ + +static void +gfc_replace_forall_variable (gfc_code **code_ptr, gfc_symbol *outer_sym, + gfc_symtree *shadow_st) +{ + /* Use custom recursive walker to ensure we visit ALL expressions */ + replace_in_code_recursive (*code_ptr, outer_sym, shadow_st); +} + static void gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) @@ -12410,14 +12586,21 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) static int nvar = 0; int i, old_nvar, tmp; gfc_forall_iterator *fa; + bool shadow = false; old_nvar = nvar; - if (!gfc_notify_std (GFC_STD_F2018_OBS, "FORALL construct at %L", &code->loc)) + /* Only warn about obsolescent FORALL, not DO CONCURRENT */ + if (code->op == EXEC_FORALL + && !gfc_notify_std (GFC_STD_F2018_OBS, "FORALL construct at %L", &code->loc)) return; /* Start to resolve a FORALL construct */ - if (forall_save == 0) + /* Allocate var_expr only at the truly outermost FORALL/DO CONCURRENT level. + forall_save==0 means we're not nested in a FORALL in the current scope, + but nvar==0 ensures we're not nested in a parent scope either (prevents + double allocation when FORALL is nested inside DO CONCURRENT). */ + if (forall_save == 0 && nvar == 0) { /* Count the total number of FORALL indices in the nested FORALL construct in order to allocate the VAR_EXPR with proper size. */ @@ -12427,11 +12610,12 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) var_expr = XCNEWVEC (gfc_expr *, total_var); } - /* The information about FORALL iterator, including FORALL indices start, end - and stride. An outer FORALL indice cannot appear in start, end or stride. */ + /* The information about FORALL iterator, including FORALL indices start, + end and stride. An outer FORALL indice cannot appear in start, end or + stride. Check for a shadow index-name. */ for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next) { - /* Fortran 20008: C738 (R753). */ + /* Fortran 2008: C738 (R753). */ if (fa->var->ref && fa->var->ref->type == REF_ARRAY) { gfc_error ("FORALL index-name at %L must be a scalar variable " @@ -12440,14 +12624,19 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) } /* Check if any outer FORALL index name is the same as the current - one. */ + one. Skip this check if the iterator is a shadow variable (from + DO CONCURRENT type spec) which may not have a symtree yet. */ for (i = 0; i < nvar; i++) { - if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym) + if (fa->var && fa->var->symtree && var_expr[i] && var_expr[i]->symtree + && fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym) gfc_error ("An outer FORALL construct already has an index " "with this name %L", &fa->var->where); } + if (fa->shadow) + shadow = true; + /* Record the current FORALL index. */ var_expr[nvar] = gfc_copy_expr (fa->var); @@ -12457,6 +12646,47 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) gcc_assert (nvar <= total_var); } + /* Need to walk the code and replace references to the index-name with + references to the shadow index-name. This must be done BEFORE resolving + the body so that resolution uses the correct shadow variables. */ + if (shadow) + { + /* Walk the FORALL/DO CONCURRENT body and replace references to shadowed variables. */ + for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next) + { + if (fa->shadow) + { + gfc_symtree *shadow_st; + const char *shadow_name_str; + char *outer_name; + + /* fa->var now points to the shadow variable "_name". */ + shadow_name_str = fa->var->symtree->name; + shadow_st = fa->var->symtree; + + if (shadow_name_str[0] != '_') + gfc_internal_error ("Expected shadow variable name to start with _"); + + outer_name = (char *) alloca (strlen (shadow_name_str)); + strcpy (outer_name, shadow_name_str + 1); + + /* Find the ITERATOR symbol in the current namespace. + This is the local DO CONCURRENT variable that body expressions reference. */ + gfc_symtree *iter_st = gfc_find_symtree (ns->sym_root, outer_name); + + if (!iter_st) + /* No iterator variable found - this shouldn't happen */ + continue; + + gfc_symbol *iter_sym = iter_st->n.sym; + + /* Walk the FORALL/DO CONCURRENT body and replace all references. */ + if (code->block && code->block->next) + gfc_replace_forall_variable (&code->block->next, iter_sym, shadow_st); + } + } + } + /* Resolve the FORALL body. */ gfc_resolve_forall_body (code, nvar, var_expr); @@ -13726,11 +13956,17 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns) forall_save = forall_flag; do_concurrent_save = gfc_do_concurrent_flag; - if (code->op == EXEC_FORALL) + if (code->op == EXEC_FORALL || code->op == EXEC_DO_CONCURRENT) { - forall_flag = 1; + if (code->op == EXEC_FORALL) + forall_flag = 1; + else if (code->op == EXEC_DO_CONCURRENT) + gfc_do_concurrent_flag = 1; gfc_resolve_forall (code, ns, forall_save); - forall_flag = 2; + if (code->op == EXEC_FORALL) + forall_flag = 2; + else if (code->op == EXEC_DO_CONCURRENT) + gfc_do_concurrent_flag = 2; } else if (code->op == EXEC_OMP_METADIRECTIVE) for (gfc_omp_variant *variant @@ -15602,7 +15838,7 @@ check_formal: static bool gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable) { - gfc_finalizer* list; + gfc_finalizer *list, *pdt_finalizers = NULL; gfc_finalizer** prev_link; /* For removing wrong entries from the list. */ bool result = true; bool seen_scalar = false; @@ -15632,6 +15868,41 @@ gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable) return true; } + /* If a PDT has finalizers, the pdt_type's f2k_derived is a copy of that of + the template. If the finalizers field has the same value, it needs to be + supplied with finalizers of the same pdt_type. */ + if (derived->attr.pdt_type + && derived->template_sym + && derived->template_sym->f2k_derived + && (pdt_finalizers = derived->template_sym->f2k_derived->finalizers) + && derived->f2k_derived->finalizers == pdt_finalizers) + { + gfc_finalizer *tmp = NULL; + derived->f2k_derived->finalizers = NULL; + prev_link = &derived->f2k_derived->finalizers; + for (list = pdt_finalizers; list; list = list->next) + { + gfc_formal_arglist *args = gfc_sym_get_dummy_args (list->proc_sym); + if (args->sym + && args->sym->ts.type == BT_DERIVED + && args->sym->ts.u.derived + && !strcmp (args->sym->ts.u.derived->name, derived->name)) + { + tmp = gfc_get_finalizer (); + *tmp = *list; + tmp->next = NULL; + if (*prev_link) + { + (*prev_link)->next = tmp; + prev_link = &tmp; + } + else + *prev_link = tmp; + list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym); + } + } + } + /* Walk over the list of finalizer-procedures, check them, and if any one does not fit in with the standard's definition, print an error and remove it from the list. */ @@ -15688,7 +15959,8 @@ gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable) } /* This argument must be of our type. */ - if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived) + if (!derived->attr.pdt_template + && (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)) { gfc_error ("Argument of FINAL procedure at %L must be of type %qs", &arg->declared_at, derived->name); @@ -15743,7 +16015,7 @@ gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable) /* Argument list might be empty; that is an error signalled earlier, but we nevertheless continued resolving. */ dummy_args = gfc_sym_get_dummy_args (i->proc_sym); - if (dummy_args) + if (dummy_args && !derived->attr.pdt_template) { gfc_symbol* i_arg = dummy_args->sym; const int i_rank = (i_arg->as ? i_arg->as->rank : 0); @@ -15791,9 +16063,13 @@ error: " rank finalizer has been declared", derived->name, &derived->declared_at); - vtab = gfc_find_derived_vtab (derived); - c = vtab->ts.u.derived->components->next->next->next->next->next; - gfc_set_sym_referenced (c->initializer->symtree->n.sym); + if (!derived->attr.pdt_template) + { + vtab = gfc_find_derived_vtab (derived); + c = vtab->ts.u.derived->components->next->next->next->next->next; + if (c && c->initializer && c->initializer->symtree && c->initializer->symtree->n.sym) + gfc_set_sym_referenced (c->initializer->symtree->n.sym); + } if (finalizable) *finalizable = true; @@ -17869,6 +18145,7 @@ skip_interfaces: /* F2008, C530. */ if (sym->attr.contiguous + && !sym->attr.associate_var && (!class_attr.dimension || (as->type != AS_ASSUMED_SHAPE && as->type != AS_ASSUMED_RANK && !class_attr.pointer))) @@ -18440,17 +18717,30 @@ skip_interfaces: } /* Check threadprivate restrictions. */ - if (sym->attr.threadprivate + if ((sym->attr.threadprivate || sym->attr.omp_groupprivate) && !(sym->attr.save || sym->attr.data || sym->attr.in_common) && !(sym->ns->save_all && !sym->attr.automatic) && sym->module == NULL && (sym->ns->proc_name == NULL || (sym->ns->proc_name->attr.flavor != FL_MODULE && !sym->ns->proc_name->attr.is_main_program))) - gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at); + { + if (sym->attr.threadprivate) + gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at); + else + gfc_error ("OpenMP groupprivate variable %qs at %L must have the SAVE " + "attribute", sym->name, &sym->declared_at); + } + + if (sym->attr.omp_groupprivate && sym->value) + gfc_error ("!$OMP GROUPPRIVATE variable %qs at %L must not have an " + "initializer", sym->name, &sym->declared_at); /* Check omp declare target restrictions. */ - if (sym->attr.omp_declare_target + if ((sym->attr.omp_declare_target + || sym->attr.omp_declare_target_link + || sym->attr.omp_declare_target_local) + && !sym->attr.omp_groupprivate /* already warned. */ && sym->attr.flavor == FL_VARIABLE && !sym->attr.save && !(sym->ns->save_all && !sym->attr.automatic) diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc index 8211d92..62925c0 100644 --- a/gcc/fortran/symbol.cc +++ b/gcc/fortran/symbol.cc @@ -458,8 +458,10 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) *contiguous = "CONTIGUOUS", *generic = "GENERIC", *automatic = "AUTOMATIC", *pdt_len = "LEN", *pdt_kind = "KIND"; static const char *threadprivate = "THREADPRIVATE"; + static const char *omp_groupprivate = "OpenMP GROUPPRIVATE"; static const char *omp_declare_target = "OMP DECLARE TARGET"; static const char *omp_declare_target_link = "OMP DECLARE TARGET LINK"; + static const char *omp_declare_target_local = "OMP DECLARE TARGET LOCAL"; static const char *oacc_declare_copyin = "OACC DECLARE COPYIN"; static const char *oacc_declare_create = "OACC DECLARE CREATE"; static const char *oacc_declare_deviceptr = "OACC DECLARE DEVICEPTR"; @@ -553,8 +555,10 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (dummy, entry); conf (dummy, intrinsic); conf (dummy, threadprivate); + conf (dummy, omp_groupprivate); conf (dummy, omp_declare_target); conf (dummy, omp_declare_target_link); + conf (dummy, omp_declare_target_local); conf (pointer, target); conf (pointer, intrinsic); conf (pointer, elemental); @@ -604,8 +608,10 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (in_equivalence, entry); conf (in_equivalence, allocatable); conf (in_equivalence, threadprivate); + conf (in_equivalence, omp_groupprivate); conf (in_equivalence, omp_declare_target); conf (in_equivalence, omp_declare_target_link); + conf (in_equivalence, omp_declare_target_local); conf (in_equivalence, oacc_declare_create); conf (in_equivalence, oacc_declare_copyin); conf (in_equivalence, oacc_declare_deviceptr); @@ -616,6 +622,7 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (entry, result); conf (generic, result); conf (generic, omp_declare_target); + conf (generic, omp_declare_target_local); conf (generic, omp_declare_target_link); conf (function, subroutine); @@ -661,8 +668,10 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (cray_pointee, in_common); conf (cray_pointee, in_equivalence); conf (cray_pointee, threadprivate); + conf (cray_pointee, omp_groupprivate); conf (cray_pointee, omp_declare_target); conf (cray_pointee, omp_declare_target_link); + conf (cray_pointee, omp_declare_target_local); conf (cray_pointee, oacc_declare_create); conf (cray_pointee, oacc_declare_copyin); conf (cray_pointee, oacc_declare_deviceptr); @@ -720,9 +729,11 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (proc_pointer, abstract) conf (proc_pointer, omp_declare_target) + conf (proc_pointer, omp_declare_target_local) conf (proc_pointer, omp_declare_target_link) conf (entry, omp_declare_target) + conf (entry, omp_declare_target_local) conf (entry, omp_declare_target_link) conf (entry, oacc_declare_create) conf (entry, oacc_declare_copyin) @@ -782,8 +793,10 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf2 (function); conf2 (subroutine); conf2 (threadprivate); + conf2 (omp_groupprivate); conf2 (omp_declare_target); conf2 (omp_declare_target_link); + conf2 (omp_declare_target_local); conf2 (oacc_declare_create); conf2 (oacc_declare_copyin); conf2 (oacc_declare_deviceptr); @@ -828,7 +841,10 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf2 (dimension); conf2 (function); if (!attr->proc_pointer) - conf2 (threadprivate); + { + conf2 (threadprivate); + conf2 (omp_groupprivate); + } } /* Procedure pointers in COMMON blocks are allowed in F03, @@ -836,6 +852,7 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) if (!attr->proc_pointer || (gfc_option.allow_std & GFC_STD_F2008)) conf2 (in_common); + conf2 (omp_declare_target_local); conf2 (omp_declare_target_link); switch (attr->proc) @@ -852,6 +869,7 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) case PROC_DUMMY: conf2 (result); conf2 (threadprivate); + conf2 (omp_groupprivate); break; default: @@ -872,8 +890,10 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf2 (function); conf2 (subroutine); conf2 (threadprivate); + conf2 (omp_groupprivate); conf2 (result); conf2 (omp_declare_target); + conf2 (omp_declare_target_local); conf2 (omp_declare_target_link); conf2 (oacc_declare_create); conf2 (oacc_declare_copyin); @@ -905,6 +925,7 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) conf2 (volatile_); conf2 (asynchronous); conf2 (threadprivate); + conf2 (omp_groupprivate); conf2 (value); conf2 (codimension); conf2 (result); @@ -1407,6 +1428,25 @@ gfc_add_asynchronous (symbol_attribute *attr, const char *name, locus *where) bool +gfc_add_omp_groupprivate (symbol_attribute *attr, const char *name, + locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + if (attr->omp_groupprivate) + { + duplicate_attr ("OpenMP GROUPPRIVATE", where); + return false; + } + + attr->omp_groupprivate = true; + return gfc_check_conflict (attr, name, where); +} + + +bool gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where) { @@ -1457,6 +1497,22 @@ gfc_add_omp_declare_target_link (symbol_attribute *attr, const char *name, bool +gfc_add_omp_declare_target_local (symbol_attribute *attr, const char *name, + locus *where) +{ + + if (check_used (attr, name, where)) + return false; + + if (attr->omp_declare_target_local) + return true; + + attr->omp_declare_target_local = 1; + return gfc_check_conflict (attr, name, where); +} + + +bool gfc_add_oacc_declare_create (symbol_attribute *attr, const char *name, locus *where) { @@ -2110,6 +2166,9 @@ gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where) goto fail; if (src->asynchronous && !gfc_add_asynchronous (dest, NULL, where)) goto fail; + if (src->omp_groupprivate + && !gfc_add_omp_groupprivate (dest, NULL, where)) + goto fail; if (src->threadprivate && !gfc_add_threadprivate (dest, NULL, where)) goto fail; @@ -2119,6 +2178,9 @@ gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where) if (src->omp_declare_target_link && !gfc_add_omp_declare_target_link (dest, NULL, where)) goto fail; + if (src->omp_declare_target_local + && !gfc_add_omp_declare_target_local (dest, NULL, where)) + goto fail; if (src->oacc_declare_create && !gfc_add_oacc_declare_create (dest, NULL, where)) goto fail; @@ -2753,8 +2815,7 @@ gfc_get_st_label (int labelno) { gfc_st_label *lp; gfc_namespace *ns; - int omp_region = (gfc_in_omp_metadirective_body - ? gfc_omp_metadirective_region_count : 0); + int omp_region = gfc_omp_metadirective_region_stack.last (); if (gfc_current_state () == COMP_DERIVED) ns = gfc_current_block ()->f2k_derived; @@ -2768,22 +2829,28 @@ gfc_get_st_label (int labelno) } /* First see if the label is already in this namespace. */ - lp = ns->st_labels; - while (lp) + gcc_checking_assert (gfc_omp_metadirective_region_stack.length () > 0); + for (int omp_region_idx = gfc_omp_metadirective_region_stack.length () - 1; + omp_region_idx >= 0; omp_region_idx--) { - if (lp->omp_region == omp_region) + int omp_region2 = gfc_omp_metadirective_region_stack[omp_region_idx]; + lp = ns->st_labels; + while (lp) { - if (lp->value == labelno) - return lp; - if (lp->value < labelno) + if (lp->omp_region == omp_region2) + { + if (lp->value == labelno) + return lp; + if (lp->value < labelno) + lp = lp->left; + else + lp = lp->right; + } + else if (lp->omp_region < omp_region2) lp = lp->left; else lp = lp->right; } - else if (lp->omp_region < omp_region) - lp = lp->left; - else - lp = lp->right; } lp = XCNEW (gfc_st_label); @@ -2799,6 +2866,53 @@ gfc_get_st_label (int labelno) return lp; } +/* Rebind a statement label to a new OpenMP region. If a label with the same + value already exists in the new region, update it and return it. Otherwise, + move the label to the new region. */ + +gfc_st_label * +gfc_rebind_label (gfc_st_label *label, int new_omp_region) +{ + gfc_st_label *lp = label->ns->st_labels; + int labelno = label->value; + + while (lp) + { + if (lp->omp_region == new_omp_region) + { + if (lp->value == labelno) + { + if (lp == label) + return label; + if (lp->defined == ST_LABEL_UNKNOWN + && label->defined != ST_LABEL_UNKNOWN) + lp->defined = label->defined; + if (lp->referenced == ST_LABEL_UNKNOWN + && label->referenced != ST_LABEL_UNKNOWN) + lp->referenced = label->referenced; + if (lp->format == NULL && label->format != NULL) + lp->format = label->format; + gfc_delete_bbt (&label->ns->st_labels, label, compare_st_labels); + return lp; + } + if (lp->value < labelno) + lp = lp->left; + else + lp = lp->right; + } + else if (lp->omp_region < new_omp_region) + lp = lp->left; + else + lp = lp->right; + } + + gfc_delete_bbt (&label->ns->st_labels, label, compare_st_labels); + label->left = nullptr; + label->right = nullptr; + label->omp_region = new_omp_region; + gfc_insert_bbt (&label->ns->st_labels, label, compare_st_labels); + return label; +} /* Called when a statement with a statement label is about to be accepted. We add the label to the list of the current namespace, @@ -2812,7 +2926,7 @@ gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus) labelno = lp->value; - if (lp->defined != ST_LABEL_UNKNOWN) + if (lp->defined != ST_LABEL_UNKNOWN && !gfc_in_omp_metadirective_body) gfc_error ("Duplicate statement label %d at %L and %L", labelno, &lp->where, label_locus); else @@ -2897,6 +3011,7 @@ gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type) } if (lp->referenced == ST_LABEL_DO_TARGET && type == ST_LABEL_DO_TARGET + && !gfc_in_omp_metadirective_body && !gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL, "Shared DO termination label %d at %C", labelno)) return false; @@ -3172,7 +3287,21 @@ gfc_free_symbol (gfc_symbol *&sym) gfc_free_formal_arglist (sym->formal); - gfc_free_namespace (sym->f2k_derived); + /* The pdt_type f2k_derived namespaces are copies of that of the pdt_template + and are only made if there are finalizers. The complete list of finalizers + is kept by the pdt_template and are freed with its f2k_derived. */ + if (!sym->attr.pdt_type) + gfc_free_namespace (sym->f2k_derived); + else if (sym->f2k_derived && sym->f2k_derived->finalizers) + { + gfc_finalizer *p, *q = NULL; + for (p = sym->f2k_derived->finalizers; p; p = q) + { + q = p->next; + free (p); + } + free (sym->f2k_derived); + } set_symbol_common_block (sym, NULL); diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index cb40816..cd13721 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -92,6 +92,8 @@ along with GCC; see the file COPYING3. If not see #include "trans-array.h" #include "trans-const.h" #include "dependency.h" +#include "cgraph.h" /* For cgraph_node::add_new_function. */ +#include "function.h" /* For push_struct_function. */ static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base); @@ -10022,6 +10024,142 @@ enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, BCAST_ALLOC_COMP}; static gfc_actual_arglist *pdt_param_list; +static bool generating_copy_helper; +static hash_set<gfc_symbol *> seen_derived_types; + +/* Forward declaration of structure_alloc_comps for wrapper generator. */ +static tree structure_alloc_comps (gfc_symbol *, tree, tree, int, int, int, + gfc_co_subroutines_args *, bool); + +/* Generate a wrapper function that performs element-wise deep copy for + recursive allocatable array components. This wrapper is passed as a + function pointer to the runtime helper _gfortran_cfi_deep_copy_array, + allowing recursion to happen at runtime instead of compile time. */ + +static tree +get_copy_helper_function_type (void) +{ + static tree fn_type = NULL_TREE; + if (fn_type == NULL_TREE) + fn_type = build_function_type_list (void_type_node, + pvoid_type_node, + pvoid_type_node, + NULL_TREE); + return fn_type; +} + +static tree +get_copy_helper_pointer_type (void) +{ + static tree ptr_type = NULL_TREE; + if (ptr_type == NULL_TREE) + ptr_type = build_pointer_type (get_copy_helper_function_type ()); + return ptr_type; +} + +static tree +generate_element_copy_wrapper (gfc_symbol *der_type, tree comp_type, + int purpose, int caf_mode) +{ + tree fndecl, fntype, result_decl; + tree dest_parm, src_parm, dest_typed, src_typed; + tree der_type_ptr; + stmtblock_t block; + tree decls; + tree body; + + fntype = get_copy_helper_function_type (); + + fndecl = build_decl (input_location, FUNCTION_DECL, + create_tmp_var_name ("copy_element"), + fntype); + + TREE_STATIC (fndecl) = 1; + TREE_USED (fndecl) = 1; + DECL_ARTIFICIAL (fndecl) = 1; + DECL_IGNORED_P (fndecl) = 0; + TREE_PUBLIC (fndecl) = 0; + DECL_UNINLINABLE (fndecl) = 1; + DECL_EXTERNAL (fndecl) = 0; + DECL_CONTEXT (fndecl) = NULL_TREE; + DECL_INITIAL (fndecl) = make_node (BLOCK); + BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl; + + result_decl = build_decl (input_location, RESULT_DECL, NULL_TREE, + void_type_node); + DECL_ARTIFICIAL (result_decl) = 1; + DECL_IGNORED_P (result_decl) = 1; + DECL_CONTEXT (result_decl) = fndecl; + DECL_RESULT (fndecl) = result_decl; + + dest_parm = build_decl (input_location, PARM_DECL, + get_identifier ("dest"), pvoid_type_node); + src_parm = build_decl (input_location, PARM_DECL, + get_identifier ("src"), pvoid_type_node); + + DECL_ARTIFICIAL (dest_parm) = 1; + DECL_ARTIFICIAL (src_parm) = 1; + DECL_ARG_TYPE (dest_parm) = pvoid_type_node; + DECL_ARG_TYPE (src_parm) = pvoid_type_node; + DECL_CONTEXT (dest_parm) = fndecl; + DECL_CONTEXT (src_parm) = fndecl; + + DECL_ARGUMENTS (fndecl) = dest_parm; + TREE_CHAIN (dest_parm) = src_parm; + + push_struct_function (fndecl); + cfun->function_end_locus = input_location; + + pushlevel (); + gfc_init_block (&block); + + bool saved_generating = generating_copy_helper; + generating_copy_helper = true; + + /* When generating a wrapper, we need a fresh type tracking state to + avoid inheriting the parent context's seen_derived_types, which would + cause infinite recursion when the wrapper tries to handle the same + recursive type. Save elements, clear the set, generate wrapper, then + restore elements. */ + vec<gfc_symbol *> saved_symbols = vNULL; + for (hash_set<gfc_symbol *>::iterator it = seen_derived_types.begin (); + it != seen_derived_types.end (); ++it) + saved_symbols.safe_push (*it); + seen_derived_types.empty (); + + der_type_ptr = build_pointer_type (comp_type); + dest_typed = fold_convert (der_type_ptr, dest_parm); + src_typed = fold_convert (der_type_ptr, src_parm); + + dest_typed = build_fold_indirect_ref (dest_typed); + src_typed = build_fold_indirect_ref (src_typed); + + body = structure_alloc_comps (der_type, src_typed, dest_typed, + 0, purpose, caf_mode, NULL, false); + gfc_add_expr_to_block (&block, body); + + /* Restore saved symbols. */ + seen_derived_types.empty (); + for (unsigned i = 0; i < saved_symbols.length (); i++) + seen_derived_types.add (saved_symbols[i]); + saved_symbols.release (); + generating_copy_helper = saved_generating; + + body = gfc_finish_block (&block); + decls = getdecls (); + + poplevel (1, 1); + + DECL_SAVED_TREE (fndecl) + = fold_build3_loc (DECL_SOURCE_LOCATION (fndecl), BIND_EXPR, + void_type_node, decls, body, DECL_INITIAL (fndecl)); + + pop_cfun (); + + cgraph_node::add_new_function (fndecl, false); + + return build1 (ADDR_EXPR, get_copy_helper_pointer_type (), fndecl); +} static tree structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, @@ -10052,7 +10190,6 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, int caf_dereg_mode; symbol_attribute *attr; bool deallocate_called; - static hash_set<gfc_symbol *> seen_derived_types; gfc_init_block (&fnblock); @@ -10186,6 +10323,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, && seen_derived_types.contains (c->ts.u.derived)) || (c->ts.type == BT_CLASS && seen_derived_types.contains (CLASS_DATA (c)->ts.u.derived)); + bool inside_wrapper = generating_copy_helper; bool is_pdt_type = c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pdt_type; @@ -10862,8 +11000,65 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, false, false, NULL_TREE, NULL_TREE); gfc_add_expr_to_block (&fnblock, tmp); } + /* Special case: recursive allocatable array components require + runtime helpers to avoid compile-time infinite recursion. Generate + a call to _gfortran_cfi_deep_copy_array with an element copy + wrapper. When inside a wrapper, reuse current_function_decl. */ + else if (c->attr.allocatable && c->as && cmp_has_alloc_comps && same_type + && purpose == COPY_ALLOC_COMP && !c->attr.proc_pointer + && !c->attr.codimension && !caf_in_coarray (caf_mode) + && c->ts.type == BT_DERIVED && c->ts.u.derived != NULL) + { + tree copy_wrapper, call, dest_addr, src_addr, elem_type; + tree helper_ptr_type; + tree alloc_expr; + int comp_rank; + + /* Get the element type from ctype (already the component + type). For arrays we need the element type, not the array + type. */ + elem_type = ctype; + if (GFC_DESCRIPTOR_TYPE_P (ctype)) + elem_type = gfc_get_element_type (ctype); + else if (TREE_CODE (ctype) == ARRAY_TYPE) + elem_type = TREE_TYPE (ctype); + + helper_ptr_type = get_copy_helper_pointer_type (); + + comp_rank = c->as ? c->as->rank : 0; + alloc_expr = gfc_duplicate_allocatable_nocopy (dcmp, comp, ctype, + comp_rank); + gfc_add_expr_to_block (&fnblock, alloc_expr); + + /* Generate or reuse the element copy helper. Inside an + existing helper we can reuse the current function to + prevent recursive generation. */ + if (inside_wrapper) + copy_wrapper + = gfc_build_addr_expr (NULL_TREE, current_function_decl); + else + copy_wrapper + = generate_element_copy_wrapper (c->ts.u.derived, elem_type, + purpose, caf_mode); + copy_wrapper = fold_convert (helper_ptr_type, copy_wrapper); + + /* Build addresses of descriptors. */ + dest_addr = gfc_build_addr_expr (pvoid_type_node, dcmp); + src_addr = gfc_build_addr_expr (pvoid_type_node, comp); + + /* Build call: _gfortran_cfi_deep_copy_array (&dcmp, &comp, + wrapper). */ + call = build_call_expr_loc (input_location, + gfor_fndecl_cfi_deep_copy_array, 3, + dest_addr, src_addr, + copy_wrapper); + gfc_add_expr_to_block (&fnblock, call); + } else if (c->attr.allocatable && !c->attr.proc_pointer - && (!(cmp_has_alloc_comps && c->as) || c->attr.codimension + && (add_when_allocated != NULL_TREE + || !cmp_has_alloc_comps + || !c->as + || c->attr.codimension || caf_in_coarray (caf_mode))) { rank = c->as ? c->as->rank : 0; diff --git a/gcc/fortran/trans-common.cc b/gcc/fortran/trans-common.cc index 135d304..6439a15 100644 --- a/gcc/fortran/trans-common.cc +++ b/gcc/fortran/trans-common.cc @@ -488,6 +488,27 @@ build_common_decl (gfc_common_head *com, tree union_type, bool is_init) } omp_clauses = c; } + /* Also check trans-decl.cc when updating/removing the following; + also update f95.c's gfc_gnu_attributes. + For the warning, see also OpenMP spec issue 4663. */ + if (com->omp_groupprivate && com->threadprivate) + { + /* Unset this flag; implicit 'declare target local(...)' remains. */ + com->omp_groupprivate = 0; + gfc_warning (OPT_Wopenmp, + "Ignoring the %<groupprivate%> attribute for " + "%<threadprivate%> common block %</%s/%> declared at %L", + com->name, &com->where); + } + if (com->omp_groupprivate) + gfc_error ("Sorry, OMP GROUPPRIVATE not implemented, used by common " + "block %</%s/%> declared at %L", com->name, &com->where); + else if (com->omp_declare_target_local) + /* Use 'else if' as groupprivate implies 'local'. */ + gfc_error ("Sorry, OMP DECLARE TARGET with LOCAL clause not implemented" + ", used by common block %</%s/%> declared at %L", + com->name, &com->where); + if (com->omp_declare_target_link) DECL_ATTRIBUTES (decl) = tree_cons (get_identifier ("omp declare target link"), @@ -497,10 +518,12 @@ build_common_decl (gfc_common_head *com, tree union_type, bool is_init) = tree_cons (get_identifier ("omp declare target"), omp_clauses, DECL_ATTRIBUTES (decl)); - if (com->omp_declare_target_link || com->omp_declare_target) + if (com->omp_declare_target_link || com->omp_declare_target + /* FIXME: || com->omp_declare_target_local */) { - /* Add to offload_vars; get_create does so for omp_declare_target, - omp_declare_target_link requires manual work. */ + /* Add to offload_vars; get_create does so for omp_declare_target + and omp_declare_target_local, omp_declare_target_link requires + manual work. */ gcc_assert (symtab_node::get (decl) == 0); symtab_node *node = symtab_node::get_create (decl); if (node != NULL && com->omp_declare_target_link) @@ -1045,8 +1068,10 @@ accumulate_equivalence_attributes (symbol_attribute *dummy_symbol, gfc_equiv *e) dummy_symbol->generic |= attr.generic; dummy_symbol->automatic |= attr.automatic; dummy_symbol->threadprivate |= attr.threadprivate; + dummy_symbol->omp_groupprivate |= attr.omp_groupprivate; dummy_symbol->omp_declare_target |= attr.omp_declare_target; dummy_symbol->omp_declare_target_link |= attr.omp_declare_target_link; + dummy_symbol->omp_declare_target_local |= attr.omp_declare_target_local; dummy_symbol->oacc_declare_copyin |= attr.oacc_declare_copyin; dummy_symbol->oacc_declare_create |= attr.oacc_declare_create; dummy_symbol->oacc_declare_deviceptr |= attr.oacc_declare_deviceptr; diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index c31c756..06edc99 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -248,6 +248,9 @@ tree gfor_fndecl_zgemm; /* RANDOM_INIT function. */ tree gfor_fndecl_random_init; /* libgfortran, 1 image only. */ +/* Deep copy helper for recursive allocatable array components. */ +tree gfor_fndecl_cfi_deep_copy_array; + static void gfc_add_decl_to_parent_function (tree decl) { @@ -1557,7 +1560,11 @@ add_attributes_to_decl (tree *decl_p, const gfc_symbol *sym) clauses = c; } - if (sym_attr.omp_device_type != OMP_DEVICE_TYPE_UNSET) + /* FIXME: 'declare_target_link' permits both any and host, but + will fail if one sets OMP_CLAUSE_DEVICE_TYPE_KIND. */ + if (sym_attr.omp_device_type != OMP_DEVICE_TYPE_UNSET + && !sym_attr.omp_declare_target_link + && !sym_attr.omp_declare_target_indirect /* implies 'any' */) { tree c = build_omp_clause (UNKNOWN_LOCATION, OMP_CLAUSE_DEVICE_TYPE); switch (sym_attr.omp_device_type) @@ -1578,6 +1585,26 @@ add_attributes_to_decl (tree *decl_p, const gfc_symbol *sym) clauses = c; } + /* Also check trans-common.cc when updating/removing the following; + also update f95.c's gfc_gnu_attributes. + For the warning, see also OpenMP spec issue 4663. */ + if (sym_attr.omp_groupprivate && sym_attr.threadprivate) + { + /* Unset this flag; implicit 'declare target local(...)' remains. */ + sym_attr.omp_groupprivate = 0; + gfc_warning (OPT_Wopenmp, + "Ignoring the %<groupprivate%> attribute for " + "%<threadprivate%> variable %qs declared at %L", + sym->name, &sym->declared_at); + } + if (sym_attr.omp_groupprivate) + gfc_error ("Sorry, OMP GROUPPRIVATE not implemented, " + "used by %qs declared at %L", sym->name, &sym->declared_at); + else if (sym_attr.omp_declare_target_local) + /* Use 'else if' as groupprivate implies 'local'. */ + gfc_error ("Sorry, OMP DECLARE TARGET with LOCAL clause not implemented, " + "used by %qs declared at %L", sym->name, &sym->declared_at); + bool has_declare = true; if (sym_attr.omp_declare_target_link || sym_attr.oacc_declare_link) @@ -3588,6 +3615,23 @@ gfc_build_intrinsic_function_decls (void) gfc_charlen_type_node, pchar1_type_node, gfc_charlen_type_node, gfc_logical4_type_node); + { + tree copy_helper_ptr_type; + tree copy_helper_fn_type; + + copy_helper_fn_type = build_function_type_list (void_type_node, + pvoid_type_node, + pvoid_type_node, + NULL_TREE); + copy_helper_ptr_type = build_pointer_type (copy_helper_fn_type); + + gfor_fndecl_cfi_deep_copy_array + = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX ("cfi_deep_copy_array")), ". R R . ", + void_type_node, 3, pvoid_type_node, pvoid_type_node, + copy_helper_ptr_type); + } + gfor_fndecl_adjustl = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("adjustl")), ". W . R ", void_type_node, 3, pchar1_type_node, gfc_charlen_type_node, @@ -4522,7 +4566,8 @@ gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body) and using trans_assignment to do the work. Set dealloc to false if no deallocation prior the assignment is needed. */ void -gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc) +gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc, + bool pdt_ok) { gfc_expr *e; tree tmp; @@ -4531,7 +4576,8 @@ gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc) gcc_assert (block); /* Initialization of PDTs is done elsewhere. */ - if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type) + if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type + && !pdt_ok) return; gcc_assert (!sym->attr.allocatable); @@ -4550,6 +4596,28 @@ gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc) } +/* Initialize a PDT, when all the components have an initializer. */ +static void +gfc_init_default_pdt (gfc_symbol *sym, stmtblock_t *block, bool dealloc) +{ + /* Allowed in the case where all the components have initializers and + there are no LEN components. */ + if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type) + { + gfc_component *c = sym->ts.u.derived->components; + if (!dealloc || !sym->value || sym->value->expr_type != EXPR_STRUCTURE) + return; + for (; c; c = c->next) + if (c->attr.pdt_len || !c->initializer) + return; + } + else + return; + gfc_init_default_dt (sym, block, dealloc, true); + return; +} + + /* Initialize INTENT(OUT) derived type dummies. As well as giving them their default initializer, if they have allocatable components, they have their allocatable components deallocated. */ @@ -4941,6 +5009,9 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) gfc_add_expr_to_block (&tmpblock, tmp); } + if (is_pdt_type) + gfc_init_default_pdt (sym, &tmpblock, true); + if (!sym->attr.result && !sym->ts.u.derived->attr.alloc_comp) tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived, sym->backend_decl, diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 2e88e65..ac85b76 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -6696,11 +6696,14 @@ conv_dummy_value (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym, argse.want_pointer = 1; gfc_conv_expr (&argse, e); cond = fold_convert (TREE_TYPE (argse.expr), null_pointer_node); - cond = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, argse.expr, cond); - vec_safe_push (optionalargs, - fold_convert (boolean_type_node, cond)); + if (e->symtree->n.sym->attr.dummy) + cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + logical_type_node, + gfc_conv_expr_present (e->symtree->n.sym), + cond); + vec_safe_push (optionalargs, fold_convert (boolean_type_node, cond)); /* Create "conditional temporary". */ conv_cond_temp (parmse, e, cond); } @@ -11697,7 +11700,17 @@ gfc_trans_scalar_assign (gfc_se *lse, gfc_se *rse, gfc_typespec ts, } gfc_add_block_to_block (&block, &rse->pre); - gfc_add_block_to_block (&block, &lse->finalblock); + + /* Skip finalization for self-assignment. */ + if (deep_copy && lse->finalblock.head) + { + tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location), + gfc_finish_block (&lse->finalblock)); + gfc_add_expr_to_block (&block, tmp); + } + else + gfc_add_block_to_block (&block, &lse->finalblock); + gfc_add_block_to_block (&block, &lse->pre); gfc_add_modify (&block, lse->expr, @@ -12683,12 +12696,30 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block, to make sure we do not check for reallocation unneccessarily. */ +/* Strip parentheses from an expression to get the underlying variable. + This is needed for self-assignment detection since (a) creates a + parentheses operator node. */ + +static gfc_expr * +strip_parentheses (gfc_expr *expr) +{ + while (expr->expr_type == EXPR_OP + && expr->value.op.op == INTRINSIC_PARENTHESES) + expr = expr->value.op.op1; + return expr; +} + + static bool is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2) { gfc_actual_arglist *a; gfc_expr *e1, *e2; + /* Strip parentheses to handle cases like a = (a). */ + expr1 = strip_parentheses (expr1); + expr2 = strip_parentheses (expr2); + switch (expr2->expr_type) { case EXPR_VARIABLE: @@ -13390,10 +13421,15 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, } /* Comply with F2018 (7.5.6.3). Make sure that any finalization code is added - after evaluation of the rhs and before reallocation. */ + after evaluation of the rhs and before reallocation. + Skip finalization for self-assignment to avoid use-after-free. + Strip parentheses from both sides to handle cases like a = (a). */ final_expr = gfc_assignment_finalizer_call (&lse, expr1, init_flag); - if (final_expr && !(expr2->expr_type == EXPR_VARIABLE - && expr2->symtree->n.sym->attr.artificial)) + if (final_expr + && gfc_dep_compare_expr (strip_parentheses (expr1), + strip_parentheses (expr2)) != 0 + && !(strip_parentheses (expr2)->expr_type == EXPR_VARIABLE + && strip_parentheses (expr2)->symtree->n.sym->attr.artificial)) { if (lss == gfc_ss_terminator) { @@ -13416,13 +13452,18 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, /* If nothing else works, do it the old fashioned way! */ if (tmp == NULL_TREE) - tmp - = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, - gfc_expr_is_variable (expr2) || scalar_to_array - || expr2->expr_type == EXPR_ARRAY, - !(l_is_temp || init_flag) && dealloc, - expr1->symtree->n.sym->attr.codimension, - assoc_assign); + { + /* Strip parentheses to detect cases like a = (a) which need deep_copy. */ + gfc_expr *expr2_stripped = strip_parentheses (expr2); + tmp + = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, + gfc_expr_is_variable (expr2_stripped) + || scalar_to_array + || expr2->expr_type == EXPR_ARRAY, + !(l_is_temp || init_flag) && dealloc, + expr1->symtree->n.sym->attr.codimension, + assoc_assign); + } /* Add the lse pre block to the body */ gfc_add_block_to_block (&body, &lse.pre); diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index 5b9111d3..91c0301 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -12559,11 +12559,23 @@ conv_intrinsic_atomic_op (gfc_code *code) else image_index = integer_zero_node; + /* Ensure VALUE names addressable storage: taking the address of a + constant is invalid in C, and scalars need a temporary as well. */ if (!POINTER_TYPE_P (TREE_TYPE (value))) { - tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (atom)), "value"); - gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), value)); - value = gfc_build_addr_expr (NULL_TREE, tmp); + tree elem + = fold_convert (TREE_TYPE (TREE_TYPE (atom)), value); + elem = gfc_trans_force_lval (&block, elem); + value = gfc_build_addr_expr (NULL_TREE, elem); + } + else if (TREE_CODE (value) == ADDR_EXPR + && TREE_CONSTANT (TREE_OPERAND (value, 0))) + { + tree elem + = fold_convert (TREE_TYPE (TREE_TYPE (atom)), + build_fold_indirect_ref (value)); + elem = gfc_trans_force_lval (&block, elem); + value = gfc_build_addr_expr (NULL_TREE, elem); } gfc_init_se (&argse, NULL); diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc index 69a70d7..8eb4fc4 100644 --- a/gcc/fortran/trans-openmp.cc +++ b/gcc/fortran/trans-openmp.cc @@ -4180,7 +4180,9 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, tree type = TREE_TYPE (decl); if (n->sym->ts.type == BT_CHARACTER && n->sym->ts.deferred - && n->sym->attr.omp_declare_target + && (n->sym->attr.omp_declare_target + || n->sym->attr.omp_declare_target_link + || n->sym->attr.omp_declare_target_local) && (always_modifier || n->sym->attr.pointer) && op != EXEC_OMP_TARGET_EXIT_DATA && n->u.map.op != OMP_MAP_DELETE @@ -5263,6 +5265,37 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, omp_clauses = gfc_trans_add_clause (c, omp_clauses); } + if (clauses->dyn_groupprivate) + { + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->dyn_groupprivate); + gfc_add_block_to_block (block, &se.pre); + tree expr = (CONSTANT_CLASS_P (se.expr) || DECL_P (se.expr) + ? se.expr : gfc_evaluate_now (se.expr, block)); + gfc_add_block_to_block (block, &se.post); + + enum omp_clause_fallback_kind kind = OMP_CLAUSE_FALLBACK_UNSPECIFIED; + switch (clauses->fallback) + { + case OMP_FALLBACK_ABORT: + kind = OMP_CLAUSE_FALLBACK_ABORT; + break; + case OMP_FALLBACK_DEFAULT_MEM: + kind = OMP_CLAUSE_FALLBACK_DEFAULT_MEM; + break; + case OMP_FALLBACK_NULL: + kind = OMP_CLAUSE_FALLBACK_NULL; + break; + case OMP_FALLBACK_NONE: + break; + } + c = build_omp_clause (gfc_get_location (&where), + OMP_CLAUSE_DYN_GROUPPRIVATE); + OMP_CLAUSE_DYN_GROUPPRIVATE_KIND (c) = kind; + OMP_CLAUSE_DYN_GROUPPRIVATE_EXPR (c) = expr; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + chunk_size = NULL_TREE; if (clauses->chunk_size) { diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 1d04b22..52cebf5 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -666,7 +666,8 @@ tree gfc_get_symbol_decl (gfc_symbol *); tree gfc_conv_initializer (gfc_expr *, gfc_typespec *, tree, bool, bool, bool); /* Assign a default initializer to a derived type. */ -void gfc_init_default_dt (gfc_symbol *, stmtblock_t *, bool); +void gfc_init_default_dt (gfc_symbol *, stmtblock_t *, bool, + bool pdt_ok = false); /* Substitute a temporary variable in place of the real one. */ void gfc_shadow_sym (gfc_symbol *, tree, gfc_saved_var *); @@ -1004,6 +1005,9 @@ extern GTY(()) tree gfor_fndecl_ieee_procedure_exit; extern GTY(()) tree gfor_fndecl_random_init; extern GTY(()) tree gfor_fndecl_caf_random_init; +/* Deep copy helper for recursive allocatable array components. */ +extern GTY(()) tree gfor_fndecl_cfi_deep_copy_array; + /* True if node is an integer constant. */ #define INTEGER_CST_P(node) (TREE_CODE(node) == INTEGER_CST) |