This is just a minor code-readability improvement: resolve_omp_clauses is very long and the allocate check is also not short, but completely self contained. Hence, it makes sense to move it out.
The change was motivated by the following commit to the OG13 branch, forward ported up to OG15: commit 9c46ffc29646d1c0b16446e8b7e8b294cae49792 OpenMP: Reprocess expanded clauses after 'declare mapper' instantiation That commit also moved this code to verify_omp_clauses_symbol_dups but it didn't quite fit there. Except for reindentation due to turn two if condition blocks intoearly returns, there should be no code changes. Committed as r17-1736-gaa4a1608ea2744 Tobias
commit aa4a1608ea2744108ec62e7baba99c7fa99800ad Author: Tobias Burnus <[email protected]> Date: Mon Jun 22 10:03:26 2026 +0200 Fortran/OpenMP: Split-off resolve_omp_allocate_clauses Move the code for ALLOCATE clause checking out of resolve_omp_clauses into a new function. Additionally, the all-enclosing if condition block is replaced by an early return; likewise, an inner if condition block that stretched to the end of the outer one is replaced by a second early return. Hence, a lot of code could be shifted 4 or 8 columns to the left. Except for the re-indentation, the early exit changes to the two if conditions and to two variable declarations, the code is identical. gcc/fortran/ChangeLog: * openmp.cc (resolve_omp_allocate_clauses): New function for resolving 'allocate' clauses, splitt-off from ... (resolve_omp_clauses): ... here. Call the new function. Suggested-by: Julian Brown <[email protected]> --- gcc/fortran/openmp.cc | 463 ++++++++++++++++++++++++++------------------------ 1 file changed, 237 insertions(+), 226 deletions(-) diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc index 526ad03c828..f3d21786932 100644 --- a/gcc/fortran/openmp.cc +++ b/gcc/fortran/openmp.cc @@ -9264,6 +9264,242 @@ gfc_resolve_omp_assumptions (gfc_omp_assumptions *assume) } +/* Resolve the OpenMP ALLOCATE clauses. */ + +static void +resolve_omp_allocate_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, + gfc_namespace *ns) +{ + gfc_omp_namelist *n; + enum gfc_omp_list_type list; + + if (!omp_clauses->lists[OMP_LIST_ALLOCATE]) + return; + for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) + { + if (n->u2.allocator + && (!gfc_resolve_expr (n->u2.allocator) + || n->u2.allocator->ts.type != BT_INTEGER + || n->u2.allocator->rank != 0 + || n->u2.allocator->ts.kind != gfc_c_intptr_kind)) + { + gfc_error ("Expected integer expression of the " + "%<omp_allocator_handle_kind%> kind at %L", + &n->u2.allocator->where); + break; + } + if (!n->u.align) + continue; + HOST_WIDE_INT alignment = 0; + if (!gfc_resolve_expr (n->u.align) + || n->u.align->ts.type != BT_INTEGER + || n->u.align->rank != 0 + || n->u.align->expr_type != EXPR_CONSTANT + || gfc_extract_hwi (n->u.align, &alignment) + || alignment <= 0 + || !pow2p_hwi (alignment)) + { + gfc_error ("ALIGN requires a scalar positive constant integer " + "alignment expression at %L that is a power of two", + &n->u.align->where); + break; + } + } + + /* Check for 2 things here. + 1. There is no duplication of variable in allocate clause. + 2. Variable in allocate clause are also present in some + privatization clase (non-composite case). */ + for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) + if (n->sym) + n->sym->mark = 0; + + gfc_omp_namelist *prev = NULL; + for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; ) + { + if (n->sym == NULL) + { + n = n->next; + continue; + } + if (n->sym->mark == 1) + { + gfc_warning (OPT_Wopenmp, "%qs appears more than once in " + "%<allocate%> at %L" , n->sym->name, &n->where); + /* We have already seen this variable so it is a duplicate. + Remove it. */ + if (prev != NULL && prev->next == n) + { + prev->next = n->next; + n->next = NULL; + gfc_free_omp_namelist (n, OMP_LIST_ALLOCATE); + n = prev->next; + } + continue; + } + n->sym->mark = 1; + prev = n; + n = n->next; + } + + /* Non-composite constructs. */ + if (code && code->op < EXEC_OMP_DO_SIMD) + { + for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM; + list = gfc_omp_list_type (list + 1)) + switch (list) + { + case OMP_LIST_PRIVATE: + case OMP_LIST_FIRSTPRIVATE: + case OMP_LIST_LASTPRIVATE: + case OMP_LIST_REDUCTION: + case OMP_LIST_REDUCTION_INSCAN: + case OMP_LIST_REDUCTION_TASK: + case OMP_LIST_IN_REDUCTION: + case OMP_LIST_TASK_REDUCTION: + case OMP_LIST_LINEAR: + for (n = omp_clauses->lists[list]; n; n = n->next) + n->sym->mark = 0; + break; + default: + break; + } + + for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) + if (n->sym->mark == 1) + gfc_error ("%qs specified in %<allocate%> clause at %L but not " + "in an explicit privatization clause", + n->sym->name, &n->where); + } + if (!(code + && (code->op == EXEC_OMP_ALLOCATORS || code->op == EXEC_OMP_ALLOCATE) + && code->block + && code->block->next + && code->block->next->op == EXEC_ALLOCATE)) + return; + + if (code->op == EXEC_OMP_ALLOCATE) + gfc_warning (OPT_Wdeprecated_openmp, + "The use of one or more %<allocate%> directives with " + "an associated %<allocate%> statement at %L is " + "deprecated since OpenMP 5.2, use an %<allocators%> " + "directive", &code->loc); + gfc_alloc *a; + gfc_omp_namelist *n_null = NULL; + bool missing_allocator = false; + gfc_symbol *missing_allocator_sym = NULL; + for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) + { + if (n->u2.allocator == NULL) + { + if (!missing_allocator_sym) + missing_allocator_sym = n->sym; + missing_allocator = true; + } + if (n->sym == NULL) + { + n_null = n; + continue; + } + if (n->sym->attr.codimension) + gfc_error ("Unexpected coarray %qs in %<allocate%> at %L", + n->sym->name, &n->where); + for (a = code->block->next->ext.alloc.list; a; a = a->next) + if (a->expr->expr_type == EXPR_VARIABLE + && a->expr->symtree->n.sym == n->sym) + { + gfc_ref *ref; + for (ref = a->expr->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + break; + if (ref == NULL) + break; + } + if (a == NULL) + gfc_error ("%qs specified in %<allocate%> at %L but not " + "in the associated ALLOCATE statement", + n->sym->name, &n->where); + } + /* If there is an ALLOCATE directive without list argument, a + namelist with its allocator/align clauses and n->sym = NULL is + created during parsing; here, we add all not otherwise specified + items from the Fortran allocate to that list. + For an ALLOCATORS directive, not listed items use the normal + Fortran way. + The behavior of an ALLOCATE directive that does not list all + arguments but there is no directive without list argument is not + well specified. Thus, we reject such code below. In OpenMP 5.2 + the executable ALLOCATE directive is deprecated and in 6.0 + deleted such that no spec clarification is to be expected. */ + for (a = code->block->next->ext.alloc.list; a; a = a->next) + if (a->expr->expr_type == EXPR_VARIABLE) + { + for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) + if (a->expr->symtree->n.sym == n->sym) + { + gfc_ref *ref; + for (ref = a->expr->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + break; + if (ref == NULL) + break; + } + if (n == NULL && n_null == NULL) + { + /* OK for ALLOCATORS but for ALLOCATE: Unspecified whether + that should use the default allocator of OpenMP or the + Fortran allocator. Thus, just reject it. */ + if (code->op == EXEC_OMP_ALLOCATE) + gfc_error ("%qs listed in %<allocate%> statement at %L " + "but it is neither explicitly in listed in " + "the %<!$OMP ALLOCATE%> directive nor exists" + " a directive without argument list", + a->expr->symtree->n.sym->name, + &a->expr->where); + break; + } + if (n == NULL) + { + if (a->expr->symtree->n.sym->attr.codimension) + gfc_error ("Unexpected coarray %qs in %<allocate%> at " + "%L, implicitly listed in %<!$OMP ALLOCATE%>" + " at %L", a->expr->symtree->n.sym->name, + &a->expr->where, &n_null->where); + break; + } + } + gfc_namespace *prog_unit = ns; + while (prog_unit->parent) + prog_unit = prog_unit->parent; + gfc_namespace *fn_ns = ns; + while (fn_ns) + { + if (ns->proc_name + && (ns->proc_name->attr.subroutine + || ns->proc_name->attr.function)) + break; + fn_ns = fn_ns->parent; + } + if (missing_allocator + && !(prog_unit->omp_requires & OMP_REQ_DYNAMIC_ALLOCATORS) + && ((fn_ns && fn_ns->proc_name->attr.omp_declare_target) + || omp_clauses->contained_in_target_construct)) + { + if (code->op == EXEC_OMP_ALLOCATORS) + gfc_error ("ALLOCATORS directive at %L inside a target region " + "must specify an ALLOCATOR modifier for %qs", + &code->loc, missing_allocator_sym->name); + else if (missing_allocator_sym) + gfc_error ("ALLOCATE directive at %L inside a target region " + "must specify an ALLOCATOR clause for %qs", + &code->loc, missing_allocator_sym->name); + else + gfc_error ("ALLOCATE directive at %L inside a target region " + "must specify an ALLOCATOR clause", &code->loc); + } +} + + /* OpenMP directive resolving routines. */ static void @@ -9815,232 +10051,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, n->sym->mark = 1; } - if (omp_clauses->lists[OMP_LIST_ALLOCATE]) - { - for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) - { - if (n->u2.allocator - && (!gfc_resolve_expr (n->u2.allocator) - || n->u2.allocator->ts.type != BT_INTEGER - || n->u2.allocator->rank != 0 - || n->u2.allocator->ts.kind != gfc_c_intptr_kind)) - { - gfc_error ("Expected integer expression of the " - "%<omp_allocator_handle_kind%> kind at %L", - &n->u2.allocator->where); - break; - } - if (!n->u.align) - continue; - HOST_WIDE_INT alignment = 0; - if (!gfc_resolve_expr (n->u.align) - || n->u.align->ts.type != BT_INTEGER - || n->u.align->rank != 0 - || n->u.align->expr_type != EXPR_CONSTANT - || gfc_extract_hwi (n->u.align, &alignment) - || alignment <= 0 - || !pow2p_hwi (alignment)) - { - gfc_error ("ALIGN requires a scalar positive constant integer " - "alignment expression at %L that is a power of two", - &n->u.align->where); - break; - } - } - - /* Check for 2 things here. - 1. There is no duplication of variable in allocate clause. - 2. Variable in allocate clause are also present in some - privatization clase (non-composite case). */ - for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) - if (n->sym) - n->sym->mark = 0; - - gfc_omp_namelist *prev = NULL; - for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; ) - { - if (n->sym == NULL) - { - n = n->next; - continue; - } - if (n->sym->mark == 1) - { - gfc_warning (OPT_Wopenmp, "%qs appears more than once in " - "%<allocate%> at %L" , n->sym->name, &n->where); - /* We have already seen this variable so it is a duplicate. - Remove it. */ - if (prev != NULL && prev->next == n) - { - prev->next = n->next; - n->next = NULL; - gfc_free_omp_namelist (n, OMP_LIST_ALLOCATE); - n = prev->next; - } - continue; - } - n->sym->mark = 1; - prev = n; - n = n->next; - } - - /* Non-composite constructs. */ - if (code && code->op < EXEC_OMP_DO_SIMD) - { - for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM; - list = gfc_omp_list_type (list + 1)) - switch (list) - { - case OMP_LIST_PRIVATE: - case OMP_LIST_FIRSTPRIVATE: - case OMP_LIST_LASTPRIVATE: - case OMP_LIST_REDUCTION: - case OMP_LIST_REDUCTION_INSCAN: - case OMP_LIST_REDUCTION_TASK: - case OMP_LIST_IN_REDUCTION: - case OMP_LIST_TASK_REDUCTION: - case OMP_LIST_LINEAR: - for (n = omp_clauses->lists[list]; n; n = n->next) - n->sym->mark = 0; - break; - default: - break; - } - - for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) - if (n->sym->mark == 1) - gfc_error ("%qs specified in %<allocate%> clause at %L but not " - "in an explicit privatization clause", - n->sym->name, &n->where); - } - if (code - && (code->op == EXEC_OMP_ALLOCATORS || code->op == EXEC_OMP_ALLOCATE) - && code->block - && code->block->next - && code->block->next->op == EXEC_ALLOCATE) - { - if (code->op == EXEC_OMP_ALLOCATE) - gfc_warning (OPT_Wdeprecated_openmp, - "The use of one or more %<allocate%> directives with " - "an associated %<allocate%> statement at %L is " - "deprecated since OpenMP 5.2, use an %<allocators%> " - "directive", &code->loc); - gfc_alloc *a; - gfc_omp_namelist *n_null = NULL; - bool missing_allocator = false; - gfc_symbol *missing_allocator_sym = NULL; - for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) - { - if (n->u2.allocator == NULL) - { - if (!missing_allocator_sym) - missing_allocator_sym = n->sym; - missing_allocator = true; - } - if (n->sym == NULL) - { - n_null = n; - continue; - } - if (n->sym->attr.codimension) - gfc_error ("Unexpected coarray %qs in %<allocate%> at %L", - n->sym->name, &n->where); - for (a = code->block->next->ext.alloc.list; a; a = a->next) - if (a->expr->expr_type == EXPR_VARIABLE - && a->expr->symtree->n.sym == n->sym) - { - gfc_ref *ref; - for (ref = a->expr->ref; ref; ref = ref->next) - if (ref->type == REF_COMPONENT) - break; - if (ref == NULL) - break; - } - if (a == NULL) - gfc_error ("%qs specified in %<allocate%> at %L but not " - "in the associated ALLOCATE statement", - n->sym->name, &n->where); - } - /* If there is an ALLOCATE directive without list argument, a - namelist with its allocator/align clauses and n->sym = NULL is - created during parsing; here, we add all not otherwise specified - items from the Fortran allocate to that list. - For an ALLOCATORS directive, not listed items use the normal - Fortran way. - The behavior of an ALLOCATE directive that does not list all - arguments but there is no directive without list argument is not - well specified. Thus, we reject such code below. In OpenMP 5.2 - the executable ALLOCATE directive is deprecated and in 6.0 - deleted such that no spec clarification is to be expected. */ - for (a = code->block->next->ext.alloc.list; a; a = a->next) - if (a->expr->expr_type == EXPR_VARIABLE) - { - for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) - if (a->expr->symtree->n.sym == n->sym) - { - gfc_ref *ref; - for (ref = a->expr->ref; ref; ref = ref->next) - if (ref->type == REF_COMPONENT) - break; - if (ref == NULL) - break; - } - if (n == NULL && n_null == NULL) - { - /* OK for ALLOCATORS but for ALLOCATE: Unspecified whether - that should use the default allocator of OpenMP or the - Fortran allocator. Thus, just reject it. */ - if (code->op == EXEC_OMP_ALLOCATE) - gfc_error ("%qs listed in %<allocate%> statement at %L " - "but it is neither explicitly in listed in " - "the %<!$OMP ALLOCATE%> directive nor exists" - " a directive without argument list", - a->expr->symtree->n.sym->name, - &a->expr->where); - break; - } - if (n == NULL) - { - if (a->expr->symtree->n.sym->attr.codimension) - gfc_error ("Unexpected coarray %qs in %<allocate%> at " - "%L, implicitly listed in %<!$OMP ALLOCATE%>" - " at %L", a->expr->symtree->n.sym->name, - &a->expr->where, &n_null->where); - break; - } - } - gfc_namespace *prog_unit = ns; - while (prog_unit->parent) - prog_unit = prog_unit->parent; - gfc_namespace *fn_ns = ns; - while (fn_ns) - { - if (ns->proc_name - && (ns->proc_name->attr.subroutine - || ns->proc_name->attr.function)) - break; - fn_ns = fn_ns->parent; - } - if (missing_allocator - && !(prog_unit->omp_requires & OMP_REQ_DYNAMIC_ALLOCATORS) - && ((fn_ns && fn_ns->proc_name->attr.omp_declare_target) - || omp_clauses->contained_in_target_construct)) - { - if (code->op == EXEC_OMP_ALLOCATORS) - gfc_error ("ALLOCATORS directive at %L inside a target region " - "must specify an ALLOCATOR modifier for %qs", - &code->loc, missing_allocator_sym->name); - else if (missing_allocator_sym) - gfc_error ("ALLOCATE directive at %L inside a target region " - "must specify an ALLOCATOR clause for %qs", - &code->loc, missing_allocator_sym->name); - else - gfc_error ("ALLOCATE directive at %L inside a target region " - "must specify an ALLOCATOR clause", &code->loc); - } - - } - } + resolve_omp_allocate_clauses (code, omp_clauses, ns); /* OpenACC reductions. */ if (openacc)
