if (n->expr)
{
fputs ("allocator(", dumpfile);
- show_expr (n->expr);
+ show_expr (n->u2.allocator);
fputc (')', dumpfile);
}
if (n->expr && n->u.align)
fputc (',', dumpfile);
if (n->u.align)
{
- fputs ("allocator(", dumpfile);
+ fputs ("align(", dumpfile);
show_expr (n->u.align);
fputc (')', dumpfile);
}
case EXEC_OACC_CACHE: name = "CACHE"; is_oacc = true; break;
case EXEC_OACC_ENTER_DATA: name = "ENTER DATA"; is_oacc = true; break;
case EXEC_OACC_EXIT_DATA: name = "EXIT DATA"; is_oacc = true; break;
+ case EXEC_OMP_ALLOCATE: name = "ALLOCATE"; break;
+ case EXEC_OMP_ALLOCATORS: name = "ALLOCATORS"; break;
case EXEC_OMP_ASSUME: name = "ASSUME"; break;
case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
case EXEC_OMP_BARRIER: name = "BARRIER"; break;
case EXEC_OACC_CACHE:
case EXEC_OACC_ENTER_DATA:
case EXEC_OACC_EXIT_DATA:
+ case EXEC_OMP_ALLOCATE:
+ case EXEC_OMP_ALLOCATORS:
case EXEC_OMP_ASSUME:
case EXEC_OMP_ATOMIC:
case EXEC_OMP_CANCEL:
ST_OMP_END_MASKED_TASKLOOP, ST_OMP_MASKED_TASKLOOP_SIMD,
ST_OMP_END_MASKED_TASKLOOP_SIMD, ST_OMP_SCOPE, ST_OMP_END_SCOPE,
ST_OMP_ERROR, ST_OMP_ASSUME, ST_OMP_END_ASSUME, ST_OMP_ASSUMES,
+ ST_OMP_ALLOCATE, ST_OMP_ALLOCATE_EXEC,
+ ST_OMP_ALLOCATORS, ST_OMP_END_ALLOCATORS,
/* Note: gfc_match_omp_nothing returns ST_NONE. */
ST_OMP_NOTHING, ST_NONE
};
{
struct gfc_omp_namelist_udr *udr;
gfc_namespace *ns;
+ gfc_expr *allocator;
} u2;
struct gfc_omp_namelist *next;
locus where;
/* Linked list of !$omp declare variant constructs. */
struct gfc_omp_declare_variant *omp_declare_variant;
- /* OpenMP assumptions. */
+ /* OpenMP assumptions and allocate for static/stack vars. */
struct gfc_omp_assumptions *omp_assumes;
+ struct gfc_omp_namelist *omp_allocate;
/* A hash set for the gfc expressions that have already
been finalized in this namespace. */
EXEC_OMP_TARGET_TEAMS_LOOP, EXEC_OMP_MASKED, EXEC_OMP_PARALLEL_MASKED,
EXEC_OMP_PARALLEL_MASKED_TASKLOOP, EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD,
EXEC_OMP_MASKED_TASKLOOP, EXEC_OMP_MASKED_TASKLOOP_SIMD, EXEC_OMP_SCOPE,
- EXEC_OMP_ERROR
+ EXEC_OMP_ERROR, EXEC_OMP_ALLOCATE, EXEC_OMP_ALLOCATORS
};
typedef struct gfc_code
void gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *);
void gfc_free_omp_udr (gfc_omp_udr *);
gfc_omp_udr *gfc_omp_udr_find (gfc_symtree *, gfc_typespec *);
+void gfc_resolve_omp_allocate (gfc_namespace *, gfc_omp_namelist *);
void gfc_resolve_omp_assumptions (gfc_omp_assumptions *);
void gfc_resolve_omp_directive (gfc_code *, gfc_namespace *);
void gfc_resolve_do_iterator (gfc_code *, gfc_symbol *, bool);
/* Free an OpenMP namelist structure. */
void
-gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns, bool free_align)
+gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns,
+ bool free_align_allocator)
{
gfc_omp_namelist *n;
for (; name; name = n)
{
gfc_free_expr (name->expr);
- if (free_align)
+ if (free_align_allocator)
gfc_free_expr (name->u.align);
if (free_ns)
gfc_free_namespace (name->u2.ns);
+ else if (free_align_allocator)
+ gfc_free_expr (name->u2.allocator);
else if (name->u2.udr)
{
if (name->u2.udr->combiner)
/* OpenMP directive matchers. */
match gfc_match_omp_eos_error (void);
+match gfc_match_omp_allocate (void);
+match gfc_match_omp_allocators (void);
match gfc_match_omp_assume (void);
match gfc_match_omp_assumes (void);
match gfc_match_omp_atomic (void);
and "nothing". */
static const struct gfc_omp_directive gfc_omp_directives[] = {
- /* {"allocate", GFC_OMP_DIR_DECLARATIVE, ST_OMP_ALLOCATE}, */
- /* {"allocators", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ALLOCATORS}, */
+ {"allocate", GFC_OMP_DIR_DECLARATIVE, ST_OMP_ALLOCATE},
+ {"allocators", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ALLOCATORS},
{"assumes", GFC_OMP_DIR_INFORMATIONAL, ST_OMP_ASSUMES},
{"assume", GFC_OMP_DIR_INFORMATIONAL, ST_OMP_ASSUME},
{"atomic", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ATOMIC},
gfc_omp_namelist ***headp = NULL,
bool allow_sections = false,
bool allow_derived = false,
- bool *has_all_memory = NULL)
+ bool *has_all_memory = NULL,
+ bool reject_common_vars = false)
{
gfc_omp_namelist *head, *tail, *p;
locus old_loc, cur_loc;
tail->sym = sym;
tail->expr = expr;
tail->where = cur_loc;
+ if (reject_common_vars && sym->attr.in_common)
+ {
+ gcc_assert (allow_common);
+ gfc_error ("%qs at %L is part of the common block %</%s/%> and "
+ "may only be specificed implicitly via the named "
+ "common block", sym->name, &cur_loc,
+ sym->common_head->name);
+ goto cleanup;
+ }
goto next_item;
case MATCH_NO:
break;
for (gfc_omp_namelist *n = *head; n; n = n->next)
{
- n->expr = (allocator) ? gfc_copy_expr (allocator) : NULL;
+ n->u2.allocator = ((allocator)
+ ? gfc_copy_expr (allocator) : NULL);
n->u.align = (align) ? gfc_copy_expr (align) : NULL;
}
gfc_free_expr (allocator);
(omp_mask (OMP_CLAUSE_AT) | OMP_CLAUSE_MESSAGE | OMP_CLAUSE_SEVERITY)
#define OMP_WORKSHARE_CLAUSES \
omp_mask (OMP_CLAUSE_NOWAIT)
+#define OMP_ALLOCATORS_CLAUSES \
+ omp_mask (OMP_CLAUSE_ALLOCATE)
static match
return MATCH_YES;
}
+/* Handles both declarative and (deprecated) executable ALLOCATE directive;
+ accepts optional list (for executable) and common blocks.
+ If no variables have been provided, the single omp namelist has sym == NULL.
+
+ Note that the executable ALLOCATE directive permits structure elements only
+ in OpenMP 5.0 and 5.1 but not longer in 5.2. See also the comment on the
+ 'omp allocators' directive below. The accidental change was reverted for
+ OpenMP TR12, permitting them again. See also gfc_match_omp_allocators.
+
+ Hence, structure elements are rejected for now, also to make resolving
+ OMP_LIST_ALLOCATE simpler (check for duplicates, same symbol in
+ Fortran allocate stmt). TODO: Permit structure elements. */
+
+match
+gfc_match_omp_allocate (void)
+{
+ match m;
+ bool first = true;
+ gfc_omp_namelist *vars = NULL;
+ gfc_expr *align = NULL;
+ gfc_expr *allocator = NULL;
+ locus loc = gfc_current_locus;
+
+ m = gfc_match_omp_variable_list (" (", &vars, true, NULL, NULL, true, true,
+ NULL, true);
+
+ if (m == MATCH_ERROR)
+ return m;
+
+ while (true)
+ {
+ gfc_gobble_whitespace ();
+ if (gfc_match_omp_eos () == MATCH_YES)
+ break;
+ if (!first)
+ gfc_match (", ");
+ first = false;
+ if ((m = gfc_match_dupl_check (!align, "align", true, &align))
+ != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ continue;
+ }
+ if ((m = gfc_match_dupl_check (!allocator, "allocator",
+ true, &allocator)) != MATCH_NO)
+ {
+ if (m == MATCH_ERROR)
+ goto error;
+ continue;
+ }
+ gfc_error ("Expected ALIGN or ALLOCATOR clause at %C");
+ return MATCH_ERROR;
+ }
+ for (gfc_omp_namelist *n = vars; n; n = n->next)
+ if (n->expr)
+ {
+ if ((n->expr->ref && n->expr->ref->type == REF_COMPONENT)
+ || (n->expr->ref->next && n->expr->ref->type == REF_COMPONENT))
+ gfc_error ("Sorry, structure-element list item at %L in ALLOCATE "
+ "directive is not yet supported", &n->expr->where);
+ else
+ gfc_error ("Unexpected expression as list item at %L in ALLOCATE "
+ "directive", &n->expr->where);
+
+ gfc_free_omp_namelist (vars, false, true);
+ goto error;
+ }
+
+ new_st.op = EXEC_OMP_ALLOCATE;
+ new_st.ext.omp_clauses = gfc_get_omp_clauses ();
+ if (vars == NULL)
+ {
+ vars = gfc_get_omp_namelist ();
+ vars->where = loc;
+ vars->u.align = align;
+ vars->u2.allocator = allocator;
+ new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = vars;
+ }
+ else
+ {
+ new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = vars;
+ for (; vars; vars = vars->next)
+ {
+ vars->u.align = (align) ? gfc_copy_expr (align) : NULL;
+ vars->u2.allocator = ((allocator) ? gfc_copy_expr (allocator) : NULL);
+ }
+ gfc_free_expr (allocator);
+ gfc_free_expr (align);
+ }
+ return MATCH_YES;
+
+error:
+ gfc_free_expr (align);
+ gfc_free_expr (allocator);
+ return MATCH_ERROR;
+}
+
+/* In line with OpenMP 5.2 derived-type components are rejected.
+ See also comment before gfc_match_omp_allocate. */
+
+match
+gfc_match_omp_allocators (void)
+{
+ return match_omp (EXEC_OMP_ALLOCATORS, OMP_ALLOCATORS_CLAUSES);
+}
+
match
gfc_match_omp_assume (void)
return copy;
}
+/* Assume that a constant expression in the range 1 (omp_default_mem_alloc)
+ to 8 (omp_thread_mem_alloc) range is fine. The original symbol name is
+ already lost during matching via gfc_match_expr. */
+bool
+is_predefined_allocator (gfc_expr *expr)
+{
+ return (gfc_resolve_expr (expr)
+ && expr->rank == 0
+ && expr->ts.type == BT_INTEGER
+ && expr->ts.kind == gfc_c_intptr_kind
+ && expr->expr_type == EXPR_CONSTANT
+ && mpz_sgn (expr->value.integer) > 0
+ && mpz_cmp_si (expr->value.integer, 8) <= 0);
+}
+
+/* Resolve declarative ALLOCATE statement. Note: Common block vars only appear
+ as /block/ not individual, which is ensured during parsing. */
+
+void
+gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list)
+{
+ for (gfc_omp_namelist *n = list; n; n = n->next)
+ n->sym->mark = 0;
+ for (gfc_omp_namelist *n = list; n; n = n->next)
+ {
+ if (n->sym->attr.flavor != FL_VARIABLE)
+ {
+ gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE "
+ "directive must be a variable", n->sym->name,
+ &n->where);
+ continue;
+ }
+ if (ns != n->sym->ns || n->sym->attr.use_assoc
+ || n->sym->attr.host_assoc || n->sym->attr.imported)
+ {
+ gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE shall be"
+ " in the same scope as the variable declaration",
+ n->sym->name, &n->where);
+ continue;
+ }
+ if (n->sym->attr.dummy)
+ {
+ gfc_error ("Unexpected dummy argument %qs as argument at %L to "
+ "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
+ continue;
+ }
+ if (n->sym->mark)
+ {
+ if (n->sym->attr.in_common)
+ {
+ gfc_error ("Duplicated common block %</%s/%> in !$OMP ALLOCATE "
+ "at %L", n->sym->common_head->name, &n->where);
+ while (n->next && n->next->sym
+ && n->sym->common_head == n->next->sym->common_head)
+ n = n->next;
+ }
+ else
+ gfc_error ("Duplicated variable %qs in !$OMP ALLOCATE at %L",
+ n->sym->name, &n->where);
+ continue;
+ }
+ n->sym->mark = 1;
+ if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok
+ && CLASS_DATA (n->sym)->attr.allocatable)
+ || (n->sym->ts.type != BT_CLASS && n->sym->attr.allocatable))
+ gfc_error ("Unexpected allocatable variable %qs at %L in declarative "
+ "!$OMP ALLOCATE directive", n->sym->name, &n->where);
+ else if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok
+ && CLASS_DATA (n->sym)->attr.class_pointer)
+ || (n->sym->ts.type != BT_CLASS && n->sym->attr.pointer))
+ gfc_error ("Unexpected pointer variable %qs at %L in declarative "
+ "!$OMP ALLOCATE directive", n->sym->name, &n->where);
+ HOST_WIDE_INT alignment = 0;
+ if (n->u.align
+ && (!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)
+ || !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);
+ while (n->sym->attr.in_common && n->next && n->next->sym
+ && n->sym->common_head == n->next->sym->common_head)
+ n = n->next;
+ continue;
+ }
+ 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)))
+ {
+ bool com = n->sym->attr.in_common;
+ if (!n->u2.allocator)
+ gfc_error ("An ALLOCATOR clause is required as the list item "
+ "%<%s%s%s%> at %L has the SAVE attribute", com ? "/" : "",
+ com ? n->sym->common_head->name : n->sym->name,
+ com ? "/" : "", &n->where);
+ else if (!is_predefined_allocator (n->u2.allocator))
+ gfc_error ("Predefined allocator required in ALLOCATOR clause at %L"
+ " as the list item %<%s%s%s%> at %L has the SAVE attribute",
+ &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;
+ }
+ else 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);
+ }
+ gfc_error ("Sorry, declarative !$OMP ALLOCATE at %L not yet supported",
+ &list->where);
+}
/* Resolve ASSUME's and ASSUMES' assumption clauses. Note that absent/contains
is handled during parse time in omp_verify_merge_absent_contains. */
{
for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
{
- if (n->expr && (!gfc_resolve_expr (n->expr)
- || n->expr->ts.type != BT_INTEGER
- || n->expr->ts.kind != gfc_c_intptr_kind))
+ 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->expr->where);
+ &n->u2.allocator->where);
break;
}
if (!n->u.align)
continue;
- int alignment = 0;
+ HOST_WIDE_INT alignment = 0;
if (!gfc_resolve_expr (n->u.align)
|| n->u.align->ts.type != BT_INTEGER
|| n->u.align->rank != 0
- || gfc_extract_int (n->u.align, &alignment)
+ || n->u.align->expr_type != EXPR_CONSTANT
+ || gfc_extract_hwi (n->u.align, &alignment)
|| alignment <= 0
|| !pow2p_hwi (alignment))
{
- gfc_error ("ALIGN modifier requires at %L a scalar positive "
- "constant integer alignment expression that is a "
- "power of two", &n->u.align->where);
+ gfc_error ("ALIGN requires a scalar positive constant integer "
+ "alignment expression at %L that is a power of two",
+ &n->u.align->where);
break;
}
}
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)
- n->sym->mark = 0;
+ if (n->sym)
+ n->sym->mark = 0;
gfc_omp_namelist *prev = NULL;
- for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n;)
+ for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; )
{
+ if (n->sym == NULL)
+ {
+ n = n->next;
+ continue;
+ }
if (n->sym->mark == 1)
{
gfc_warning (0, "%qs appears more than once in %<allocate%> "
- "clauses at %L" , n->sym->name, &n->where);
+ "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)
"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)
+ {
+ gfc_alloc *a;
+ for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
+ {
+ if (n->sym == NULL)
+ continue;
+ 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)
+ break;
+ if (a == NULL)
+ gfc_error ("%qs specified in %<allocate%> at %L but not "
+ "in the associated ALLOCATE statement",
+ n->sym->name, &n->where);
+ }
+ }
+
}
/* OpenACC reductions. */
n->sym->name, &n->where);
else if (n->expr)
{
- gfc_expr *expr = n->expr;
- int alignment = 0;
- if (!gfc_resolve_expr (expr)
- || expr->ts.type != BT_INTEGER
- || expr->rank != 0
- || gfc_extract_int (expr, &alignment)
- || alignment <= 0)
- gfc_error ("%qs in ALIGNED clause at %L requires a scalar "
- "positive constant integer alignment "
+ if (!gfc_resolve_expr (n->expr)
+ || n->expr->ts.type != BT_INTEGER
+ || n->expr->rank != 0
+ || n->expr->expr_type != EXPR_CONSTANT
+ || mpz_sgn (n->expr->value.integer) <= 0)
+ gfc_error ("%qs in ALIGNED clause at %L requires a scalar"
+ " positive constant integer alignment "
"expression", n->sym->name, &n->where);
}
}
default:
for (; n != NULL; n = n->next)
{
+ if (n->sym == NULL)
+ {
+ gcc_assert (code->op == EXEC_OMP_ALLOCATORS
+ || code->op == EXEC_OMP_ALLOCATE);
+ continue;
+ }
bool bad = false;
bool is_reduction = (list == OMP_LIST_REDUCTION
|| list == OMP_LIST_REDUCTION_INSCAN
return ST_OMP_DO;
case EXEC_OMP_LOOP:
return ST_OMP_LOOP;
+ case EXEC_OMP_ALLOCATE:
+ return ST_OMP_ALLOCATE_EXEC;
+ case EXEC_OMP_ALLOCATORS:
+ return ST_OMP_ALLOCATORS;
case EXEC_OMP_ASSUME:
return ST_OMP_ASSUME;
case EXEC_OMP_ATOMIC:
case EXEC_OMP_TEAMS_LOOP:
resolve_omp_do (code);
break;
+ case EXEC_OMP_ALLOCATE:
+ case EXEC_OMP_ALLOCATORS:
case EXEC_OMP_ASSUME:
case EXEC_OMP_CANCEL:
case EXEC_OMP_ERROR:
gfc_state_data *gfc_state_stack;
static bool last_was_use_stmt = false;
+bool in_exec_part;
/* TODO: Re-order functions to kill these forward decls. */
static void check_statement_label (gfc_statement);
return ST_GET_FCN_CHARACTERISTICS;
}
+/* Checks for the ST_OMP_ALLOCATE. First, check whether all list items
+ are allocatables/pointers - and if so, assume it is associated with a Fortran
+ ALLOCATE stmt. If not, do some initial parsing-related checks and append
+ namelist to namespace.
+ The check follows OpenMP 5.1 by requiring an executable stmt or OpenMP
+ construct before a directive associated with an allocate statement
+ (-> ST_OMP_ALLOCATE_EXEC); instead of showing an error, conversion of
+ ST_OMP_ALLOCATE -> ST_OMP_ALLOCATE_EXEC would be an alternative. */
+
+bool
+check_omp_allocate_stmt (locus *loc)
+{
+ gfc_omp_namelist *n;
+
+ if (new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->sym == NULL)
+ {
+ gfc_error ("%qs directive at %L must either have a variable argument or, "
+ "if associated with an ALLOCATE stmt, must be preceded by an "
+ "executable statement or OpenMP construct",
+ gfc_ascii_statement (ST_OMP_ALLOCATE), loc);
+ return false;
+ }
+ bool has_allocatable = false;
+ bool has_non_allocatable = false;
+ for (n = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
+ {
+ if (n->expr)
+ {
+ gfc_error ("Structure-component expression at %L in %qs directive not"
+ " permitted in declarative directive; as directive "
+ "associated with an ALLOCATE stmt it must be preceded by "
+ "an executable statement or OpenMP construct",
+ &n->expr->where, gfc_ascii_statement (ST_OMP_ALLOCATE));
+ return false;
+ }
+ bool alloc_ptr;
+ if (n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok)
+ alloc_ptr = (CLASS_DATA (n->sym)->attr.allocatable
+ || CLASS_DATA (n->sym)->attr.class_pointer);
+ else
+ alloc_ptr = (n->sym->attr.allocatable || n->sym->attr.pointer
+ || n->sym->attr.proc_pointer);
+ if (alloc_ptr
+ || (n->sym->ns && n->sym->ns->proc_name
+ && (n->sym->ns->proc_name->attr.allocatable
+ || n->sym->ns->proc_name->attr.pointer
+ || n->sym->ns->proc_name->attr.proc_pointer)))
+ has_allocatable = true;
+ else
+ has_non_allocatable = true;
+ }
+ /* All allocatables - assume it is allocated with an ALLOCATE stmt. */
+ if (has_allocatable && !has_non_allocatable)
+ {
+ gfc_error ("%qs directive at %L associated with an ALLOCATE stmt must be "
+ "preceded by an executable statement or OpenMP construct; "
+ "note the variables in the list all have the allocatable or "
+ "pointer attribute", gfc_ascii_statement (ST_OMP_ALLOCATE),
+ loc);
+ return false;
+ }
+ if (!gfc_current_ns->omp_allocate)
+ gfc_current_ns->omp_allocate
+ = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE];
+ else
+ {
+ for (n = gfc_current_ns->omp_allocate; n->next; n = n->next)
+ ;
+ n->next = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE];
+ }
+ new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = NULL;
+ gfc_free_omp_clauses (new_st.ext.omp_clauses);
+ return true;
+}
+
+
/* Like match, but set a flag simd_matched if keyword matched
and if spec_only, goto do_spec_only without actually matching. */
#define matchs(keyword, subr, st) \
switch (c)
{
case 'a':
+ if (in_exec_part)
+ matcho ("allocate", gfc_match_omp_allocate, ST_OMP_ALLOCATE_EXEC);
+ else
+ matcho ("allocate", gfc_match_omp_allocate, ST_OMP_ALLOCATE);
+ matcho ("allocators", gfc_match_omp_allocators, ST_OMP_ALLOCATORS);
/* For -fopenmp-simd, ignore 'assumes'; note no clause starts with 's'. */
if (!flag_openmp && gfc_match ("assumes") == MATCH_YES)
break;
break;
case 'e':
matcho ("error", gfc_match_omp_error, ST_OMP_ERROR);
+ matcho ("end allocators", gfc_match_omp_eos_error, ST_OMP_END_ALLOCATORS);
matchs ("end assume", gfc_match_omp_eos_error, ST_OMP_END_ASSUME);
matcho ("end atomic", gfc_match_omp_eos_error, ST_OMP_END_ATOMIC);
matcho ("end critical", gfc_match_omp_end_critical, ST_OMP_END_CRITICAL);
return ST_NONE;
}
}
+ if (ret == ST_OMP_ALLOCATE && !check_omp_allocate_stmt (&old_locus))
+ goto error_handling;
+
switch (ret)
{
/* Set omp_target_seen; exclude ST_OMP_DECLARE_TARGET.
case ST_OMP_TARGET_SIMD: case ST_OMP_TASKLOOP: case ST_OMP_TASKLOOP_SIMD: \
case ST_OMP_LOOP: case ST_OMP_PARALLEL_LOOP: case ST_OMP_TEAMS_LOOP: \
case ST_OMP_TARGET_PARALLEL_LOOP: case ST_OMP_TARGET_TEAMS_LOOP: \
- case ST_OMP_ASSUME: \
+ case ST_OMP_ALLOCATE_EXEC: case ST_OMP_ALLOCATORS: case ST_OMP_ASSUME: \
case ST_CRITICAL: \
case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \
case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: \
#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_ASSUMES: \
+ 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
/* Block end statements. Errors associated with interchanging these
case ST_OACC_END_ATOMIC:
p = "!$ACC END ATOMIC";
break;
+ case ST_OMP_ALLOCATE:
+ case ST_OMP_ALLOCATE_EXEC:
+ p = "!$OMP ALLOCATE";
+ break;
+ case ST_OMP_ALLOCATORS:
+ p = "!$OMP ALLOCATORS";
+ break;
case ST_OMP_ASSUME:
p = "!$OMP ASSUME";
break;
case ST_OMP_DO_SIMD:
p = "!$OMP DO SIMD";
break;
+ case ST_OMP_END_ALLOCATORS:
+ p = "!$OMP END ALLOCATORS";
+ break;
case ST_OMP_END_ASSUME:
p = "!$OMP END ASSUME";
break;
{
case ST_NONE:
p->state = ORDER_START;
+ in_exec_part = false;
break;
case ST_USE:
case_exec_markers:
if (p->state < ORDER_EXEC)
p->state = ORDER_EXEC;
+ in_exec_part = true;
break;
default:
}
+/* Parse an OpenMP allocate block, including optional ALLOCATORS
+ end directive. */
+
+static gfc_statement
+parse_openmp_allocate_block (gfc_statement omp_st)
+{
+ gfc_statement st;
+ gfc_code *cp, *np;
+ gfc_state_data s;
+ bool empty_list = false;
+ locus empty_list_loc;
+ gfc_omp_namelist *n_first = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE];
+
+ if (omp_st == ST_OMP_ALLOCATE_EXEC
+ && new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->sym == NULL)
+ {
+ empty_list = true;
+ empty_list_loc = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->where;
+ }
+
+ accept_statement (omp_st);
+
+ cp = gfc_state_stack->tail;
+ push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
+ np = new_level (cp);
+ np->op = cp->op;
+ np->block = NULL;
+
+ st = next_statement ();
+ while (omp_st == ST_OMP_ALLOCATE_EXEC && st == ST_OMP_ALLOCATE_EXEC)
+ {
+ if (empty_list && !new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->sym)
+ {
+ locus *loc = &new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->where;
+ gfc_error_now ("%s statements at %L and %L have both no list item but"
+ " only one may", gfc_ascii_statement (st),
+ &empty_list_loc, loc);
+ empty_list = false;
+ }
+ if (!new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->sym)
+ {
+ empty_list = true;
+ empty_list_loc = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->where;
+ }
+ for ( ; n_first->next; n_first = n_first->next)
+ ;
+ n_first->next = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE];
+ new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = NULL;
+ gfc_free_omp_clauses (new_st.ext.omp_clauses);
+
+ accept_statement (ST_NONE);
+ st = next_statement ();
+ }
+ if (st != ST_ALLOCATE && omp_st == ST_OMP_ALLOCATE_EXEC)
+ gfc_error_now ("Unexpected %s at %C; expected ALLOCATE or %s statement",
+ gfc_ascii_statement (st), gfc_ascii_statement (omp_st));
+ else if (st != ST_ALLOCATE)
+ gfc_error_now ("Unexpected %s at %C; expected ALLOCATE statement after %s",
+ gfc_ascii_statement (st), gfc_ascii_statement (omp_st));
+ accept_statement (st);
+ pop_state ();
+ st = next_statement ();
+ if (omp_st == ST_OMP_ALLOCATORS && st == ST_OMP_END_ALLOCATORS)
+ {
+ accept_statement (st);
+ st = next_statement ();
+ }
+ return st;
+}
+
+
/* Parse the statements of an OpenMP structured block. */
static gfc_statement
parse_forall_block ();
break;
+ case ST_OMP_ALLOCATE_EXEC:
+ case ST_OMP_ALLOCATORS:
+ st = parse_openmp_allocate_block (st);
+ continue;
+
case ST_OMP_ASSUME:
case ST_OMP_PARALLEL:
case ST_OMP_PARALLEL_MASKED:
parse_executable (gfc_statement st)
{
int close_flag;
+ in_exec_part = true;
if (st == ST_NONE)
st = next_statement ();
parse_oacc_structured_block (st);
break;
+ case ST_OMP_ALLOCATE_EXEC:
+ case ST_OMP_ALLOCATORS:
+ st = parse_openmp_allocate_block (st);
+ continue;
+
case ST_OMP_ASSUME:
case ST_OMP_PARALLEL:
case ST_OMP_PARALLEL_MASKED:
case EXEC_OACC_ENTER_DATA:
case EXEC_OACC_EXIT_DATA:
case EXEC_OACC_ROUTINE:
+ case EXEC_OMP_ALLOCATE:
+ case EXEC_OMP_ALLOCATORS:
case EXEC_OMP_ASSUME:
case EXEC_OMP_CRITICAL:
case EXEC_OMP_DISTRIBUTE:
gfc_resolve_oacc_directive (code, ns);
break;
+ case EXEC_OMP_ALLOCATE:
+ case EXEC_OMP_ALLOCATORS:
case EXEC_OMP_ASSUME:
case EXEC_OMP_ATOMIC:
case EXEC_OMP_BARRIER:
gfc_resolve_oacc_declare (ns);
gfc_resolve_oacc_routines (ns);
gfc_resolve_omp_local_vars (ns);
+ if (ns->omp_allocate)
+ gfc_resolve_omp_allocate (ns, ns->omp_allocate);
gfc_resolve_code (ns->code, ns);
bitmap_obstack_release (&labels_obstack);
case EXEC_OACC_ENTER_DATA:
case EXEC_OACC_EXIT_DATA:
case EXEC_OACC_ROUTINE:
+ case EXEC_OMP_ALLOCATE:
+ case EXEC_OMP_ALLOCATORS:
case EXEC_OMP_ASSUME:
case EXEC_OMP_ATOMIC:
case EXEC_OMP_CANCEL:
tree node = build_omp_clause (input_location,
OMP_CLAUSE_ALLOCATE);
OMP_CLAUSE_DECL (node) = t;
- if (n->expr)
+ if (n->u2.allocator)
{
tree allocator_;
gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, n->expr);
+ gfc_conv_expr (&se, n->u2.allocator);
allocator_ = gfc_evaluate_now (se.expr, block);
OMP_CLAUSE_ALLOCATE_ALLOCATOR (node) = allocator_;
}
p = gfc_get_omp_namelist ();
p->sym = alloc_nl->sym;
p->expr = alloc_nl->expr;
+ p->u.align = alloc_nl->u.align;
+ p->u2.allocator = alloc_nl->u2.allocator;
p->where = alloc_nl->where;
if (clausesa[i].lists[OMP_LIST_ALLOCATE] == NULL)
{
{
switch (code->op)
{
+ case EXEC_OMP_ALLOCATE:
+ case EXEC_OMP_ALLOCATORS:
+ sorry ("%<!$OMP %s%> not yet supported",
+ code->op == EXEC_OMP_ALLOCATE ? "ALLOCATE" : "ALLOCATORS");
+ return NULL_TREE;
case EXEC_OMP_ASSUME:
return gfc_trans_omp_assume (code);
case EXEC_OMP_ATOMIC:
res = gfc_trans_dt_end (code);
break;
+ case EXEC_OMP_ALLOCATE:
+ case EXEC_OMP_ALLOCATORS:
case EXEC_OMP_ASSUME:
case EXEC_OMP_ATOMIC:
case EXEC_OMP_BARRIER:
x=3
!$omp end parallel
- !$omp parallel private (x) allocate (x) allocate (x) ! { dg-warning "'x' appears more than once in 'allocate' clauses at .1." }
+ !$omp parallel private (x) allocate (x) allocate (x) ! { dg-warning "'x' appears more than once in 'allocate' at .1." }
x=4
!$omp end parallel
- !$omp parallel private (x) allocate (x, x) ! { dg-warning "'x' appears more than once in 'allocate' clauses at .1." }
+ !$omp parallel private (x) allocate (x, x) ! { dg-warning "'x' appears more than once in 'allocate' at .1." }
x=5
!$omp end parallel
--- /dev/null
+module my_omp_lib
+ use iso_c_binding, only: c_intptr_t
+ !use omp_lib
+ implicit none
+ integer, parameter :: omp_allocator_handle_kind = c_intptr_t
+
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_null_allocator = 0
+
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_default_mem_alloc = 1
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_large_cap_mem_alloc = 2
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_const_mem_alloc = 3
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_high_bw_mem_alloc = 4
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_low_lat_mem_alloc = 5
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_cgroup_mem_alloc = 6
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_pteam_mem_alloc = 7
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_thread_mem_alloc = 8
+end module my_omp_lib
+
+subroutine one(n, my_alloc)
+ use my_omp_lib
+ implicit none
+integer :: n
+integer(kind=omp_allocator_handle_kind), intent(in) :: my_alloc
+
+!stack variables:
+integer :: a,b,c(n),d(5),e(2)
+!$omp allocate(a) ! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" }
+!$omp allocate ( b , c ) align ( 32) allocator (my_alloc)
+!$omp allocate (d) align( 128 )
+!$omp allocate( e ) allocator( omp_high_bw_mem_alloc )
+
+!saved vars
+integer, save :: k,l,m(5),r(2)
+!$omp allocate(k) align(16) , allocator (omp_large_cap_mem_alloc)
+!$omp allocate ( l ) allocator (omp_large_cap_mem_alloc) , align ( 32)
+!$omp allocate (m) align( 128 ),allocator( omp_high_bw_mem_alloc )
+!$omp allocate( r ) allocator( omp_high_bw_mem_alloc )
+
+!common /block/
+integer :: q,x,y(2),z(5)
+common /com1/ q,x
+common /com2/ y,z
+!$omp allocate ( / com1/) align( 128 ) allocator( omp_high_bw_mem_alloc )
+!$omp allocate(/com2 / ) allocator( omp_high_bw_mem_alloc )
+end
--- /dev/null
+module my_omp_lib
+ use iso_c_binding, only: c_intptr_t
+ !use omp_lib
+ implicit none
+ integer, parameter :: omp_allocator_handle_kind = c_intptr_t
+
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_null_allocator = 0
+
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_default_mem_alloc = 1
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_large_cap_mem_alloc = 2
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_const_mem_alloc = 3
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_high_bw_mem_alloc = 4
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_low_lat_mem_alloc = 5
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_cgroup_mem_alloc = 6
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_pteam_mem_alloc = 7
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_thread_mem_alloc = 8
+ type t
+ integer :: a
+ end type t
+end module my_omp_lib
+
+subroutine zero()
+ !$omp assumes absent (allocators)
+
+ !$omp assume absent (allocators)
+ !$omp end assume
+end
+
+subroutine two(c,x2,y2)
+ use my_omp_lib
+ implicit none
+ integer, allocatable :: a, b(:), c(:,:)
+ type(t), allocatable :: x1
+ type(t), pointer :: x2(:)
+ class(t), allocatable :: y1
+ class(t), pointer :: y2(:)
+
+ !$omp flush ! some executable statement
+ !$omp allocate(a) ! { dg-message "not yet supported" }
+ allocate(a,b(4),c(3,4))
+ deallocate(a,b,c)
+
+ !$omp allocate(x1,y1,x2,y2) ! { dg-message "not yet supported" }
+ allocate(x1,y1,x2(5),y2(5))
+ deallocate(x1,y1,x2,y2)
+
+ !$omp allocate(b,a) align ( 128 ) ! { dg-message "not yet supported" }
+ !$omp allocate align ( 64 )
+ allocate(a,b(4),c(3,4))
+ deallocate(a,b,c)
+end
+
+subroutine three(c)
+ use my_omp_lib
+ implicit none
+ integer :: q
+ integer, allocatable :: a, b(:), c(:,:)
+
+ call foo() ! executable stmt
+ !$omp allocate allocator( omp_large_cap_mem_alloc ) , align(64) ! { dg-message "not yet supported" }
+ !$omp allocate(b) allocator( omp_high_bw_mem_alloc )
+ !$omp allocate(c) allocator( omp_high_bw_mem_alloc )
+ allocate(a,b(4),c(3,4))
+ deallocate(a,b,c)
+
+ block
+ q = 5 ! executable stmt
+ !$omp allocate(a) align(64) ! { dg-message "not yet supported" }
+ !$omp allocate(b) allocator( omp_high_bw_mem_alloc ), align(32)
+ !$omp allocate(c) allocator( omp_thread_mem_alloc )
+ allocate(a,b(4),c(3,4))
+ deallocate(a,b,c)
+ end block
+ call inner
+contains
+ subroutine inner
+ call foo() ! executable stmt
+ !$omp allocate(a) align(64) ! { dg-message "not yet supported" }
+ !$omp allocate(b) allocator( omp_high_bw_mem_alloc ), align(32)
+ !$omp allocate(c) allocator( omp_thread_mem_alloc )
+ allocate(a,b(4),c(3,4))
+ deallocate(a,b,c)
+ end subroutine inner
+end
--- /dev/null
+module my_omp_lib
+ use iso_c_binding, only: c_intptr_t
+ !use omp_lib
+ implicit none
+ integer, parameter :: omp_allocator_handle_kind = c_intptr_t
+
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_null_allocator = 0
+
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_default_mem_alloc = 1
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_large_cap_mem_alloc = 2
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_const_mem_alloc = 3
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_high_bw_mem_alloc = 4
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_low_lat_mem_alloc = 5
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_cgroup_mem_alloc = 6
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_pteam_mem_alloc = 7
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_thread_mem_alloc = 8
+ type t
+ integer,allocatable :: a
+ integer,pointer :: b(:,:)
+ end type t
+end module my_omp_lib
+
+subroutine zero()
+ !$omp assumes absent (allocate) ! { dg-error "Invalid 'ALLOCATE' directive at .1. in ABSENT clause: declarative, informational and meta directives not permitted" }
+
+ !$omp assume absent (allocate) ! { dg-error "Invalid 'ALLOCATE' directive at .1. in ABSENT clause: declarative, informational and meta directives not permitted" }
+ !!$omp end assume
+end
+
+subroutine alloc(c,x2,y2)
+ use my_omp_lib
+ implicit none
+ integer, allocatable :: a, b(:), c(:,:)
+ type(t) :: x1,x2
+ class(t) :: y1,y2
+ allocatable :: x1, y1
+
+ !$omp flush ! some executable statement
+
+ !$omp allocate(x2%a,x2%b,y2%a,y2%b) allocator(omp_pteam_mem_alloc) align(64) ! { dg-error "Sorry, structure-element list item at .1. in ALLOCATE directive is not yet supported" }
+ allocate(x2%a,x2%b(3,4),y2%a,y2%b(3,4))
+
+ !$omp allocate(b(3)) align ( 64 ) ! { dg-error "Unexpected expression as list item at .1. in ALLOCATE directive" }
+ allocate(b(3))
+end
+
+subroutine one(n, my_alloc)
+ use my_omp_lib
+ implicit none
+integer :: n
+integer(kind=omp_allocator_handle_kind), intent(in) :: my_alloc
+
+integer :: a,b,c(n),d(5),e(2)
+integer, save :: k,l,m(5),r(2)
+integer :: q,x,y(2),z(5)
+common /com1/ q,x
+common /com2/ y,z
+integer, allocatable :: alloc
+integer, pointer :: ptr
+
+!$omp allocate(q) ! { dg-error "'q' at .1. is part of the common block '/com1/' and may only be specificed implicitly via the named common block" }
+
+!$omp allocate(d(:)) ! { dg-error "Unexpected expression as list item at .1. in ALLOCATE directive" }
+!$omp allocate(a) align(4), align(4) ! { dg-error "Duplicated 'align' clause" }
+!$omp allocate( e ) allocator( omp_high_bw_mem_alloc ), align(32),allocator( omp_high_bw_mem_alloc ) ! { dg-error "Duplicated 'allocator' clause" }
+
+!$omp allocate align(32) ! { dg-error "'!.OMP ALLOCATE' directive at .1. must either have a variable argument or, if associated with an ALLOCATE stmt, must be preceded by an executable statement or OpenMP construct" }
+
+!$omp allocate(alloc) align(128) ! { dg-error "'!.OMP ALLOCATE' directive at .1. associated with an ALLOCATE stmt must be preceded by an executable statement or OpenMP construct; note the variables in the list all have the allocatable or pointer attribute" }
+!$omp allocate(ptr) align(128) ! { dg-error "'!.OMP ALLOCATE' directive at .1. associated with an ALLOCATE stmt must be preceded by an executable statement or OpenMP construct; note the variables in the list all have the allocatable or pointer attribute" }
+
+!$omp allocate(e) allocate(omp_thread_mem_alloc) ! { dg-error "Expected ALIGN or ALLOCATOR clause" }
+end
+
+subroutine two()
+ integer, allocatable :: a,b,c
+
+ call foo()
+ !$omp allocate(a)
+ a = 5 ! { dg-error "Unexpected assignment at .1.; expected ALLOCATE or !.OMP ALLOCATE statement" }
+
+ !$omp allocate ! { dg-error "!.OMP ALLOCATE statements at .1. and .2. have both no list item but only one may" }
+ !$omp allocate(b)
+ !$omp allocate ! { dg-error "!.OMP ALLOCATE statements at .1. and .2. have both no list item but only one may" }
+ allocate(a,b,c)
+
+ !$omp allocate
+ allocate(a,b,c) ! allocate is no block construct, hence:
+ !$omp end allocate ! { dg-error "Unclassifiable OpenMP directive" }
+
+ !$omp allocators allocate(align(64) : a, b)
+ !$omp allocators allocate(align(128) : c) ! { dg-error "Unexpected !.OMP ALLOCATORS at .1.; expected ALLOCATE statement after !.OMP ALLOCATORS" }
+ allocate(a,b,c)
+end
--- /dev/null
+! { dg-additional-options "-fmax-errors=1000" }
+module my_omp_lib
+ use iso_c_binding, only: c_intptr_t
+ !use omp_lib
+ implicit none
+ integer, parameter :: omp_allocator_handle_kind = c_intptr_t
+
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_null_allocator = 0
+
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_default_mem_alloc = 1
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_large_cap_mem_alloc = 2
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_const_mem_alloc = 3
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_high_bw_mem_alloc = 4
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_low_lat_mem_alloc = 5
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_cgroup_mem_alloc = 6
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_pteam_mem_alloc = 7
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_thread_mem_alloc = 8
+ type t
+ integer,allocatable :: a
+ integer,pointer :: b(:,:)
+ end type t
+ integer :: used
+end module my_omp_lib
+
+subroutine one(n, my_alloc)
+ use my_omp_lib
+ implicit none
+integer :: n
+integer(kind=omp_allocator_handle_kind), intent(in) :: my_alloc
+
+integer :: a,b,c(n),d(5),e(2)
+integer, save :: k,l,m(5),r(2)
+integer :: q,x,y(2),z(5)
+common /com1/ q,x
+common /com2/ y,z
+integer, allocatable :: alloc
+integer, pointer :: ptr
+integer, parameter :: prm=5
+
+!$omp allocate(prm) align(64) ! { dg-error "Argument 'prm' at .1. to declarative !.OMP ALLOCATE directive must be a variable" }
+! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
+
+!$omp allocate(used) allocator(omp_pteam_mem_alloc) ! { dg-error "Argument 'used' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" }
+!$omp allocate(n) allocator(omp_pteam_mem_alloc) ! { dg-error "Unexpected dummy argument 'n' as argument at .1. to declarative !.OMP ALLOCATE" }
+
+!$omp allocate (x) align(128) ! { dg-error "'x' at .1. is part of the common block '/com1/' and may only be specificed implicitly via the named common block" }
+
+!$omp allocate (a, b, a) allocator (omp_pteam_mem_alloc) ! { dg-error "Duplicated variable 'a' in !.OMP ALLOCATE" }
+contains
+
+ subroutine inner
+ !$omp allocate(a) allocator(omp_pteam_mem_alloc) ! { dg-error "Argument 'a' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" }
+! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
+ end
+end
+
+subroutine three(n)
+ use my_omp_lib
+ implicit none
+integer,value :: n
+integer :: a,b,c(n),d(5),e(2)
+integer, save :: k,l,m(5)
+integer :: q,x,y(2),z(5),r
+common /com4/ y,z
+allocatable :: q
+pointer :: b
+!$omp allocate (c, d) allocator (omp_pteam_mem_alloc)
+! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
+!$omp allocate (/com4/) allocator (omp_pteam_mem_alloc)
+!$omp allocate (c) allocator (omp_pteam_mem_alloc) ! { dg-error "Duplicated variable 'c' in !.OMP ALLOCATE" }
+!$omp allocate (/com4/) allocator (omp_pteam_mem_alloc) ! { dg-error "Duplicated common block '/com4/' in !.OMP ALLOCATE" }
+
+!$omp allocate(q,x) ! { dg-error "Unexpected allocatable variable 'q' at .1. in declarative !.OMP ALLOCATE directive" }
+!$omp allocate(b,e) ! { dg-error "Unexpected pointer variable 'b' at .1. in declarative !.OMP ALLOCATE directive" }
+end
+
+subroutine four(n)
+ integer :: qq, rr, ss, tt, uu, vv,n
+!$omp allocate (qq) align(3+n) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
+! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
+!$omp allocate (rr) align([4]) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
+!$omp allocate (ss) align([4]) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
+!$omp allocate (tt) align(32.0) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
+!$omp allocate (uu) align(31) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
+end
+
+subroutine five(n,my_alloc)
+ use my_omp_lib
+ implicit none
+ integer :: qq, rr, ss, tt, uu, vv,n
+ integer(omp_allocator_handle_kind) :: my_alloc
+!$omp allocate (qq) allocator(3.0) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" }
+! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
+!$omp allocate (rr) allocator(3_2) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" }
+!$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" }
+!$omp allocate (tt) allocator(my_alloc) ! OK
+end
+
+
+subroutine five_SaveAll(n,my_alloc)
+ use my_omp_lib
+ implicit none
+ save
+ integer :: qq, rr, ss, tt, uu, vv,n
+ integer(omp_allocator_handle_kind) :: my_alloc
+!$omp allocate (qq) allocator(3.0) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'qq' at .2. has the SAVE attribute" }
+! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
+!$omp allocate (rr) allocator(3_2) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'rr' at .2. has the SAVE attribute" }
+!$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'ss' at .2. has the SAVE attribute" }
+!$omp allocate (tt) allocator(my_alloc) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'tt' at .2. has the SAVE attribute" }
+end
+
+
+subroutine five_Save(n,my_alloc)
+ use my_omp_lib
+ implicit none
+ integer :: n
+ integer, save :: qq, rr, ss, tt, uu, vv
+ integer(omp_allocator_handle_kind) :: my_alloc
+!$omp allocate (qq) allocator(3.0) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'qq' at .2. has the SAVE attribute" }
+! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
+!$omp allocate (rr) allocator(3_2) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'rr' at .2. has the SAVE attribute" }
+!$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'ss' at .2. has the SAVE attribute" }
+!$omp allocate (tt) allocator(my_alloc) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'tt' at .2. has the SAVE attribute" }
+end
+
+module five_Module
+ use my_omp_lib
+ implicit none
+ integer, save :: qq, rr, ss, tt, uu, vv,n
+ integer(omp_allocator_handle_kind) :: my_alloc
+!$omp allocate (qq) allocator(3.0) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'qq' at .2. has the SAVE attribute" }
+! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
+!$omp allocate (rr) allocator(3_2) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'rr' at .2. has the SAVE attribute" }
+!$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'ss' at .2. has the SAVE attribute" }
+!$omp allocate (tt) allocator(my_alloc) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'tt' at .2. has the SAVE attribute" }
+end module
+
+program five_program
+ use my_omp_lib
+ implicit none
+ integer, save :: qq, rr, ss, tt, uu, vv,n
+ integer(omp_allocator_handle_kind) :: my_alloc
+!$omp allocate (qq) allocator(3.0) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'qq' at .2. has the SAVE attribute" }
+! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
+!$omp allocate (rr) allocator(3_2) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'rr' at .2. has the SAVE attribute" }
+!$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'ss' at .2. has the SAVE attribute" }
+!$omp allocate (tt) allocator(my_alloc) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'tt' at .2. has the SAVE attribute" }
+end program
+
+
+
+subroutine six(n,my_alloc)
+ use my_omp_lib
+ implicit none
+ integer :: qq, rr, ss, tt, uu, vv,n
+ common /com6qq/ qq
+ common /com6rr/ rr
+ common /com6ss/ ss
+ common /com6tt/ tt
+ integer(omp_allocator_handle_kind) :: my_alloc
+
+!$omp allocate (/com6qq/) allocator(3.0) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item '/com6qq/' at .2. has the SAVE attribute" }
+! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
+!$omp allocate (/com6rr/) allocator(3_2) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item '/com6rr/' at .2. has the SAVE attribute" }
+!$omp allocate (/com6ss/) allocator([omp_pteam_mem_alloc]) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item '/com6ss/' at .2. has the SAVE attribute" }
+!$omp allocate (/com6tt/) allocator(my_alloc) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item '/com6tt/' at .2. has the SAVE attribute" }
+end
+
+
+subroutine two()
+ use my_omp_lib
+ implicit none
+ integer,allocatable :: qq, rr, ss, tt, uu, vv,n
+ integer(omp_allocator_handle_kind) :: my_alloc
+
+ call foo()
+!$omp allocate (qq) allocator(3.0) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" }
+allocate(qq)
+!$omp allocate (rr) allocator(3_2) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" }
+allocate(rr)
+!$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" }
+allocate(ss)
+!$omp allocate (tt) allocator(my_alloc) ! OK
+allocate(tt)
+end
+
+subroutine two_ptr()
+ use my_omp_lib
+ implicit none
+ integer,pointer :: qq, rr, ss, tt, uu, vv,n
+ integer(omp_allocator_handle_kind) :: my_alloc
+
+ call foo()
+!$omp allocate (qq) align(3+n) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
+allocate(qq)
+!$omp allocate (rr) align([4]) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
+allocate(rr)
+!$omp allocate (ss) align([4]) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
+allocate(ss)
+!$omp allocate (tt) align(32.0) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
+allocate(tt)
+!$omp allocate (uu) align(31) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
+allocate(uu)
+end
+
+subroutine next()
+ use my_omp_lib
+ implicit none
+ integer,allocatable :: qq, rr, ss, tt, uu, vv,n
+ integer(omp_allocator_handle_kind) :: my_alloc
+
+ !$omp allocate(qq) ! { dg-error "'!.OMP ALLOCATE' directive at .1. associated with an ALLOCATE stmt must be preceded by an executable statement or OpenMP construct; note the variables in the list all have the allocatable or pointer attribute" }
+ allocate(qq,rr)
+
+ !$omp allocate(uu,tt)
+ !$omp allocate(tt) ! { dg-warning "'tt' appears more than once in 'allocate" }
+ allocate(uu,tt)
+
+ !$omp allocate(uu,vv) ! { dg-error "'uu' specified in 'allocate' at .1. but not in the associated ALLOCATE statement" }
+ allocate(vv)
+end
--- /dev/null
+implicit none
+integer, allocatable :: a, b
+integer :: q
+integer :: arr(2)
+
+!$omp allocators allocate(align(64): a)
+block ! { dg-error "expected ALLOCATE statement after !.OMP ALLOCATORS" }
+end block ! { dg-error "Expecting END PROGRAM statement" }
+
+
+!$omp allocators allocate(align(64): a)
+ allocate(a, b) ! OK
+!$omp end allocators
+
+!$omp allocators allocate(align(128): b)
+ allocate(a, b) ! OK (assuming not allocated)
+
+
+!$omp allocators allocate(align(64): a)
+ allocate(a, b, stat=arr) ! { dg-error "Stat-variable at .1. must be a scalar INTEGER variable" }
+!$omp end allocators
+
+
+!$omp allocators allocate(align(64): a)
+ allocate(q) ! { dg-error "is neither a data pointer nor an allocatable variable" }
+!$omp end allocators ! { dg-error "Unexpected !.OMP END ALLOCATORS" }
+
+end
--- /dev/null
+implicit none
+integer, allocatable :: a, b
+integer :: q
+integer :: arr(2)
+
+!$omp allocators allocate(align(64): a)
+ allocate(a, b) ! OK
+!$omp end allocators
+
+!$omp allocators allocate(align(128): b)
+ allocate(a, b) ! OK (assuming not allocated)
+
+
+!$omp allocators allocate(align(62.0): a) ! { dg-error "a scalar positive constant integer alignment expression" }
+ allocate(a)
+
+
+!$omp allocators allocate(align(64): a, b) ! { dg-error "'b' specified in 'allocate' at \\(1\\) but not in the associated ALLOCATE statement" }
+ allocate(a)
+!$omp end allocators
+
+end
!$omp parallel allocate( allocator (omp_high_bw_mem_alloc) : x) firstprivate(x) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" }
!$omp end parallel
-!$omp parallel allocate( align (q) : x) firstprivate(x) ! { dg-error "32:ALIGN modifier requires at \\(1\\) a scalar positive constant integer alignment expression that is a power of two" }
+!$omp parallel allocate( align (q) : x) firstprivate(x) ! { dg-error "32:ALIGN requires a scalar positive constant integer alignment expression at \\(1\\) that is a power of two" }
!$omp end parallel
!$omp parallel allocate( align (32) : x) firstprivate(x) ! OK
!$omp end parallel
-!$omp parallel allocate( align(q) : x) firstprivate(x) ! { dg-error "31:ALIGN modifier requires at \\(1\\) a scalar positive constant integer alignment expression that is a power of two" }
+!$omp parallel allocate( align(q) : x) firstprivate(x) ! { dg-error "31:ALIGN requires a scalar positive constant integer alignment expression at \\(1\\) that is a power of two" }
!$omp end parallel
!$omp parallel allocate( align(cnst(1)) : x ) firstprivate(x) ! OK
!$omp end parallel
-!$omp parallel allocate( align(cnst(2)) : x) firstprivate(x) ! { dg-error "31:ALIGN modifier requires at \\(1\\) a scalar positive constant integer alignment expression that is a power of two" }
+!$omp parallel allocate( align(cnst(2)) : x) firstprivate(x) ! { dg-error "31:ALIGN requires a scalar positive constant integer alignment expression at \\(1\\) that is a power of two" }
!$omp end parallel
-!$omp parallel allocate( align( 31) :x) firstprivate(x) ! { dg-error "32:ALIGN modifier requires at \\(1\\) a scalar positive constant integer alignment expression that is a power of two" }
+!$omp parallel allocate( align( 31) :x) firstprivate(x) ! { dg-error "32:ALIGN requires a scalar positive constant integer alignment expression at \\(1\\) that is a power of two" }
!$omp end parallel
-!$omp parallel allocate( align (32.0): x) firstprivate(x) ! { dg-error "32:ALIGN modifier requires at \\(1\\) a scalar positive constant integer alignment expression that is a power of two" }
+!$omp parallel allocate( align (32.0): x) firstprivate(x) ! { dg-error "32:ALIGN requires a scalar positive constant integer alignment expression at \\(1\\) that is a power of two" }
!$omp end parallel
-!$omp parallel allocate( align(cnst ) : x ) firstprivate(x) ! { dg-error "31:ALIGN modifier requires at \\(1\\) a scalar positive constant integer alignment expression that is a power of two" }
+!$omp parallel allocate( align(cnst ) : x ) firstprivate(x) ! { dg-error "31:ALIGN requires a scalar positive constant integer alignment expression at \\(1\\) that is a power of two" }
!$omp end parallel
end
projects / thirdparty / gcc.git / commitdiff
