Line data Source code
1 : /* OpenMP directive matching and resolving.
2 : Copyright (C) 2005-2026 Free Software Foundation, Inc.
3 : Contributed by Jakub Jelinek
4 :
5 : This file is part of GCC.
6 :
7 : GCC is free software; you can redistribute it and/or modify it under
8 : the terms of the GNU General Public License as published by the Free
9 : Software Foundation; either version 3, or (at your option) any later
10 : version.
11 :
12 : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 : WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 : FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 : for more details.
16 :
17 : You should have received a copy of the GNU General Public License
18 : along with GCC; see the file COPYING3. If not see
19 : <http://www.gnu.org/licenses/>. */
20 :
21 : #define INCLUDE_VECTOR
22 : #define INCLUDE_STRING
23 : #include "config.h"
24 : #include "system.h"
25 : #include "coretypes.h"
26 : #include "options.h"
27 : #include "gfortran.h"
28 : #include "arith.h"
29 : #include "match.h"
30 : #include "parse.h"
31 : #include "constructor.h"
32 : #include "diagnostic.h"
33 : #include "gomp-constants.h"
34 : #include "target-memory.h" /* For gfc_encode_character. */
35 : #include "bitmap.h"
36 : #include "omp-api.h" /* For omp_runtime_api_procname. */
37 :
38 : location_t gfc_get_location (locus *);
39 :
40 : static gfc_statement omp_code_to_statement (gfc_code *);
41 :
42 : enum gfc_omp_directive_kind {
43 : GFC_OMP_DIR_DECLARATIVE,
44 : GFC_OMP_DIR_EXECUTABLE,
45 : GFC_OMP_DIR_INFORMATIONAL,
46 : GFC_OMP_DIR_META,
47 : GFC_OMP_DIR_SUBSIDIARY,
48 : GFC_OMP_DIR_UTILITY
49 : };
50 :
51 : struct gfc_omp_directive {
52 : const char *name;
53 : enum gfc_omp_directive_kind kind;
54 : gfc_statement st;
55 : };
56 :
57 : /* Alphabetically sorted OpenMP clauses, except that longer strings are before
58 : substrings; excludes combined/composite directives. See note for "ordered"
59 : and "nothing". */
60 :
61 : static const struct gfc_omp_directive gfc_omp_directives[] = {
62 : /* allocate as alias for allocators is also executive. */
63 : {"allocate", GFC_OMP_DIR_DECLARATIVE, ST_OMP_ALLOCATE},
64 : {"allocators", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ALLOCATORS},
65 : {"assumes", GFC_OMP_DIR_INFORMATIONAL, ST_OMP_ASSUMES},
66 : {"assume", GFC_OMP_DIR_INFORMATIONAL, ST_OMP_ASSUME},
67 : {"atomic", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ATOMIC},
68 : {"barrier", GFC_OMP_DIR_EXECUTABLE, ST_OMP_BARRIER},
69 : {"cancellation point", GFC_OMP_DIR_EXECUTABLE, ST_OMP_CANCELLATION_POINT},
70 : {"cancel", GFC_OMP_DIR_EXECUTABLE, ST_OMP_CANCEL},
71 : {"critical", GFC_OMP_DIR_EXECUTABLE, ST_OMP_CRITICAL},
72 : /* {"declare induction", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_INDUCTION}, */
73 : /* {"declare mapper", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_MAPPER}, */
74 : {"declare reduction", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_REDUCTION},
75 : {"declare simd", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_SIMD},
76 : {"declare target", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_TARGET},
77 : {"declare variant", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_VARIANT},
78 : {"depobj", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DEPOBJ},
79 : {"dispatch", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DISPATCH},
80 : {"distribute", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DISTRIBUTE},
81 : {"do", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DO},
82 : /* "error" becomes GFC_OMP_DIR_EXECUTABLE with at(execution) */
83 : {"error", GFC_OMP_DIR_UTILITY, ST_OMP_ERROR},
84 : /* {"flatten", GFC_OMP_DIR_EXECUTABLE, ST_OMP_FLATTEN}, */
85 : {"flush", GFC_OMP_DIR_EXECUTABLE, ST_OMP_FLUSH},
86 : /* {"fuse", GFC_OMP_DIR_EXECUTABLE, ST_OMP_FLUSE}, */
87 : {"groupprivate", GFC_OMP_DIR_DECLARATIVE, ST_OMP_GROUPPRIVATE},
88 : /* {"interchange", GFC_OMP_DIR_EXECUTABLE, ST_OMP_INTERCHANGE}, */
89 : {"interop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_INTEROP},
90 : {"loop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_LOOP},
91 : {"masked", GFC_OMP_DIR_EXECUTABLE, ST_OMP_MASKED},
92 : {"metadirective", GFC_OMP_DIR_META, ST_OMP_METADIRECTIVE},
93 : /* Note: gfc_match_omp_nothing returns ST_NONE. */
94 : {"nothing", GFC_OMP_DIR_UTILITY, ST_OMP_NOTHING},
95 : /* Special case; for now map to the first one.
96 : ordered-blockassoc = ST_OMP_ORDERED
97 : ordered-standalone = ST_OMP_ORDERED_DEPEND + depend/doacross. */
98 : {"ordered", GFC_OMP_DIR_EXECUTABLE, ST_OMP_ORDERED},
99 : {"parallel", GFC_OMP_DIR_EXECUTABLE, ST_OMP_PARALLEL},
100 : {"requires", GFC_OMP_DIR_INFORMATIONAL, ST_OMP_REQUIRES},
101 : {"scan", GFC_OMP_DIR_SUBSIDIARY, ST_OMP_SCAN},
102 : {"scope", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SCOPE},
103 : {"sections", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SECTIONS},
104 : {"section", GFC_OMP_DIR_SUBSIDIARY, ST_OMP_SECTION},
105 : {"simd", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SIMD},
106 : {"single", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SINGLE},
107 : /* {"split", GFC_OMP_DIR_EXECUTABLE, ST_OMP_SPLIT}, */
108 : /* {"strip", GFC_OMP_DIR_EXECUTABLE, ST_OMP_STRIP}, */
109 : {"target data", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_DATA},
110 : {"target enter data", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_ENTER_DATA},
111 : {"target exit data", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_EXIT_DATA},
112 : {"target update", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET_UPDATE},
113 : {"target", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TARGET},
114 : /* {"taskgraph", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKGRAPH}, */
115 : /* {"task iteration", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASK_ITERATION}, */
116 : {"taskloop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKLOOP},
117 : {"taskwait", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKWAIT},
118 : {"taskyield", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASKYIELD},
119 : {"task", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TASK},
120 : {"teams", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TEAMS},
121 : {"threadprivate", GFC_OMP_DIR_DECLARATIVE, ST_OMP_THREADPRIVATE},
122 : {"tile", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TILE},
123 : {"unroll", GFC_OMP_DIR_EXECUTABLE, ST_OMP_UNROLL},
124 : /* {"workdistribute", GFC_OMP_DIR_EXECUTABLE, ST_OMP_WORKDISTRIBUTE}, */
125 : {"workshare", GFC_OMP_DIR_EXECUTABLE, ST_OMP_WORKSHARE},
126 : };
127 :
128 :
129 : /* Match an end of OpenMP directive. End of OpenMP directive is optional
130 : whitespace, followed by '\n' or comment '!'. In the special case where a
131 : context selector is being matched, match against ')' instead. */
132 :
133 : static match
134 54819 : gfc_match_omp_eos (void)
135 : {
136 54819 : locus old_loc;
137 54819 : char c;
138 :
139 54819 : old_loc = gfc_current_locus;
140 54819 : gfc_gobble_whitespace ();
141 :
142 54819 : if (gfc_matching_omp_context_selector)
143 : {
144 269 : if (gfc_peek_ascii_char () == ')')
145 : return MATCH_YES;
146 : }
147 : else
148 : {
149 54550 : c = gfc_next_ascii_char ();
150 54550 : switch (c)
151 : {
152 0 : case '!':
153 0 : do
154 0 : c = gfc_next_ascii_char ();
155 0 : while (c != '\n');
156 : /* Fall through */
157 :
158 52842 : case '\n':
159 52842 : return MATCH_YES;
160 : }
161 : }
162 :
163 1709 : gfc_current_locus = old_loc;
164 1709 : return MATCH_NO;
165 : }
166 :
167 : match
168 13157 : gfc_match_omp_eos_error (void)
169 : {
170 13157 : if (gfc_match_omp_eos() == MATCH_YES)
171 : return MATCH_YES;
172 :
173 35 : gfc_error ("Unexpected junk at %C");
174 35 : return MATCH_ERROR;
175 : }
176 :
177 :
178 : /* Free an omp_clauses structure. */
179 :
180 : void
181 60934 : gfc_free_omp_clauses (gfc_omp_clauses *c)
182 : {
183 60934 : if (c == NULL)
184 : return;
185 :
186 34286 : gfc_free_expr (c->if_expr);
187 377146 : for (int i = 0; i < OMP_IF_LAST; i++)
188 342860 : gfc_free_expr (c->if_exprs[i]);
189 34286 : gfc_free_expr (c->self_expr);
190 34286 : gfc_free_expr (c->final_expr);
191 34286 : gfc_free_expr (c->num_threads);
192 34286 : gfc_free_expr (c->chunk_size);
193 34286 : gfc_free_expr (c->safelen_expr);
194 34286 : gfc_free_expr (c->simdlen_expr);
195 34286 : gfc_free_expr (c->num_teams_lower);
196 34286 : gfc_free_expr (c->num_teams_upper);
197 34286 : gfc_free_expr (c->device);
198 34286 : gfc_free_expr (c->dyn_groupprivate);
199 34286 : gfc_free_expr (c->thread_limit);
200 34286 : gfc_free_expr (c->dist_chunk_size);
201 34286 : gfc_free_expr (c->grainsize);
202 34286 : gfc_free_expr (c->hint);
203 34286 : gfc_free_expr (c->num_tasks);
204 34286 : gfc_free_expr (c->priority);
205 34286 : gfc_free_expr (c->detach);
206 34286 : gfc_free_expr (c->novariants);
207 34286 : gfc_free_expr (c->nocontext);
208 34286 : gfc_free_expr (c->async_expr);
209 34286 : gfc_free_expr (c->gang_num_expr);
210 34286 : gfc_free_expr (c->gang_static_expr);
211 34286 : gfc_free_expr (c->worker_expr);
212 34286 : gfc_free_expr (c->vector_expr);
213 34286 : gfc_free_expr (c->num_gangs_expr);
214 34286 : gfc_free_expr (c->num_workers_expr);
215 34286 : gfc_free_expr (c->vector_length_expr);
216 1371440 : for (enum gfc_omp_list_type t = OMP_LIST_FIRST; t < OMP_LIST_NUM;
217 1337154 : t = gfc_omp_list_type (t + 1))
218 1337154 : gfc_free_omp_namelist (c->lists[t], t);
219 34286 : gfc_free_expr_list (c->wait_list);
220 34286 : gfc_free_expr_list (c->tile_list);
221 34286 : gfc_free_expr_list (c->sizes_list);
222 34286 : free (const_cast<char *> (c->critical_name));
223 34286 : if (c->assume)
224 : {
225 23 : free (c->assume->absent);
226 23 : free (c->assume->contains);
227 23 : gfc_free_expr_list (c->assume->holds);
228 23 : free (c->assume);
229 : }
230 34286 : free (c);
231 : }
232 :
233 : /* Free oacc_declare structures. */
234 :
235 : void
236 76 : gfc_free_oacc_declare_clauses (struct gfc_oacc_declare *oc)
237 : {
238 76 : struct gfc_oacc_declare *decl = oc;
239 :
240 76 : do
241 : {
242 76 : struct gfc_oacc_declare *next;
243 :
244 76 : next = decl->next;
245 76 : gfc_free_omp_clauses (decl->clauses);
246 76 : free (decl);
247 76 : decl = next;
248 : }
249 76 : while (decl);
250 76 : }
251 :
252 : /* Free expression list. */
253 : void
254 103804 : gfc_free_expr_list (gfc_expr_list *list)
255 : {
256 103804 : gfc_expr_list *n;
257 :
258 105207 : for (; list; list = n)
259 : {
260 1403 : n = list->next;
261 1403 : free (list);
262 : }
263 103804 : }
264 :
265 : /* Free an !$omp declare simd construct list. */
266 :
267 : void
268 236 : gfc_free_omp_declare_simd (gfc_omp_declare_simd *ods)
269 : {
270 236 : if (ods)
271 : {
272 236 : gfc_free_omp_clauses (ods->clauses);
273 236 : free (ods);
274 : }
275 236 : }
276 :
277 : void
278 518983 : gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *list)
279 : {
280 519219 : while (list)
281 : {
282 236 : gfc_omp_declare_simd *current = list;
283 236 : list = list->next;
284 236 : gfc_free_omp_declare_simd (current);
285 : }
286 518983 : }
287 :
288 : static void
289 727 : gfc_free_omp_trait_property_list (gfc_omp_trait_property *list)
290 : {
291 1134 : while (list)
292 : {
293 407 : gfc_omp_trait_property *current = list;
294 407 : list = list->next;
295 407 : switch (current->property_kind)
296 : {
297 24 : case OMP_TRAIT_PROPERTY_ID:
298 24 : free (current->name);
299 24 : break;
300 261 : case OMP_TRAIT_PROPERTY_NAME_LIST:
301 261 : if (current->is_name)
302 168 : free (current->name);
303 : break;
304 15 : case OMP_TRAIT_PROPERTY_CLAUSE_LIST:
305 15 : gfc_free_omp_clauses (current->clauses);
306 15 : break;
307 : default:
308 : break;
309 : }
310 407 : free (current);
311 : }
312 727 : }
313 :
314 : static void
315 599 : gfc_free_omp_selector_list (gfc_omp_selector *list)
316 : {
317 1326 : while (list)
318 : {
319 727 : gfc_omp_selector *current = list;
320 727 : list = list->next;
321 727 : gfc_free_omp_trait_property_list (current->properties);
322 727 : free (current);
323 : }
324 599 : }
325 :
326 : static void
327 668 : gfc_free_omp_set_selector_list (gfc_omp_set_selector *list)
328 : {
329 1267 : while (list)
330 : {
331 599 : gfc_omp_set_selector *current = list;
332 599 : list = list->next;
333 599 : gfc_free_omp_selector_list (current->trait_selectors);
334 599 : free (current);
335 : }
336 668 : }
337 :
338 : /* Free an !$omp declare variant construct list. */
339 :
340 : void
341 518983 : gfc_free_omp_declare_variant_list (gfc_omp_declare_variant *list)
342 : {
343 519437 : while (list)
344 : {
345 454 : gfc_omp_declare_variant *current = list;
346 454 : list = list->next;
347 454 : gfc_free_omp_set_selector_list (current->set_selectors);
348 454 : gfc_free_omp_namelist (current->adjust_args_list, OMP_LIST_NONE);
349 454 : free (current);
350 : }
351 518983 : }
352 :
353 : /* Free an !$omp declare reduction. */
354 :
355 : void
356 1118 : gfc_free_omp_udr (gfc_omp_udr *omp_udr)
357 : {
358 1118 : if (omp_udr)
359 : {
360 607 : gfc_free_omp_udr (omp_udr->next);
361 607 : gfc_free_namespace (omp_udr->combiner_ns);
362 607 : if (omp_udr->initializer_ns)
363 377 : gfc_free_namespace (omp_udr->initializer_ns);
364 607 : free (omp_udr);
365 : }
366 1118 : }
367 :
368 : /* Free variants of an !$omp metadirective construct. */
369 :
370 : void
371 93 : gfc_free_omp_variants (gfc_omp_variant *variant)
372 : {
373 284 : while (variant)
374 : {
375 191 : gfc_omp_variant *next_variant = variant->next;
376 191 : gfc_free_omp_set_selector_list (variant->selectors);
377 191 : free (variant);
378 191 : variant = next_variant;
379 : }
380 93 : }
381 :
382 : static gfc_omp_udr *
383 4710 : gfc_find_omp_udr (gfc_namespace *ns, const char *name, gfc_typespec *ts)
384 : {
385 4710 : gfc_symtree *st;
386 :
387 4710 : if (ns == NULL)
388 467 : ns = gfc_current_ns;
389 5658 : do
390 : {
391 5658 : gfc_omp_udr *omp_udr;
392 :
393 5658 : st = gfc_find_symtree (ns->omp_udr_root, name);
394 5658 : if (st != NULL)
395 : {
396 934 : for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
397 934 : if (ts == NULL)
398 : return omp_udr;
399 567 : else if (gfc_compare_types (&omp_udr->ts, ts))
400 : {
401 479 : if (ts->type == BT_CHARACTER)
402 : {
403 60 : if (omp_udr->ts.u.cl->length == NULL)
404 : return omp_udr;
405 36 : if (ts->u.cl->length == NULL)
406 0 : continue;
407 36 : if (gfc_compare_expr (omp_udr->ts.u.cl->length,
408 : ts->u.cl->length,
409 : INTRINSIC_EQ) != 0)
410 12 : continue;
411 : }
412 443 : return omp_udr;
413 : }
414 : }
415 :
416 : /* Don't escape an interface block. */
417 4824 : if (ns && !ns->has_import_set
418 4824 : && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
419 : break;
420 :
421 4824 : ns = ns->parent;
422 : }
423 4824 : while (ns != NULL);
424 :
425 : return NULL;
426 : }
427 :
428 :
429 : /* Match a variable/common block list and construct a namelist from it;
430 : if has_all_memory != NULL, *has_all_memory is set and omp_all_memory
431 : yields a list->sym NULL entry. */
432 :
433 : static match
434 30982 : gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list,
435 : bool allow_common, bool *end_colon = NULL,
436 : gfc_omp_namelist ***headp = NULL,
437 : bool allow_sections = false,
438 : bool allow_derived = false,
439 : bool *has_all_memory = NULL,
440 : bool reject_common_vars = false,
441 : bool reverse_order = false)
442 : {
443 30982 : gfc_omp_namelist *head, *tail, *p;
444 30982 : locus old_loc, cur_loc;
445 30982 : char n[GFC_MAX_SYMBOL_LEN+1];
446 30982 : gfc_symbol *sym;
447 30982 : match m;
448 30982 : gfc_symtree *st;
449 :
450 30982 : head = tail = NULL;
451 :
452 30982 : old_loc = gfc_current_locus;
453 30982 : if (has_all_memory)
454 708 : *has_all_memory = false;
455 30982 : m = gfc_match (str);
456 30982 : if (m != MATCH_YES)
457 : return m;
458 :
459 37686 : for (;;)
460 : {
461 37686 : gfc_gobble_whitespace ();
462 37686 : cur_loc = gfc_current_locus;
463 :
464 37686 : m = gfc_match_name (n);
465 37686 : if (m == MATCH_YES && strcmp (n, "omp_all_memory") == 0)
466 : {
467 23 : locus loc = gfc_get_location_range (NULL, 0, &cur_loc, 1,
468 : &gfc_current_locus);
469 23 : if (!has_all_memory)
470 : {
471 2 : gfc_error ("%<omp_all_memory%> at %L not permitted in this "
472 : "clause", &loc);
473 2 : goto cleanup;
474 : }
475 21 : *has_all_memory = true;
476 21 : p = gfc_get_omp_namelist ();
477 21 : if (head == NULL)
478 : head = tail = p;
479 : else
480 : {
481 3 : tail->next = p;
482 3 : tail = tail->next;
483 : }
484 21 : tail->where = loc;
485 21 : goto next_item;
486 : }
487 37409 : if (m == MATCH_YES)
488 : {
489 37409 : gfc_symtree *st;
490 37409 : if ((m = gfc_get_ha_sym_tree (n, &st) ? MATCH_ERROR : MATCH_YES)
491 : == MATCH_YES)
492 37409 : sym = st->n.sym;
493 : }
494 37663 : switch (m)
495 : {
496 37409 : case MATCH_YES:
497 37409 : gfc_expr *expr;
498 37409 : expr = NULL;
499 37409 : gfc_gobble_whitespace ();
500 22789 : if ((allow_sections && gfc_peek_ascii_char () == '(')
501 56100 : || (allow_derived && gfc_peek_ascii_char () == '%'))
502 : {
503 6325 : gfc_current_locus = cur_loc;
504 6325 : m = gfc_match_variable (&expr, 0);
505 6325 : switch (m)
506 : {
507 4 : case MATCH_ERROR:
508 12 : goto cleanup;
509 0 : case MATCH_NO:
510 0 : goto syntax;
511 6321 : default:
512 6321 : break;
513 : }
514 6321 : if (gfc_is_coindexed (expr))
515 : {
516 5 : gfc_error ("List item shall not be coindexed at %L",
517 5 : &expr->where);
518 5 : goto cleanup;
519 : }
520 : }
521 37400 : gfc_set_sym_referenced (sym);
522 37400 : p = gfc_get_omp_namelist ();
523 37400 : if (head == NULL)
524 : head = tail = p;
525 10113 : else if (reverse_order)
526 : {
527 57 : p->next = head;
528 57 : head = p;
529 : }
530 : else
531 : {
532 10056 : tail->next = p;
533 10056 : tail = tail->next;
534 : }
535 37400 : p->sym = sym;
536 37400 : p->expr = expr;
537 37400 : p->where = gfc_get_location_range (NULL, 0, &cur_loc, 1,
538 : &gfc_current_locus);
539 37400 : if (reject_common_vars && sym->attr.in_common)
540 : {
541 3 : gcc_assert (allow_common);
542 3 : gfc_error ("%qs at %L is part of the common block %</%s/%> and "
543 : "may only be specificed implicitly via the named "
544 : "common block", sym->name, &cur_loc,
545 3 : sym->common_head->name);
546 3 : goto cleanup;
547 : }
548 37397 : goto next_item;
549 254 : case MATCH_NO:
550 254 : break;
551 0 : case MATCH_ERROR:
552 0 : goto cleanup;
553 : }
554 :
555 254 : if (!allow_common)
556 10 : goto syntax;
557 :
558 244 : m = gfc_match ("/ %n /", n);
559 244 : if (m == MATCH_ERROR)
560 0 : goto cleanup;
561 244 : if (m == MATCH_NO)
562 19 : goto syntax;
563 :
564 225 : cur_loc = gfc_get_location_range (NULL, 0, &cur_loc, 1,
565 : &gfc_current_locus);
566 225 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
567 225 : if (st == NULL)
568 : {
569 2 : gfc_error ("COMMON block %</%s/%> not found at %L", n, &cur_loc);
570 2 : goto cleanup;
571 : }
572 724 : for (sym = st->n.common->head; sym; sym = sym->common_next)
573 : {
574 501 : gfc_set_sym_referenced (sym);
575 501 : p = gfc_get_omp_namelist ();
576 501 : if (head == NULL)
577 : head = tail = p;
578 325 : else if (reverse_order)
579 : {
580 0 : p->next = head;
581 0 : head = p;
582 : }
583 : else
584 : {
585 325 : tail->next = p;
586 325 : tail = tail->next;
587 : }
588 501 : p->sym = sym;
589 501 : p->where = cur_loc;
590 : }
591 :
592 223 : next_item:
593 37641 : if (end_colon && gfc_match_char (':') == MATCH_YES)
594 : {
595 793 : *end_colon = true;
596 793 : break;
597 : }
598 36848 : if (gfc_match_char (')') == MATCH_YES)
599 : break;
600 10182 : if (gfc_match_char (',') != MATCH_YES)
601 19 : goto syntax;
602 : }
603 :
604 36973 : while (*list)
605 9514 : list = &(*list)->next;
606 :
607 27459 : *list = head;
608 27459 : if (headp)
609 21590 : *headp = list;
610 : return MATCH_YES;
611 :
612 48 : syntax:
613 48 : gfc_error ("Syntax error in OpenMP variable list at %C");
614 :
615 64 : cleanup:
616 64 : gfc_free_omp_namelist (head, OMP_LIST_NONE);
617 64 : gfc_current_locus = old_loc;
618 64 : return MATCH_ERROR;
619 : }
620 :
621 : /* Match a variable/procedure/common block list and construct a namelist
622 : from it. */
623 :
624 : static match
625 362 : gfc_match_omp_to_link (const char *str, gfc_omp_namelist **list)
626 : {
627 362 : gfc_omp_namelist *head, *tail, *p;
628 362 : locus old_loc, cur_loc;
629 362 : char n[GFC_MAX_SYMBOL_LEN+1];
630 362 : gfc_symbol *sym;
631 362 : match m;
632 362 : gfc_symtree *st;
633 :
634 362 : head = tail = NULL;
635 :
636 362 : old_loc = gfc_current_locus;
637 :
638 362 : m = gfc_match (str);
639 362 : if (m != MATCH_YES)
640 : return m;
641 :
642 548 : for (;;)
643 : {
644 548 : cur_loc = gfc_current_locus;
645 548 : m = gfc_match_symbol (&sym, 1);
646 548 : switch (m)
647 : {
648 507 : case MATCH_YES:
649 507 : p = gfc_get_omp_namelist ();
650 507 : if (head == NULL)
651 : head = tail = p;
652 : else
653 : {
654 194 : tail->next = p;
655 194 : tail = tail->next;
656 : }
657 507 : tail->sym = sym;
658 507 : tail->where = cur_loc;
659 507 : goto next_item;
660 : case MATCH_NO:
661 : break;
662 0 : case MATCH_ERROR:
663 0 : goto cleanup;
664 : }
665 :
666 41 : m = gfc_match (" / %n /", n);
667 41 : if (m == MATCH_ERROR)
668 0 : goto cleanup;
669 41 : if (m == MATCH_NO)
670 0 : goto syntax;
671 :
672 41 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
673 41 : if (st == NULL)
674 : {
675 0 : gfc_error ("COMMON block /%s/ not found at %C", n);
676 0 : goto cleanup;
677 : }
678 41 : p = gfc_get_omp_namelist ();
679 41 : if (head == NULL)
680 : head = tail = p;
681 : else
682 : {
683 4 : tail->next = p;
684 4 : tail = tail->next;
685 : }
686 41 : tail->u.common = st->n.common;
687 41 : tail->where = cur_loc;
688 :
689 548 : next_item:
690 548 : if (gfc_match_char (')') == MATCH_YES)
691 : break;
692 198 : if (gfc_match_char (',') != MATCH_YES)
693 0 : goto syntax;
694 : }
695 :
696 361 : while (*list)
697 11 : list = &(*list)->next;
698 :
699 350 : *list = head;
700 350 : return MATCH_YES;
701 :
702 0 : syntax:
703 0 : gfc_error ("Syntax error in OpenMP variable list at %C");
704 :
705 0 : cleanup:
706 0 : gfc_free_omp_namelist (head, OMP_LIST_NONE);
707 0 : gfc_current_locus = old_loc;
708 0 : return MATCH_ERROR;
709 : }
710 :
711 : /* Match detach(event-handle). */
712 :
713 : static match
714 126 : gfc_match_omp_detach (gfc_expr **expr)
715 : {
716 126 : locus old_loc = gfc_current_locus;
717 :
718 126 : if (gfc_match ("detach ( ") != MATCH_YES)
719 0 : goto syntax_error;
720 :
721 126 : if (gfc_match_variable (expr, 0) != MATCH_YES)
722 0 : goto syntax_error;
723 :
724 126 : if (gfc_match_char (')') != MATCH_YES)
725 0 : goto syntax_error;
726 :
727 : return MATCH_YES;
728 :
729 0 : syntax_error:
730 0 : gfc_error ("Syntax error in OpenMP detach clause at %C");
731 0 : gfc_current_locus = old_loc;
732 0 : return MATCH_ERROR;
733 :
734 : }
735 :
736 : /* Match doacross(sink : ...) construct a namelist from it;
737 : if depend is true, match legacy 'depend(sink : ...)'. */
738 :
739 : static match
740 241 : gfc_match_omp_doacross_sink (gfc_omp_namelist **list, bool depend)
741 : {
742 241 : char n[GFC_MAX_SYMBOL_LEN+1];
743 241 : gfc_omp_namelist *head, *tail, *p;
744 241 : locus old_loc, cur_loc;
745 241 : gfc_symbol *sym;
746 :
747 241 : head = tail = NULL;
748 :
749 241 : old_loc = gfc_current_locus;
750 :
751 2231 : for (;;)
752 : {
753 1236 : gfc_gobble_whitespace ();
754 1236 : cur_loc = gfc_current_locus;
755 :
756 1236 : if (gfc_match_name (n) != MATCH_YES)
757 1 : goto syntax;
758 1235 : locus loc = gfc_get_location_range (NULL, 0, &cur_loc, 1,
759 : &gfc_current_locus);
760 1235 : if (UNLIKELY (strcmp (n, "omp_all_memory") == 0))
761 : {
762 1 : gfc_error ("%<omp_all_memory%> used with dependence-type "
763 : "other than OUT or INOUT at %L", &loc);
764 1 : goto cleanup;
765 : }
766 1234 : sym = NULL;
767 1234 : if (!(strcmp (n, "omp_cur_iteration") == 0))
768 : {
769 1229 : gfc_symtree *st;
770 1229 : if (gfc_get_ha_sym_tree (n, &st))
771 0 : goto syntax;
772 1229 : sym = st->n.sym;
773 1229 : gfc_set_sym_referenced (sym);
774 : }
775 1234 : p = gfc_get_omp_namelist ();
776 1234 : if (head == NULL)
777 : {
778 239 : head = tail = p;
779 253 : head->u.depend_doacross_op = (depend ? OMP_DEPEND_SINK_FIRST
780 : : OMP_DOACROSS_SINK_FIRST);
781 : }
782 : else
783 : {
784 995 : tail->next = p;
785 995 : tail = tail->next;
786 995 : tail->u.depend_doacross_op = OMP_DOACROSS_SINK;
787 : }
788 1234 : tail->sym = sym;
789 1234 : tail->expr = NULL;
790 1234 : tail->where = loc;
791 1234 : if (gfc_match_char ('+') == MATCH_YES)
792 : {
793 154 : if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES)
794 0 : goto syntax;
795 : }
796 1080 : else if (gfc_match_char ('-') == MATCH_YES)
797 : {
798 418 : if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES)
799 1 : goto syntax;
800 417 : tail->expr = gfc_uminus (tail->expr);
801 : }
802 1233 : if (gfc_match_char (')') == MATCH_YES)
803 : break;
804 995 : if (gfc_match_char (',') != MATCH_YES)
805 0 : goto syntax;
806 995 : }
807 :
808 1030 : while (*list)
809 792 : list = &(*list)->next;
810 :
811 238 : *list = head;
812 238 : return MATCH_YES;
813 :
814 2 : syntax:
815 2 : gfc_error ("Syntax error in OpenMP SINK dependence-type list at %C");
816 :
817 3 : cleanup:
818 3 : gfc_free_omp_namelist (head, OMP_LIST_DEPEND);
819 3 : gfc_current_locus = old_loc;
820 3 : return MATCH_ERROR;
821 : }
822 :
823 : static match
824 819 : match_omp_oacc_expr_list (const char *str, gfc_expr_list **list,
825 : bool allow_asterisk, bool is_omp)
826 : {
827 819 : gfc_expr_list *head, *tail, *p;
828 819 : locus old_loc;
829 819 : gfc_expr *expr;
830 819 : match m;
831 :
832 819 : head = tail = NULL;
833 :
834 819 : old_loc = gfc_current_locus;
835 :
836 819 : m = gfc_match (str);
837 819 : if (m != MATCH_YES)
838 : return m;
839 :
840 1030 : for (;;)
841 : {
842 1030 : m = gfc_match_expr (&expr);
843 1030 : if (m == MATCH_YES || allow_asterisk)
844 : {
845 1018 : p = gfc_get_expr_list ();
846 1018 : if (head == NULL)
847 : head = tail = p;
848 : else
849 : {
850 335 : tail->next = p;
851 335 : tail = tail->next;
852 : }
853 1018 : if (m == MATCH_YES)
854 885 : tail->expr = expr;
855 133 : else if (gfc_match (" *") != MATCH_YES)
856 18 : goto syntax;
857 1000 : goto next_item;
858 : }
859 12 : if (m == MATCH_ERROR)
860 0 : goto cleanup;
861 12 : goto syntax;
862 :
863 1000 : next_item:
864 1000 : if (gfc_match_char (')') == MATCH_YES)
865 : break;
866 346 : if (gfc_match_char (',') != MATCH_YES)
867 6 : goto syntax;
868 : }
869 :
870 660 : while (*list)
871 6 : list = &(*list)->next;
872 :
873 654 : *list = head;
874 654 : return MATCH_YES;
875 :
876 36 : syntax:
877 36 : if (is_omp)
878 7 : gfc_error ("Syntax error in OpenMP expression list at %C");
879 : else
880 29 : gfc_error ("Syntax error in OpenACC expression list at %C");
881 :
882 36 : cleanup:
883 36 : gfc_free_expr_list (head);
884 36 : gfc_current_locus = old_loc;
885 36 : return MATCH_ERROR;
886 : }
887 :
888 : static match
889 3056 : match_oacc_clause_gwv (gfc_omp_clauses *cp, unsigned gwv)
890 : {
891 3056 : match ret = MATCH_YES;
892 :
893 3056 : if (gfc_match (" ( ") != MATCH_YES)
894 : return MATCH_NO;
895 :
896 470 : if (gwv == GOMP_DIM_GANG)
897 : {
898 : /* The gang clause accepts two optional arguments, num and static.
899 : The num argument may either be explicit (num: <val>) or
900 : implicit without (<val> without num:). */
901 :
902 457 : while (ret == MATCH_YES)
903 : {
904 236 : if (gfc_match (" static :") == MATCH_YES)
905 : {
906 114 : if (cp->gang_static)
907 : return MATCH_ERROR;
908 : else
909 113 : cp->gang_static = true;
910 113 : if (gfc_match_char ('*') == MATCH_YES)
911 18 : cp->gang_static_expr = NULL;
912 95 : else if (gfc_match (" %e ", &cp->gang_static_expr) != MATCH_YES)
913 : return MATCH_ERROR;
914 : }
915 : else
916 : {
917 122 : if (cp->gang_num_expr)
918 : return MATCH_ERROR;
919 :
920 : /* The 'num' argument is optional. */
921 121 : gfc_match (" num :");
922 :
923 121 : if (gfc_match (" %e ", &cp->gang_num_expr) != MATCH_YES)
924 : return MATCH_ERROR;
925 : }
926 :
927 231 : ret = gfc_match (" , ");
928 : }
929 : }
930 244 : else if (gwv == GOMP_DIM_WORKER)
931 : {
932 : /* The 'num' argument is optional. */
933 107 : gfc_match (" num :");
934 :
935 107 : if (gfc_match (" %e ", &cp->worker_expr) != MATCH_YES)
936 : return MATCH_ERROR;
937 : }
938 137 : else if (gwv == GOMP_DIM_VECTOR)
939 : {
940 : /* The 'length' argument is optional. */
941 137 : gfc_match (" length :");
942 :
943 137 : if (gfc_match (" %e ", &cp->vector_expr) != MATCH_YES)
944 : return MATCH_ERROR;
945 : }
946 : else
947 0 : gfc_fatal_error ("Unexpected OpenACC parallelism.");
948 :
949 459 : return gfc_match (" )");
950 : }
951 :
952 : static match
953 8 : gfc_match_oacc_clause_link (const char *str, gfc_omp_namelist **list)
954 : {
955 8 : gfc_omp_namelist *head = NULL;
956 8 : gfc_omp_namelist *tail, *p;
957 8 : locus old_loc;
958 8 : char n[GFC_MAX_SYMBOL_LEN+1];
959 8 : gfc_symbol *sym;
960 8 : match m;
961 8 : gfc_symtree *st;
962 :
963 8 : old_loc = gfc_current_locus;
964 :
965 8 : m = gfc_match (str);
966 8 : if (m != MATCH_YES)
967 : return m;
968 :
969 8 : m = gfc_match (" (");
970 :
971 14 : for (;;)
972 : {
973 14 : m = gfc_match_symbol (&sym, 0);
974 14 : switch (m)
975 : {
976 8 : case MATCH_YES:
977 8 : if (sym->attr.in_common)
978 : {
979 2 : gfc_error_now ("Variable at %C is an element of a COMMON block");
980 2 : goto cleanup;
981 : }
982 6 : gfc_set_sym_referenced (sym);
983 6 : p = gfc_get_omp_namelist ();
984 6 : if (head == NULL)
985 : head = tail = p;
986 : else
987 : {
988 4 : tail->next = p;
989 4 : tail = tail->next;
990 : }
991 6 : tail->sym = sym;
992 6 : tail->expr = NULL;
993 6 : tail->where = gfc_current_locus;
994 6 : goto next_item;
995 : case MATCH_NO:
996 : break;
997 :
998 0 : case MATCH_ERROR:
999 0 : goto cleanup;
1000 : }
1001 :
1002 6 : m = gfc_match (" / %n /", n);
1003 6 : if (m == MATCH_ERROR)
1004 0 : goto cleanup;
1005 6 : if (m == MATCH_NO || n[0] == '\0')
1006 0 : goto syntax;
1007 :
1008 6 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
1009 6 : if (st == NULL)
1010 : {
1011 1 : gfc_error ("COMMON block /%s/ not found at %C", n);
1012 1 : goto cleanup;
1013 : }
1014 :
1015 20 : for (sym = st->n.common->head; sym; sym = sym->common_next)
1016 : {
1017 15 : gfc_set_sym_referenced (sym);
1018 15 : p = gfc_get_omp_namelist ();
1019 15 : if (head == NULL)
1020 : head = tail = p;
1021 : else
1022 : {
1023 12 : tail->next = p;
1024 12 : tail = tail->next;
1025 : }
1026 15 : tail->sym = sym;
1027 15 : tail->where = gfc_current_locus;
1028 : }
1029 :
1030 5 : next_item:
1031 11 : if (gfc_match_char (')') == MATCH_YES)
1032 : break;
1033 6 : if (gfc_match_char (',') != MATCH_YES)
1034 0 : goto syntax;
1035 : }
1036 :
1037 5 : if (gfc_match_omp_eos () != MATCH_YES)
1038 : {
1039 1 : gfc_error ("Unexpected junk after !$ACC DECLARE at %C");
1040 1 : goto cleanup;
1041 : }
1042 :
1043 4 : while (*list)
1044 0 : list = &(*list)->next;
1045 4 : *list = head;
1046 4 : return MATCH_YES;
1047 :
1048 0 : syntax:
1049 0 : gfc_error ("Syntax error in !$ACC DECLARE list at %C");
1050 :
1051 4 : cleanup:
1052 4 : gfc_current_locus = old_loc;
1053 4 : return MATCH_ERROR;
1054 : }
1055 :
1056 : /* OpenMP clauses. */
1057 : enum omp_mask1
1058 : {
1059 : OMP_CLAUSE_PRIVATE,
1060 : OMP_CLAUSE_FIRSTPRIVATE,
1061 : OMP_CLAUSE_LASTPRIVATE,
1062 : OMP_CLAUSE_COPYPRIVATE,
1063 : OMP_CLAUSE_SHARED,
1064 : OMP_CLAUSE_COPYIN,
1065 : OMP_CLAUSE_REDUCTION,
1066 : OMP_CLAUSE_IN_REDUCTION,
1067 : OMP_CLAUSE_TASK_REDUCTION,
1068 : OMP_CLAUSE_IF,
1069 : OMP_CLAUSE_NUM_THREADS,
1070 : OMP_CLAUSE_SCHEDULE,
1071 : OMP_CLAUSE_DEFAULT,
1072 : OMP_CLAUSE_ORDER,
1073 : OMP_CLAUSE_ORDERED,
1074 : OMP_CLAUSE_COLLAPSE,
1075 : OMP_CLAUSE_UNTIED,
1076 : OMP_CLAUSE_FINAL,
1077 : OMP_CLAUSE_MERGEABLE,
1078 : OMP_CLAUSE_ALIGNED,
1079 : OMP_CLAUSE_DEPEND,
1080 : OMP_CLAUSE_INBRANCH,
1081 : OMP_CLAUSE_LINEAR,
1082 : OMP_CLAUSE_NOTINBRANCH,
1083 : OMP_CLAUSE_PROC_BIND,
1084 : OMP_CLAUSE_SAFELEN,
1085 : OMP_CLAUSE_SIMDLEN,
1086 : OMP_CLAUSE_UNIFORM,
1087 : OMP_CLAUSE_DEVICE,
1088 : OMP_CLAUSE_MAP,
1089 : OMP_CLAUSE_TO,
1090 : OMP_CLAUSE_FROM,
1091 : OMP_CLAUSE_NUM_TEAMS,
1092 : OMP_CLAUSE_THREAD_LIMIT,
1093 : OMP_CLAUSE_DIST_SCHEDULE,
1094 : OMP_CLAUSE_DEFAULTMAP,
1095 : OMP_CLAUSE_GRAINSIZE,
1096 : OMP_CLAUSE_HINT,
1097 : OMP_CLAUSE_IS_DEVICE_PTR,
1098 : OMP_CLAUSE_LINK,
1099 : OMP_CLAUSE_NOGROUP,
1100 : OMP_CLAUSE_NOTEMPORAL,
1101 : OMP_CLAUSE_NUM_TASKS,
1102 : OMP_CLAUSE_PRIORITY,
1103 : OMP_CLAUSE_SIMD,
1104 : OMP_CLAUSE_THREADS,
1105 : OMP_CLAUSE_USE_DEVICE_PTR,
1106 : OMP_CLAUSE_USE_DEVICE_ADDR, /* OpenMP 5.0. */
1107 : OMP_CLAUSE_DEVICE_TYPE, /* OpenMP 5.0. */
1108 : OMP_CLAUSE_ATOMIC, /* OpenMP 5.0. */
1109 : OMP_CLAUSE_CAPTURE, /* OpenMP 5.0. */
1110 : OMP_CLAUSE_MEMORDER, /* OpenMP 5.0. */
1111 : OMP_CLAUSE_DETACH, /* OpenMP 5.0. */
1112 : OMP_CLAUSE_AFFINITY, /* OpenMP 5.0. */
1113 : OMP_CLAUSE_ALLOCATE, /* OpenMP 5.0. */
1114 : OMP_CLAUSE_BIND, /* OpenMP 5.0. */
1115 : OMP_CLAUSE_FILTER, /* OpenMP 5.1. */
1116 : OMP_CLAUSE_AT, /* OpenMP 5.1. */
1117 : OMP_CLAUSE_MESSAGE, /* OpenMP 5.1. */
1118 : OMP_CLAUSE_SEVERITY, /* OpenMP 5.1. */
1119 : OMP_CLAUSE_COMPARE, /* OpenMP 5.1. */
1120 : OMP_CLAUSE_FAIL, /* OpenMP 5.1. */
1121 : OMP_CLAUSE_WEAK, /* OpenMP 5.1. */
1122 : OMP_CLAUSE_NOWAIT,
1123 : /* This must come last. */
1124 : OMP_MASK1_LAST
1125 : };
1126 :
1127 : /* More OpenMP clauses and OpenACC 2.0+ specific clauses. */
1128 : enum omp_mask2
1129 : {
1130 : OMP_CLAUSE_ASYNC,
1131 : OMP_CLAUSE_NUM_GANGS,
1132 : OMP_CLAUSE_NUM_WORKERS,
1133 : OMP_CLAUSE_VECTOR_LENGTH,
1134 : OMP_CLAUSE_COPY,
1135 : OMP_CLAUSE_COPYOUT,
1136 : OMP_CLAUSE_CREATE,
1137 : OMP_CLAUSE_NO_CREATE,
1138 : OMP_CLAUSE_PRESENT,
1139 : OMP_CLAUSE_DEVICEPTR,
1140 : OMP_CLAUSE_GANG,
1141 : OMP_CLAUSE_WORKER,
1142 : OMP_CLAUSE_VECTOR,
1143 : OMP_CLAUSE_SEQ,
1144 : OMP_CLAUSE_INDEPENDENT,
1145 : OMP_CLAUSE_USE_DEVICE,
1146 : OMP_CLAUSE_DEVICE_RESIDENT,
1147 : OMP_CLAUSE_SELF,
1148 : OMP_CLAUSE_HOST,
1149 : OMP_CLAUSE_WAIT,
1150 : OMP_CLAUSE_DELETE,
1151 : OMP_CLAUSE_AUTO,
1152 : OMP_CLAUSE_TILE,
1153 : OMP_CLAUSE_IF_PRESENT,
1154 : OMP_CLAUSE_FINALIZE,
1155 : OMP_CLAUSE_ATTACH,
1156 : OMP_CLAUSE_NOHOST,
1157 : OMP_CLAUSE_HAS_DEVICE_ADDR, /* OpenMP 5.1 */
1158 : OMP_CLAUSE_ENTER, /* OpenMP 5.2 */
1159 : OMP_CLAUSE_DOACROSS, /* OpenMP 5.2 */
1160 : OMP_CLAUSE_ASSUMPTIONS, /* OpenMP 5.1. */
1161 : OMP_CLAUSE_USES_ALLOCATORS, /* OpenMP 5.0 */
1162 : OMP_CLAUSE_INDIRECT, /* OpenMP 5.1 */
1163 : OMP_CLAUSE_FULL, /* OpenMP 5.1. */
1164 : OMP_CLAUSE_PARTIAL, /* OpenMP 5.1. */
1165 : OMP_CLAUSE_SIZES, /* OpenMP 5.1. */
1166 : OMP_CLAUSE_INIT, /* OpenMP 5.1. */
1167 : OMP_CLAUSE_DESTROY, /* OpenMP 5.1. */
1168 : OMP_CLAUSE_USE, /* OpenMP 5.1. */
1169 : OMP_CLAUSE_NOVARIANTS, /* OpenMP 5.1 */
1170 : OMP_CLAUSE_NOCONTEXT, /* OpenMP 5.1 */
1171 : OMP_CLAUSE_INTEROP, /* OpenMP 5.1 */
1172 : OMP_CLAUSE_LOCAL, /* OpenMP 6.0 */
1173 : OMP_CLAUSE_DYN_GROUPPRIVATE, /* OpenMP 6.1 */
1174 : /* This must come last. */
1175 : OMP_MASK2_LAST
1176 : };
1177 :
1178 : struct omp_inv_mask;
1179 :
1180 : /* Customized bitset for up to 128-bits.
1181 : The two enums above provide bit numbers to use, and which of the
1182 : two enums it is determines which of the two mask fields is used.
1183 : Supported operations are defining a mask, like:
1184 : #define XXX_CLAUSES \
1185 : (omp_mask (OMP_CLAUSE_XXX) | OMP_CLAUSE_YYY | OMP_CLAUSE_ZZZ)
1186 : oring such bitsets together or removing selected bits:
1187 : (XXX_CLAUSES | YYY_CLAUSES) & ~(omp_mask (OMP_CLAUSE_VVV))
1188 : and testing individual bits:
1189 : if (mask & OMP_CLAUSE_UUU) */
1190 :
1191 : struct omp_mask {
1192 : const uint64_t mask1;
1193 : const uint64_t mask2;
1194 : inline omp_mask ();
1195 : inline omp_mask (omp_mask1);
1196 : inline omp_mask (omp_mask2);
1197 : inline omp_mask (uint64_t, uint64_t);
1198 : inline omp_mask operator| (omp_mask1) const;
1199 : inline omp_mask operator| (omp_mask2) const;
1200 : inline omp_mask operator| (omp_mask) const;
1201 : inline omp_mask operator& (const omp_inv_mask &) const;
1202 : inline bool operator& (omp_mask1) const;
1203 : inline bool operator& (omp_mask2) const;
1204 : inline omp_inv_mask operator~ () const;
1205 : };
1206 :
1207 : struct omp_inv_mask : public omp_mask {
1208 : inline omp_inv_mask (const omp_mask &);
1209 : };
1210 :
1211 : omp_mask::omp_mask () : mask1 (0), mask2 (0)
1212 : {
1213 : }
1214 :
1215 31919 : omp_mask::omp_mask (omp_mask1 m) : mask1 (((uint64_t) 1) << m), mask2 (0)
1216 : {
1217 : }
1218 :
1219 2205 : omp_mask::omp_mask (omp_mask2 m) : mask1 (0), mask2 (((uint64_t) 1) << m)
1220 : {
1221 : }
1222 :
1223 32827 : omp_mask::omp_mask (uint64_t m1, uint64_t m2) : mask1 (m1), mask2 (m2)
1224 : {
1225 : }
1226 :
1227 : omp_mask
1228 31876 : omp_mask::operator| (omp_mask1 m) const
1229 : {
1230 31876 : return omp_mask (mask1 | (((uint64_t) 1) << m), mask2);
1231 : }
1232 :
1233 : omp_mask
1234 16598 : omp_mask::operator| (omp_mask2 m) const
1235 : {
1236 16598 : return omp_mask (mask1, mask2 | (((uint64_t) 1) << m));
1237 : }
1238 :
1239 : omp_mask
1240 4357 : omp_mask::operator| (omp_mask m) const
1241 : {
1242 4357 : return omp_mask (mask1 | m.mask1, mask2 | m.mask2);
1243 : }
1244 :
1245 : omp_mask
1246 2018 : omp_mask::operator& (const omp_inv_mask &m) const
1247 : {
1248 2018 : return omp_mask (mask1 & ~m.mask1, mask2 & ~m.mask2);
1249 : }
1250 :
1251 : bool
1252 124821 : omp_mask::operator& (omp_mask1 m) const
1253 : {
1254 124821 : return (mask1 & (((uint64_t) 1) << m)) != 0;
1255 : }
1256 :
1257 : bool
1258 88265 : omp_mask::operator& (omp_mask2 m) const
1259 : {
1260 88265 : return (mask2 & (((uint64_t) 1) << m)) != 0;
1261 : }
1262 :
1263 : omp_inv_mask
1264 2018 : omp_mask::operator~ () const
1265 : {
1266 2018 : return omp_inv_mask (*this);
1267 : }
1268 :
1269 2018 : omp_inv_mask::omp_inv_mask (const omp_mask &m) : omp_mask (m)
1270 : {
1271 : }
1272 :
1273 : /* Helper function for OpenACC and OpenMP clauses involving memory
1274 : mapping. */
1275 :
1276 : static bool
1277 5544 : gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op,
1278 : bool allow_common, bool allow_derived)
1279 : {
1280 5544 : gfc_omp_namelist **head = NULL;
1281 5544 : if (gfc_match_omp_variable_list ("", list, allow_common, NULL, &head, true,
1282 : allow_derived)
1283 : == MATCH_YES)
1284 : {
1285 5535 : gfc_omp_namelist *n;
1286 13409 : for (n = *head; n; n = n->next)
1287 7874 : n->u.map.op = map_op;
1288 : return true;
1289 : }
1290 :
1291 : return false;
1292 : }
1293 :
1294 : static match
1295 1114 : gfc_match_iterator (gfc_namespace **ns, bool permit_var)
1296 : {
1297 1114 : locus old_loc = gfc_current_locus;
1298 :
1299 1114 : if (gfc_match ("iterator ( ") != MATCH_YES)
1300 : return MATCH_NO;
1301 :
1302 80 : gfc_typespec ts;
1303 80 : gfc_symbol *last = NULL;
1304 80 : gfc_expr *begin, *end, *step;
1305 80 : *ns = gfc_build_block_ns (gfc_current_ns);
1306 86 : char name[GFC_MAX_SYMBOL_LEN + 1];
1307 92 : while (true)
1308 : {
1309 86 : locus prev_loc = gfc_current_locus;
1310 86 : if (gfc_match_type_spec (&ts) == MATCH_YES
1311 86 : && gfc_match (" :: ") == MATCH_YES)
1312 : {
1313 5 : if (ts.type != BT_INTEGER)
1314 : {
1315 2 : gfc_error ("Expected INTEGER type at %L", &prev_loc);
1316 5 : return MATCH_ERROR;
1317 : }
1318 : permit_var = false;
1319 : }
1320 : else
1321 : {
1322 81 : ts.type = BT_INTEGER;
1323 81 : ts.kind = gfc_default_integer_kind;
1324 81 : gfc_current_locus = prev_loc;
1325 : }
1326 84 : prev_loc = gfc_current_locus;
1327 84 : if (gfc_match_name (name) != MATCH_YES)
1328 : {
1329 4 : gfc_error ("Expected identifier at %C");
1330 4 : goto failed;
1331 : }
1332 80 : if (gfc_find_symtree ((*ns)->sym_root, name))
1333 : {
1334 2 : gfc_error ("Same identifier %qs specified again at %C", name);
1335 2 : goto failed;
1336 : }
1337 :
1338 78 : gfc_symbol *sym = gfc_new_symbol (name, *ns);
1339 78 : if (last)
1340 4 : last->tlink = sym;
1341 : else
1342 74 : (*ns)->omp_affinity_iterators = sym;
1343 78 : last = sym;
1344 78 : sym->declared_at = prev_loc;
1345 78 : sym->ts = ts;
1346 78 : sym->attr.flavor = FL_VARIABLE;
1347 78 : sym->attr.artificial = 1;
1348 78 : sym->attr.referenced = 1;
1349 78 : sym->refs++;
1350 78 : gfc_symtree *st = gfc_new_symtree (&(*ns)->sym_root, name);
1351 78 : st->n.sym = sym;
1352 :
1353 78 : prev_loc = gfc_current_locus;
1354 78 : if (gfc_match (" = ") != MATCH_YES)
1355 3 : goto failed;
1356 75 : permit_var = false;
1357 75 : begin = end = step = NULL;
1358 75 : if (gfc_match ("%e : ", &begin) != MATCH_YES
1359 75 : || gfc_match ("%e ", &end) != MATCH_YES)
1360 : {
1361 3 : gfc_error ("Expected range-specification at %C");
1362 3 : gfc_free_expr (begin);
1363 3 : gfc_free_expr (end);
1364 3 : return MATCH_ERROR;
1365 : }
1366 72 : if (':' == gfc_peek_ascii_char ())
1367 : {
1368 23 : if (gfc_match (": %e ", &step) != MATCH_YES)
1369 : {
1370 5 : gfc_free_expr (begin);
1371 5 : gfc_free_expr (end);
1372 5 : gfc_free_expr (step);
1373 5 : goto failed;
1374 : }
1375 : }
1376 :
1377 67 : gfc_expr *e = gfc_get_expr ();
1378 67 : e->where = prev_loc;
1379 67 : e->expr_type = EXPR_ARRAY;
1380 67 : e->ts = ts;
1381 67 : e->rank = 1;
1382 67 : e->shape = gfc_get_shape (1);
1383 116 : mpz_init_set_ui (e->shape[0], step ? 3 : 2);
1384 67 : gfc_constructor_append_expr (&e->value.constructor, begin, &begin->where);
1385 67 : gfc_constructor_append_expr (&e->value.constructor, end, &end->where);
1386 67 : if (step)
1387 18 : gfc_constructor_append_expr (&e->value.constructor, step, &step->where);
1388 67 : sym->value = e;
1389 :
1390 67 : if (gfc_match (") ") == MATCH_YES)
1391 : break;
1392 6 : if (gfc_match (", ") != MATCH_YES)
1393 0 : goto failed;
1394 6 : }
1395 61 : return MATCH_YES;
1396 :
1397 14 : failed:
1398 14 : gfc_namespace *prev_ns = NULL;
1399 14 : for (gfc_namespace *it = gfc_current_ns->contained; it; it = it->sibling)
1400 : {
1401 0 : if (it == *ns)
1402 : {
1403 0 : if (prev_ns)
1404 0 : prev_ns->sibling = it->sibling;
1405 : else
1406 0 : gfc_current_ns->contained = it->sibling;
1407 0 : gfc_free_namespace (it);
1408 0 : break;
1409 : }
1410 0 : prev_ns = it;
1411 : }
1412 14 : *ns = NULL;
1413 14 : if (!permit_var)
1414 : return MATCH_ERROR;
1415 4 : gfc_current_locus = old_loc;
1416 4 : return MATCH_NO;
1417 : }
1418 :
1419 : /* Match target update's to/from( [present:] var-list). */
1420 :
1421 : static match
1422 1715 : gfc_match_motion_var_list (const char *str, gfc_omp_namelist **list,
1423 : gfc_omp_namelist ***headp)
1424 : {
1425 1715 : match m = gfc_match (str);
1426 1715 : if (m != MATCH_YES)
1427 : return m;
1428 :
1429 1715 : match m_present = gfc_match (" present : ");
1430 :
1431 1715 : m = gfc_match_omp_variable_list ("", list, false, NULL, headp, true, true);
1432 1715 : if (m != MATCH_YES)
1433 : return m;
1434 1715 : if (m_present == MATCH_YES)
1435 : {
1436 5 : gfc_omp_namelist *n;
1437 10 : for (n = **headp; n; n = n->next)
1438 5 : n->u.present_modifier = true;
1439 : }
1440 : return MATCH_YES;
1441 : }
1442 :
1443 : /* reduction ( reduction-modifier, reduction-operator : variable-list )
1444 : in_reduction ( reduction-operator : variable-list )
1445 : task_reduction ( reduction-operator : variable-list ) */
1446 :
1447 : static match
1448 4357 : gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc,
1449 : bool allow_derived, bool openmp_target = false)
1450 : {
1451 4357 : if (pc == 'r' && gfc_match ("reduction ( ") != MATCH_YES)
1452 : return MATCH_NO;
1453 4357 : else if (pc == 'i' && gfc_match ("in_reduction ( ") != MATCH_YES)
1454 : return MATCH_NO;
1455 4245 : else if (pc == 't' && gfc_match ("task_reduction ( ") != MATCH_YES)
1456 : return MATCH_NO;
1457 :
1458 4245 : locus old_loc = gfc_current_locus;
1459 4245 : enum gfc_omp_list_type list_idx = OMP_LIST_NONE;
1460 :
1461 4245 : if (pc == 'r' && !openacc)
1462 : {
1463 2118 : if (gfc_match ("inscan") == MATCH_YES)
1464 : list_idx = OMP_LIST_REDUCTION_INSCAN;
1465 2048 : else if (gfc_match ("task") == MATCH_YES)
1466 : list_idx = OMP_LIST_REDUCTION_TASK;
1467 1943 : else if (gfc_match ("default") == MATCH_YES)
1468 : list_idx = OMP_LIST_REDUCTION;
1469 231 : if (list_idx != OMP_LIST_NONE && gfc_match (", ") != MATCH_YES)
1470 : {
1471 1 : gfc_error ("Comma expected at %C");
1472 1 : gfc_current_locus = old_loc;
1473 1 : return MATCH_NO;
1474 : }
1475 2117 : if (list_idx == OMP_LIST_NONE)
1476 3831 : list_idx = OMP_LIST_REDUCTION;
1477 : }
1478 2127 : else if (pc == 'i')
1479 : list_idx = OMP_LIST_IN_REDUCTION;
1480 2009 : else if (pc == 't')
1481 : list_idx = OMP_LIST_TASK_REDUCTION;
1482 : else
1483 3831 : list_idx = OMP_LIST_REDUCTION;
1484 :
1485 4244 : gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
1486 4244 : char buffer[GFC_MAX_SYMBOL_LEN + 3];
1487 4244 : if (gfc_match_char ('+') == MATCH_YES)
1488 : rop = OMP_REDUCTION_PLUS;
1489 2223 : else if (gfc_match_char ('*') == MATCH_YES)
1490 : rop = OMP_REDUCTION_TIMES;
1491 1991 : else if (gfc_match_char ('-') == MATCH_YES)
1492 : {
1493 171 : if (!openacc)
1494 16 : gfc_warning (OPT_Wdeprecated_openmp,
1495 : "%<-%> operator at %C for reductions deprecated in "
1496 : "OpenMP 5.2");
1497 : rop = OMP_REDUCTION_MINUS;
1498 : }
1499 1820 : else if (gfc_match (".and.") == MATCH_YES)
1500 : rop = OMP_REDUCTION_AND;
1501 1714 : else if (gfc_match (".or.") == MATCH_YES)
1502 : rop = OMP_REDUCTION_OR;
1503 929 : else if (gfc_match (".eqv.") == MATCH_YES)
1504 : rop = OMP_REDUCTION_EQV;
1505 831 : else if (gfc_match (".neqv.") == MATCH_YES)
1506 : rop = OMP_REDUCTION_NEQV;
1507 736 : if (rop != OMP_REDUCTION_NONE)
1508 3508 : snprintf (buffer, sizeof buffer, "operator %s",
1509 : gfc_op2string ((gfc_intrinsic_op) rop));
1510 736 : else if (gfc_match_defined_op_name (buffer + 1, 1) == MATCH_YES)
1511 : {
1512 38 : buffer[0] = '.';
1513 38 : strcat (buffer, ".");
1514 : }
1515 698 : else if (gfc_match_name (buffer) == MATCH_YES)
1516 : {
1517 697 : gfc_symbol *sym;
1518 697 : const char *n = buffer;
1519 :
1520 697 : gfc_find_symbol (buffer, NULL, 1, &sym);
1521 697 : if (sym != NULL)
1522 : {
1523 216 : if (sym->attr.intrinsic)
1524 139 : n = sym->name;
1525 77 : else if ((sym->attr.flavor != FL_UNKNOWN
1526 75 : && sym->attr.flavor != FL_PROCEDURE)
1527 75 : || sym->attr.external
1528 64 : || sym->attr.generic
1529 64 : || sym->attr.entry
1530 64 : || sym->attr.result
1531 64 : || sym->attr.dummy
1532 64 : || sym->attr.subroutine
1533 63 : || sym->attr.pointer
1534 63 : || sym->attr.target
1535 63 : || sym->attr.cray_pointer
1536 63 : || sym->attr.cray_pointee
1537 63 : || (sym->attr.proc != PROC_UNKNOWN
1538 1 : && sym->attr.proc != PROC_INTRINSIC)
1539 62 : || sym->attr.if_source != IFSRC_UNKNOWN
1540 62 : || sym == sym->ns->proc_name)
1541 : {
1542 : sym = NULL;
1543 : n = NULL;
1544 : }
1545 : else
1546 62 : n = sym->name;
1547 : }
1548 201 : if (n == NULL)
1549 : rop = OMP_REDUCTION_NONE;
1550 682 : else if (strcmp (n, "max") == 0)
1551 : rop = OMP_REDUCTION_MAX;
1552 517 : else if (strcmp (n, "min") == 0)
1553 : rop = OMP_REDUCTION_MIN;
1554 376 : else if (strcmp (n, "iand") == 0)
1555 : rop = OMP_REDUCTION_IAND;
1556 321 : else if (strcmp (n, "ior") == 0)
1557 : rop = OMP_REDUCTION_IOR;
1558 255 : else if (strcmp (n, "ieor") == 0)
1559 : rop = OMP_REDUCTION_IEOR;
1560 : if (rop != OMP_REDUCTION_NONE
1561 477 : && sym != NULL
1562 200 : && ! sym->attr.intrinsic
1563 61 : && ! sym->attr.use_assoc
1564 61 : && ((sym->attr.flavor == FL_UNKNOWN
1565 2 : && !gfc_add_flavor (&sym->attr, FL_PROCEDURE,
1566 : sym->name, NULL))
1567 61 : || !gfc_add_intrinsic (&sym->attr, NULL)))
1568 : rop = OMP_REDUCTION_NONE;
1569 : }
1570 : else
1571 1 : buffer[0] = '\0';
1572 4244 : gfc_omp_udr *udr = (buffer[0] ? gfc_find_omp_udr (gfc_current_ns, buffer, NULL)
1573 : : NULL);
1574 4244 : gfc_omp_namelist **head = NULL;
1575 4244 : if (rop == OMP_REDUCTION_NONE && udr)
1576 250 : rop = OMP_REDUCTION_USER;
1577 :
1578 4244 : if (gfc_match_omp_variable_list (" :", &c->lists[list_idx], false, NULL,
1579 : &head, openacc, allow_derived) != MATCH_YES)
1580 : {
1581 9 : gfc_current_locus = old_loc;
1582 9 : return MATCH_NO;
1583 : }
1584 4235 : gfc_omp_namelist *n;
1585 4235 : if (rop == OMP_REDUCTION_NONE)
1586 : {
1587 6 : n = *head;
1588 6 : *head = NULL;
1589 6 : gfc_error_now ("!$OMP DECLARE REDUCTION %s not found at %L",
1590 : buffer, &old_loc);
1591 6 : gfc_free_omp_namelist (n, OMP_LIST_NONE);
1592 : }
1593 : else
1594 9110 : for (n = *head; n; n = n->next)
1595 : {
1596 4881 : n->u.reduction_op = rop;
1597 4881 : if (udr)
1598 : {
1599 473 : n->u2.udr = gfc_get_omp_namelist_udr ();
1600 473 : n->u2.udr->udr = udr;
1601 : }
1602 4881 : if (openmp_target && list_idx == OMP_LIST_IN_REDUCTION)
1603 : {
1604 40 : gfc_omp_namelist *p = gfc_get_omp_namelist (), **tl;
1605 40 : p->sym = n->sym;
1606 40 : p->where = n->where;
1607 40 : p->u.map.op = OMP_MAP_ALWAYS_TOFROM;
1608 :
1609 40 : tl = &c->lists[OMP_LIST_MAP];
1610 52 : while (*tl)
1611 12 : tl = &((*tl)->next);
1612 40 : *tl = p;
1613 40 : p->next = NULL;
1614 : }
1615 : }
1616 : return MATCH_YES;
1617 : }
1618 :
1619 : static match
1620 39 : gfc_omp_absent_contains_clause (gfc_omp_assumptions **assume, bool is_absent)
1621 : {
1622 39 : if (*assume == NULL)
1623 14 : *assume = gfc_get_omp_assumptions ();
1624 61 : do
1625 : {
1626 50 : gfc_statement st = ST_NONE;
1627 50 : gfc_gobble_whitespace ();
1628 50 : locus old_loc = gfc_current_locus;
1629 50 : char c = gfc_peek_ascii_char ();
1630 50 : enum gfc_omp_directive_kind kind
1631 : = GFC_OMP_DIR_DECLARATIVE; /* Silence warning. */
1632 1524 : for (size_t i = 0; i < ARRAY_SIZE (gfc_omp_directives); i++)
1633 : {
1634 1524 : if (gfc_omp_directives[i].name[0] > c)
1635 : break;
1636 1474 : if (gfc_omp_directives[i].name[0] != c)
1637 1135 : continue;
1638 339 : if (gfc_match (gfc_omp_directives[i].name) == MATCH_YES)
1639 : {
1640 50 : st = gfc_omp_directives[i].st;
1641 50 : kind = gfc_omp_directives[i].kind;
1642 : }
1643 : }
1644 50 : gfc_gobble_whitespace ();
1645 50 : c = gfc_peek_ascii_char ();
1646 50 : if (st == ST_NONE || (c != ',' && c != ')'))
1647 : {
1648 0 : if (st == ST_NONE)
1649 0 : gfc_error ("Unknown directive at %L", &old_loc);
1650 : else
1651 0 : gfc_error ("Invalid combined or composite directive at %L",
1652 : &old_loc);
1653 3 : return MATCH_ERROR;
1654 : }
1655 50 : if (kind == GFC_OMP_DIR_DECLARATIVE
1656 50 : || kind == GFC_OMP_DIR_INFORMATIONAL
1657 : || kind == GFC_OMP_DIR_META)
1658 : {
1659 3 : gfc_error ("Invalid %qs directive at %L in %s clause: declarative, "
1660 : "informational, and meta directives not permitted",
1661 : gfc_ascii_statement (st, true), &old_loc,
1662 : is_absent ? "ABSENT" : "CONTAINS");
1663 3 : return MATCH_ERROR;
1664 : }
1665 47 : if (is_absent)
1666 : {
1667 : /* Use exponential allocation; equivalent to pow2p(x). */
1668 33 : int i = (*assume)->n_absent;
1669 33 : int size = ((i == 0) ? 4
1670 10 : : pow2p_hwi (i) == 1 ? i*2 : 0);
1671 8 : if (size != 0)
1672 31 : (*assume)->absent = XRESIZEVEC (gfc_statement,
1673 : (*assume)->absent, size);
1674 33 : (*assume)->absent[(*assume)->n_absent++] = st;
1675 : }
1676 : else
1677 : {
1678 14 : int i = (*assume)->n_contains;
1679 14 : int size = ((i == 0) ? 4
1680 4 : : pow2p_hwi (i) == 1 ? i*2 : 0);
1681 4 : if (size != 0)
1682 14 : (*assume)->contains = XRESIZEVEC (gfc_statement,
1683 : (*assume)->contains, size);
1684 14 : (*assume)->contains[(*assume)->n_contains++] = st;
1685 : }
1686 47 : gfc_gobble_whitespace ();
1687 47 : if (gfc_match(",") == MATCH_YES)
1688 11 : continue;
1689 36 : if (gfc_match(")") == MATCH_YES)
1690 : break;
1691 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
1692 0 : return MATCH_ERROR;
1693 : }
1694 : while (true);
1695 :
1696 36 : return MATCH_YES;
1697 : }
1698 :
1699 : /* Check 'check' argument for duplicated statements in absent and/or contains
1700 : clauses. If 'merge', merge them from check to 'merge'. */
1701 :
1702 : static match
1703 43 : omp_verify_merge_absent_contains (gfc_statement st, gfc_omp_assumptions *check,
1704 : gfc_omp_assumptions *merge, locus *loc)
1705 : {
1706 43 : if (check == NULL)
1707 : return MATCH_YES;
1708 43 : bitmap_head absent_head, contains_head;
1709 43 : bitmap_obstack_initialize (NULL);
1710 43 : bitmap_initialize (&absent_head, &bitmap_default_obstack);
1711 43 : bitmap_initialize (&contains_head, &bitmap_default_obstack);
1712 :
1713 43 : match m = MATCH_YES;
1714 76 : for (int i = 0; i < check->n_absent; i++)
1715 33 : if (!bitmap_set_bit (&absent_head, check->absent[i]))
1716 : {
1717 2 : gfc_error ("%qs directive mentioned multiple times in %s clause in %s "
1718 : "directive at %L",
1719 2 : gfc_ascii_statement (check->absent[i], true),
1720 : "ABSENT", gfc_ascii_statement (st), loc);
1721 2 : m = MATCH_ERROR;
1722 : }
1723 57 : for (int i = 0; i < check->n_contains; i++)
1724 : {
1725 14 : if (!bitmap_set_bit (&contains_head, check->contains[i]))
1726 : {
1727 2 : gfc_error ("%qs directive mentioned multiple times in %s clause in %s "
1728 : "directive at %L",
1729 2 : gfc_ascii_statement (check->contains[i], true),
1730 : "CONTAINS", gfc_ascii_statement (st), loc);
1731 2 : m = MATCH_ERROR;
1732 : }
1733 14 : if (bitmap_bit_p (&absent_head, check->contains[i]))
1734 : {
1735 2 : gfc_error ("%qs directive mentioned both times in ABSENT and CONTAINS "
1736 : "clauses in %s directive at %L",
1737 2 : gfc_ascii_statement (check->absent[i], true),
1738 : gfc_ascii_statement (st), loc);
1739 2 : m = MATCH_ERROR;
1740 : }
1741 : }
1742 :
1743 43 : if (m == MATCH_ERROR)
1744 : return MATCH_ERROR;
1745 37 : if (merge == NULL)
1746 : return MATCH_YES;
1747 2 : if (merge->absent == NULL && check->absent)
1748 : {
1749 1 : merge->n_absent = check->n_absent;
1750 1 : merge->absent = check->absent;
1751 1 : check->absent = NULL;
1752 : }
1753 1 : else if (merge->absent && check->absent)
1754 : {
1755 0 : check->absent = XRESIZEVEC (gfc_statement, check->absent,
1756 : merge->n_absent + check->n_absent);
1757 0 : for (int i = 0; i < merge->n_absent; i++)
1758 0 : if (!bitmap_bit_p (&absent_head, merge->absent[i]))
1759 0 : check->absent[check->n_absent++] = merge->absent[i];
1760 0 : free (merge->absent);
1761 0 : merge->absent = check->absent;
1762 0 : merge->n_absent = check->n_absent;
1763 0 : check->absent = NULL;
1764 : }
1765 2 : if (merge->contains == NULL && check->contains)
1766 : {
1767 0 : merge->n_contains = check->n_contains;
1768 0 : merge->contains = check->contains;
1769 0 : check->contains = NULL;
1770 : }
1771 2 : else if (merge->contains && check->contains)
1772 : {
1773 0 : check->contains = XRESIZEVEC (gfc_statement, check->contains,
1774 : merge->n_contains + check->n_contains);
1775 0 : for (int i = 0; i < merge->n_contains; i++)
1776 0 : if (!bitmap_bit_p (&contains_head, merge->contains[i]))
1777 0 : check->contains[check->n_contains++] = merge->contains[i];
1778 0 : free (merge->contains);
1779 0 : merge->contains = check->contains;
1780 0 : merge->n_contains = check->n_contains;
1781 0 : check->contains = NULL;
1782 : }
1783 : return MATCH_YES;
1784 : }
1785 :
1786 : /* OpenMP 5.0
1787 : uses_allocators ( allocator-list )
1788 :
1789 : allocator:
1790 : predefined-allocator
1791 : variable ( traits-array )
1792 :
1793 : OpenMP 5.2 deprecated, 6.0 deleted: 'variable ( traits-array )'
1794 :
1795 : OpenMP 5.2:
1796 : uses_allocators ( [modifier-list :] allocator-list )
1797 :
1798 : OpenMP 6.0:
1799 : uses_allocators ( [modifier-list :] allocator-list [; ...])
1800 :
1801 : allocator:
1802 : variable or predefined-allocator
1803 : modifier:
1804 : traits ( traits-array )
1805 : memspace ( mem-space-handle ) */
1806 :
1807 : static match
1808 56 : gfc_match_omp_clause_uses_allocators (gfc_omp_clauses *c)
1809 : {
1810 60 : parse_next:
1811 60 : gfc_symbol *memspace_sym = NULL;
1812 60 : gfc_symbol *traits_sym = NULL;
1813 60 : gfc_omp_namelist *head = NULL;
1814 60 : gfc_omp_namelist *p, *tail, **list;
1815 60 : int ntraits, nmemspace;
1816 60 : bool has_modifiers;
1817 60 : locus old_loc, cur_loc;
1818 :
1819 60 : gfc_gobble_whitespace ();
1820 60 : old_loc = gfc_current_locus;
1821 60 : ntraits = nmemspace = 0;
1822 92 : do
1823 : {
1824 76 : cur_loc = gfc_current_locus;
1825 76 : if (gfc_match ("traits ( %S ) ", &traits_sym) == MATCH_YES)
1826 24 : ntraits++;
1827 52 : else if (gfc_match ("memspace ( %S ) ", &memspace_sym) == MATCH_YES)
1828 23 : nmemspace++;
1829 76 : if (ntraits > 1 || nmemspace > 1)
1830 : {
1831 2 : gfc_error ("Duplicate %s modifier at %L in USES_ALLOCATORS clause",
1832 : ntraits > 1 ? "TRAITS" : "MEMSPACE", &cur_loc);
1833 2 : return MATCH_ERROR;
1834 : }
1835 74 : if (gfc_match (", ") == MATCH_YES)
1836 16 : continue;
1837 58 : if (gfc_match (": ") != MATCH_YES)
1838 : {
1839 : /* Assume no modifier. */
1840 31 : memspace_sym = traits_sym = NULL;
1841 31 : gfc_current_locus = old_loc;
1842 31 : break;
1843 : }
1844 : break;
1845 : } while (true);
1846 :
1847 85 : has_modifiers = traits_sym != NULL || memspace_sym != NULL;
1848 150 : do
1849 : {
1850 104 : p = gfc_get_omp_namelist ();
1851 104 : p->where = gfc_current_locus;
1852 104 : if (head == NULL)
1853 : head = tail = p;
1854 : else
1855 : {
1856 46 : tail->next = p;
1857 46 : tail = tail->next;
1858 : }
1859 104 : if (gfc_match ("%S ", &p->sym) != MATCH_YES)
1860 0 : goto error;
1861 104 : if (!has_modifiers)
1862 : {
1863 72 : if (gfc_match ("( %S ) ", &p->u2.traits_sym) == MATCH_YES)
1864 17 : gfc_warning (OPT_Wdeprecated_openmp,
1865 : "The specification of arguments to "
1866 : "%<uses_allocators%> at %L where each item is of "
1867 : "the form %<allocator(traits)%> is deprecated since "
1868 : "OpenMP 5.2; instead use %<uses_allocators(traits(%s"
1869 17 : "): %s)%>", &p->where, p->u2.traits_sym->name,
1870 17 : p->sym->name);
1871 : }
1872 32 : else if (gfc_peek_ascii_char () == '(')
1873 : {
1874 0 : gfc_error ("Unexpected %<(%> at %C");
1875 0 : goto error;
1876 : }
1877 : else
1878 : {
1879 32 : p->u.memspace_sym = memspace_sym;
1880 32 : p->u2.traits_sym = traits_sym;
1881 : }
1882 104 : gfc_gobble_whitespace ();
1883 104 : const char c = gfc_peek_ascii_char ();
1884 104 : if (c == ';' || c == ')')
1885 : break;
1886 48 : if (c != ',')
1887 : {
1888 2 : gfc_error ("Expected %<,%>, %<)%> or %<;%> at %C");
1889 2 : goto error;
1890 : }
1891 46 : gfc_match_char (',');
1892 46 : gfc_gobble_whitespace ();
1893 46 : } while (true);
1894 :
1895 56 : list = &c->lists[OMP_LIST_USES_ALLOCATORS];
1896 74 : while (*list)
1897 18 : list = &(*list)->next;
1898 56 : *list = head;
1899 :
1900 56 : if (gfc_match_char (';') == MATCH_YES)
1901 4 : goto parse_next;
1902 :
1903 52 : gfc_match_char (')');
1904 52 : return MATCH_YES;
1905 :
1906 2 : error:
1907 2 : gfc_free_omp_namelist (head, OMP_LIST_USES_ALLOCATORS);
1908 2 : return MATCH_ERROR;
1909 : }
1910 :
1911 :
1912 : /* Match the 'prefer_type' modifier of the interop 'init' clause:
1913 : with either OpenMP 5.1's
1914 : prefer_type ( <const-int-expr|string literal> [, ...]
1915 : or
1916 : prefer_type ( '{' <fr(...) | attr (...)>, ...] '}' [, '{' ... '}' ] )
1917 : where 'fr' takes a constant expression or a string literal
1918 : and 'attr takes a list of string literals, starting with 'ompx_')
1919 :
1920 : For the foreign runtime identifiers, string values are converted to
1921 : their integer value; unknown string or integer values are set to
1922 : GOMP_INTEROP_IFR_KNOWN.
1923 :
1924 : Data format:
1925 : For the foreign runtime identifiers, string values are converted to
1926 : their integer value; unknown string or integer values are set to 0.
1927 :
1928 : Each item (a) GOMP_INTEROP_IFR_SEPARATOR
1929 : (b) for any 'fr', its integer value.
1930 : Note: Spec only permits 1 'fr' entry (6.0; changed after TR13)
1931 : (c) GOMP_INTEROP_IFR_SEPARATOR
1932 : (d) list of \0-terminated non-empty strings for 'attr'
1933 : (e) '\0'
1934 : Tailing '\0'. */
1935 :
1936 : static match
1937 82 : gfc_match_omp_prefer_type (char **type_str, int *type_str_len)
1938 : {
1939 82 : gfc_expr *e;
1940 82 : std::string type_string, attr_string;
1941 : /* New syntax. */
1942 82 : if (gfc_peek_ascii_char () == '{')
1943 115 : do
1944 : {
1945 85 : attr_string.clear ();
1946 85 : type_string += (char) GOMP_INTEROP_IFR_SEPARATOR;
1947 85 : if (gfc_match ("{ ") != MATCH_YES)
1948 : {
1949 1 : gfc_error ("Expected %<{%> at %C");
1950 1 : return MATCH_ERROR;
1951 : }
1952 : bool fr_found = false;
1953 148 : do
1954 : {
1955 116 : if (gfc_match ("fr ( ") == MATCH_YES)
1956 : {
1957 62 : if (fr_found)
1958 : {
1959 1 : gfc_error ("Duplicated %<fr%> preference-selector-name "
1960 : "at %C");
1961 1 : return MATCH_ERROR;
1962 : }
1963 61 : fr_found = true;
1964 61 : do
1965 : {
1966 61 : bool found_literal = false;
1967 61 : match m = MATCH_YES;
1968 61 : if (gfc_match_literal_constant (&e, false) == MATCH_YES)
1969 : found_literal = true;
1970 : else
1971 12 : m = gfc_match_expr (&e);
1972 12 : if (m != MATCH_YES
1973 61 : || !gfc_resolve_expr (e)
1974 61 : || e->rank != 0
1975 60 : || e->expr_type != EXPR_CONSTANT
1976 59 : || (e->ts.type != BT_INTEGER
1977 43 : && (!found_literal || e->ts.type != BT_CHARACTER))
1978 58 : || (e->ts.type == BT_INTEGER
1979 16 : && !mpz_fits_sint_p (e->value.integer))
1980 70 : || (e->ts.type == BT_CHARACTER
1981 42 : && (e->ts.kind != gfc_default_character_kind
1982 41 : || e->value.character.length == 0)))
1983 : {
1984 5 : gfc_error ("Expected constant scalar integer expression"
1985 : " or non-empty default-kind character "
1986 5 : "literal at %L", &e->where);
1987 5 : gfc_free_expr (e);
1988 5 : return MATCH_ERROR;
1989 : }
1990 56 : gfc_gobble_whitespace ();
1991 56 : int val;
1992 56 : if (e->ts.type == BT_INTEGER)
1993 : {
1994 16 : val = mpz_get_si (e->value.integer);
1995 16 : if (val < 1 || val > GOMP_INTEROP_IFR_LAST)
1996 : {
1997 0 : gfc_warning_now (OPT_Wopenmp,
1998 : "Unknown foreign runtime "
1999 : "identifier %qd at %L",
2000 : val, &e->where);
2001 0 : val = GOMP_INTEROP_IFR_UNKNOWN;
2002 : }
2003 : }
2004 : else
2005 : {
2006 40 : char *str = XALLOCAVEC (char,
2007 : e->value.character.length+1);
2008 229 : for (int i = 0; i < e->value.character.length + 1; i++)
2009 189 : str[i] = e->value.character.string[i];
2010 40 : if (memchr (str, '\0', e->value.character.length) != 0)
2011 : {
2012 0 : gfc_error ("Unexpected null character in character "
2013 : "literal at %L", &e->where);
2014 0 : return MATCH_ERROR;
2015 : }
2016 40 : val = omp_get_fr_id_from_name (str);
2017 40 : if (val == GOMP_INTEROP_IFR_UNKNOWN)
2018 2 : gfc_warning_now (OPT_Wopenmp,
2019 : "Unknown foreign runtime identifier "
2020 2 : "%qs at %L", str, &e->where);
2021 : }
2022 :
2023 56 : type_string += (char) val;
2024 56 : if (gfc_match (") ") == MATCH_YES)
2025 : break;
2026 4 : gfc_error ("Expected %<)%> at %C");
2027 4 : return MATCH_ERROR;
2028 : }
2029 : while (true);
2030 : }
2031 54 : else if (gfc_match ("attr ( ") == MATCH_YES)
2032 : {
2033 60 : do
2034 : {
2035 57 : if (gfc_match_literal_constant (&e, false) != MATCH_YES
2036 56 : || !gfc_resolve_expr (e)
2037 56 : || e->expr_type != EXPR_CONSTANT
2038 56 : || e->rank != 0
2039 56 : || e->ts.type != BT_CHARACTER
2040 113 : || e->ts.kind != gfc_default_character_kind)
2041 : {
2042 1 : gfc_error ("Expected default-kind character literal "
2043 1 : "at %L", &e->where);
2044 1 : gfc_free_expr (e);
2045 1 : return MATCH_ERROR;
2046 : }
2047 56 : gfc_gobble_whitespace ();
2048 56 : char *str = XALLOCAVEC (char, e->value.character.length+1);
2049 564 : for (int i = 0; i < e->value.character.length + 1; i++)
2050 508 : str[i] = e->value.character.string[i];
2051 56 : if (!startswith (str, "ompx_"))
2052 : {
2053 1 : gfc_error ("Character literal at %L must start with "
2054 : "%<ompx_%>", &e->where);
2055 1 : gfc_free_expr (e);
2056 1 : return MATCH_ERROR;
2057 : }
2058 55 : if (memchr (str, '\0', e->value.character.length) != 0
2059 55 : || memchr (str, ',', e->value.character.length) != 0)
2060 : {
2061 1 : gfc_error ("Unexpected null or %<,%> character in "
2062 : "character literal at %L", &e->where);
2063 1 : return MATCH_ERROR;
2064 : }
2065 54 : attr_string += str;
2066 54 : attr_string += '\0';
2067 54 : if (gfc_match (", ") == MATCH_YES)
2068 3 : continue;
2069 51 : if (gfc_match (") ") == MATCH_YES)
2070 : break;
2071 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
2072 0 : return MATCH_ERROR;
2073 3 : }
2074 : while (true);
2075 : }
2076 : else
2077 : {
2078 0 : gfc_error ("Expected %<fr(%> or %<attr(%> at %C");
2079 0 : return MATCH_ERROR;
2080 : }
2081 103 : if (gfc_match (", ") == MATCH_YES)
2082 32 : continue;
2083 71 : if (gfc_match ("} ") == MATCH_YES)
2084 : break;
2085 2 : gfc_error ("Expected %<,%> or %<}%> at %C");
2086 2 : return MATCH_ERROR;
2087 32 : }
2088 : while (true);
2089 69 : type_string += (char) GOMP_INTEROP_IFR_SEPARATOR;
2090 69 : type_string += attr_string;
2091 69 : type_string += '\0';
2092 69 : if (gfc_match (", ") == MATCH_YES)
2093 30 : continue;
2094 39 : if (gfc_match (") ") == MATCH_YES)
2095 : break;
2096 1 : gfc_error ("Expected %<,%> or %<)%> at %C");
2097 1 : return MATCH_ERROR;
2098 30 : }
2099 : while (true);
2100 : else
2101 75 : do
2102 : {
2103 51 : type_string += (char) GOMP_INTEROP_IFR_SEPARATOR;
2104 51 : bool found_literal = false;
2105 51 : match m = MATCH_YES;
2106 51 : if (gfc_match_literal_constant (&e, false) == MATCH_YES)
2107 : found_literal = true;
2108 : else
2109 19 : m = gfc_match_expr (&e);
2110 19 : if (m != MATCH_YES
2111 51 : || !gfc_resolve_expr (e)
2112 51 : || e->rank != 0
2113 50 : || e->expr_type != EXPR_CONSTANT
2114 49 : || (e->ts.type != BT_INTEGER
2115 28 : && (!found_literal || e->ts.type != BT_CHARACTER))
2116 48 : || (e->ts.type == BT_INTEGER
2117 21 : && !mpz_fits_sint_p (e->value.integer))
2118 67 : || (e->ts.type == BT_CHARACTER
2119 27 : && (e->ts.kind != gfc_default_character_kind
2120 27 : || e->value.character.length == 0)))
2121 : {
2122 3 : gfc_error ("Expected constant scalar integer expression or "
2123 3 : "non-empty default-kind character literal at %L", &e->where);
2124 3 : gfc_free_expr (e);
2125 3 : return MATCH_ERROR;
2126 : }
2127 48 : gfc_gobble_whitespace ();
2128 48 : int val;
2129 48 : if (e->ts.type == BT_INTEGER)
2130 : {
2131 21 : val = mpz_get_si (e->value.integer);
2132 21 : if (val < 1 || val > GOMP_INTEROP_IFR_LAST)
2133 : {
2134 3 : gfc_warning_now (OPT_Wopenmp,
2135 : "Unknown foreign runtime identifier %qd at %L",
2136 : val, &e->where);
2137 3 : val = 0;
2138 : }
2139 : }
2140 : else
2141 : {
2142 27 : char *str = XALLOCAVEC (char, e->value.character.length+1);
2143 169 : for (int i = 0; i < e->value.character.length + 1; i++)
2144 142 : str[i] = e->value.character.string[i];
2145 27 : if (memchr (str, '\0', e->value.character.length) != 0)
2146 : {
2147 0 : gfc_error ("Unexpected null character in character "
2148 : "literal at %L", &e->where);
2149 0 : return MATCH_ERROR;
2150 : }
2151 27 : val = omp_get_fr_id_from_name (str);
2152 27 : if (val == GOMP_INTEROP_IFR_UNKNOWN)
2153 5 : gfc_warning_now (OPT_Wopenmp,
2154 : "Unknown foreign runtime identifier %qs at %L",
2155 5 : str, &e->where);
2156 : }
2157 48 : type_string += (char) val;
2158 48 : type_string += (char) GOMP_INTEROP_IFR_SEPARATOR;
2159 48 : type_string += '\0';
2160 48 : gfc_free_expr (e);
2161 48 : if (gfc_match (", ") == MATCH_YES)
2162 24 : continue;
2163 24 : if (gfc_match (") ") == MATCH_YES)
2164 : break;
2165 2 : gfc_error ("Expected %<,%> or %<)%> at %C");
2166 2 : return MATCH_ERROR;
2167 24 : }
2168 : while (true);
2169 60 : type_string += '\0';
2170 60 : *type_str_len = type_string.length();
2171 60 : *type_str = XNEWVEC (char, type_string.length ());
2172 60 : memcpy (*type_str, type_string.data (), type_string.length ());
2173 60 : return MATCH_YES;
2174 82 : }
2175 :
2176 :
2177 : /* Match OpenMP 5.1's 'init'-clause modifiers, used by the 'init' clause of
2178 : the 'interop' directive and the 'append_args' directive of 'declare variant'.
2179 : [prefer_type(...)][,][<target|targetsync>, ...])
2180 :
2181 : If is_init_clause, the modifier parsing ends with a ':'.
2182 : If not is_init_clause (i.e. append_args), the parsing ends with ')'. */
2183 :
2184 : static match
2185 164 : gfc_parser_omp_clause_init_modifiers (bool &target, bool &targetsync,
2186 : char **type_str, int &type_str_len,
2187 : bool is_init_clause)
2188 : {
2189 164 : target = false;
2190 164 : targetsync = false;
2191 164 : *type_str = NULL;
2192 164 : type_str_len = 0;
2193 286 : match m;
2194 :
2195 286 : do
2196 : {
2197 286 : if (gfc_match ("prefer_type ( ") == MATCH_YES)
2198 : {
2199 83 : if (*type_str)
2200 : {
2201 1 : gfc_error ("Duplicate %<prefer_type%> modifier at %C");
2202 1 : return MATCH_ERROR;
2203 : }
2204 82 : m = gfc_match_omp_prefer_type (type_str, &type_str_len);
2205 82 : if (m != MATCH_YES)
2206 : return m;
2207 60 : if (gfc_match (", ") == MATCH_YES)
2208 14 : continue;
2209 46 : if (is_init_clause)
2210 : {
2211 24 : if (gfc_match (": ") == MATCH_YES)
2212 : break;
2213 0 : gfc_error ("Expected %<,%> or %<:%> at %C");
2214 : }
2215 : else
2216 : {
2217 22 : if (gfc_match (") ") == MATCH_YES)
2218 : break;
2219 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
2220 : }
2221 0 : return MATCH_ERROR;
2222 : }
2223 :
2224 203 : if (gfc_match ("prefer_type ") == MATCH_YES)
2225 : {
2226 2 : gfc_error ("Expected %<(%> after %<prefer_type%> at %C");
2227 2 : return MATCH_ERROR;
2228 : }
2229 :
2230 201 : if (gfc_match ("targetsync ") == MATCH_YES)
2231 : {
2232 57 : if (targetsync)
2233 : {
2234 3 : gfc_error ("Duplicate %<targetsync%> at %C");
2235 3 : return MATCH_ERROR;
2236 : }
2237 54 : targetsync = true;
2238 54 : if (gfc_match (", ") == MATCH_YES)
2239 13 : continue;
2240 41 : if (!is_init_clause)
2241 : {
2242 23 : if (gfc_match (") ") == MATCH_YES)
2243 : break;
2244 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
2245 0 : return MATCH_ERROR;
2246 : }
2247 18 : if (gfc_match (": ") == MATCH_YES)
2248 : break;
2249 1 : gfc_error ("Expected %<,%> or %<:%> at %C");
2250 1 : return MATCH_ERROR;
2251 : }
2252 144 : if (gfc_match ("target ") == MATCH_YES)
2253 : {
2254 135 : if (target)
2255 : {
2256 3 : gfc_error ("Duplicate %<target%> at %C");
2257 3 : return MATCH_ERROR;
2258 : }
2259 132 : target = true;
2260 132 : if (gfc_match (", ") == MATCH_YES)
2261 95 : continue;
2262 37 : if (!is_init_clause)
2263 : {
2264 11 : if (gfc_match (") ") == MATCH_YES)
2265 : break;
2266 0 : gfc_error ("Expected %<,%> or %<)%> at %C");
2267 0 : return MATCH_ERROR;
2268 : }
2269 26 : if (gfc_match (": ") == MATCH_YES)
2270 : break;
2271 1 : gfc_error ("Expected %<,%> or %<:%> at %C");
2272 1 : return MATCH_ERROR;
2273 : }
2274 9 : gfc_error ("Expected %<prefer_type%>, %<target%>, or %<targetsync%> "
2275 : "at %C");
2276 9 : return MATCH_ERROR;
2277 : }
2278 : while (true);
2279 :
2280 122 : if (!target && !targetsync)
2281 : {
2282 4 : gfc_error ("Missing required %<target%> and/or %<targetsync%> "
2283 : "modifier at %C");
2284 4 : return MATCH_ERROR;
2285 : }
2286 : return MATCH_YES;
2287 : }
2288 :
2289 : /* Match OpenMP 5.1's 'init' clause for 'interop' objects:
2290 : init([prefer_type(...)][,][<target|targetsync>, ...] :] interop-obj-list) */
2291 :
2292 : static match
2293 108 : gfc_match_omp_init (gfc_omp_namelist **list)
2294 : {
2295 108 : bool target, targetsync;
2296 108 : char *type_str = NULL;
2297 108 : int type_str_len;
2298 108 : if (gfc_parser_omp_clause_init_modifiers (target, targetsync, &type_str,
2299 : type_str_len, true) == MATCH_ERROR)
2300 : return MATCH_ERROR;
2301 :
2302 64 : gfc_omp_namelist **head = NULL;
2303 64 : if (gfc_match_omp_variable_list ("", list, false, NULL, &head) != MATCH_YES)
2304 : return MATCH_ERROR;
2305 147 : for (gfc_omp_namelist *n = *head; n; n = n->next)
2306 : {
2307 84 : n->u.init.target = target;
2308 84 : n->u.init.targetsync = targetsync;
2309 84 : n->u.init.len = type_str_len;
2310 84 : n->u2.init_interop = type_str;
2311 : }
2312 : return MATCH_YES;
2313 : }
2314 :
2315 :
2316 : /* Match with duplicate check. Matches 'name'. If expr != NULL, it
2317 : then matches '(expr)', otherwise, if open_parens is true,
2318 : it matches a ' ( ' after 'name'.
2319 : dupl_message requires '%qs %L' - and is used by
2320 : gfc_match_dupl_memorder and gfc_match_dupl_atomic. */
2321 :
2322 : static match
2323 22380 : gfc_match_dupl_check (bool not_dupl, const char *name, bool open_parens = false,
2324 : gfc_expr **expr = NULL, const char *dupl_msg = NULL)
2325 : {
2326 22380 : match m;
2327 22380 : char c;
2328 22380 : locus old_loc = gfc_current_locus;
2329 22380 : if ((m = gfc_match (name)) != MATCH_YES)
2330 : return m;
2331 : /* Ensure that no partial string is matched. */
2332 17417 : if (gfc_current_form == FORM_FREE
2333 16919 : && gfc_match_eos () != MATCH_YES
2334 30200 : && ((c = gfc_peek_ascii_char ()) == '_' || ISALNUM (c)))
2335 : {
2336 8 : gfc_current_locus = old_loc;
2337 8 : return MATCH_NO;
2338 : }
2339 17409 : if (!not_dupl)
2340 : {
2341 44 : if (dupl_msg)
2342 2 : gfc_error (dupl_msg, name, &old_loc);
2343 : else
2344 42 : gfc_error ("Duplicated %qs clause at %L", name, &old_loc);
2345 44 : return MATCH_ERROR;
2346 : }
2347 17365 : if (open_parens || expr)
2348 : {
2349 9475 : if (gfc_match (" ( ") != MATCH_YES)
2350 : {
2351 22 : gfc_error ("Expected %<(%> after %qs at %C", name);
2352 22 : return MATCH_ERROR;
2353 : }
2354 9453 : if (expr)
2355 : {
2356 4419 : if (gfc_match ("%e )", expr) != MATCH_YES)
2357 : {
2358 9 : gfc_error ("Invalid expression after %<%s(%> at %C", name);
2359 9 : return MATCH_ERROR;
2360 : }
2361 : }
2362 : }
2363 : return MATCH_YES;
2364 : }
2365 :
2366 : static match
2367 211 : gfc_match_dupl_memorder (bool not_dupl, const char *name)
2368 : {
2369 0 : return gfc_match_dupl_check (not_dupl, name, false, NULL,
2370 : "Duplicated memory-order clause: unexpected %s "
2371 0 : "clause at %L");
2372 : }
2373 :
2374 : static match
2375 1175 : gfc_match_dupl_atomic (bool not_dupl, const char *name)
2376 : {
2377 0 : return gfc_match_dupl_check (not_dupl, name, false, NULL,
2378 : "Duplicated atomic clause: unexpected %s "
2379 0 : "clause at %L");
2380 : }
2381 :
2382 : /* Match OpenMP and OpenACC directive clauses. MASK is a bitmask of
2383 : clauses that are allowed for a particular directive. */
2384 :
2385 : static match
2386 34124 : gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
2387 : bool first = true, bool needs_space = true,
2388 : bool openacc = false, bool openmp_target = false)
2389 : {
2390 34124 : bool error = false;
2391 34124 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
2392 34124 : locus old_loc;
2393 : /* Determine whether we're dealing with an OpenACC directive that permits
2394 : derived type member accesses. This in particular disallows
2395 : "!$acc declare" from using such accesses, because it's not clear if/how
2396 : that should work. */
2397 34124 : bool allow_derived = (openacc
2398 34124 : && ((mask & OMP_CLAUSE_ATTACH)
2399 5933 : || (mask & OMP_CLAUSE_DETACH)));
2400 :
2401 34124 : gcc_checking_assert (OMP_MASK1_LAST <= 64 && OMP_MASK2_LAST <= 64);
2402 34124 : *cp = NULL;
2403 125046 : while (1)
2404 : {
2405 79585 : match m = MATCH_NO;
2406 59231 : if ((first || (m = gfc_match_char (',')) != MATCH_YES)
2407 138460 : && (needs_space && gfc_match_space () != MATCH_YES))
2408 : break;
2409 75037 : needs_space = false;
2410 75037 : first = false;
2411 75037 : gfc_gobble_whitespace ();
2412 75037 : bool end_colon;
2413 75037 : gfc_omp_namelist **head;
2414 75037 : old_loc = gfc_current_locus;
2415 75037 : char pc = gfc_peek_ascii_char ();
2416 75037 : if (pc == '\n' && m == MATCH_YES)
2417 : {
2418 1 : gfc_error ("Clause expected at %C after trailing comma");
2419 1 : goto error;
2420 : }
2421 75036 : switch (pc)
2422 : {
2423 1312 : case 'a':
2424 1312 : end_colon = false;
2425 1312 : head = NULL;
2426 1336 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
2427 1312 : && gfc_match ("absent ( ") == MATCH_YES)
2428 : {
2429 27 : if (gfc_omp_absent_contains_clause (&c->assume, true)
2430 : != MATCH_YES)
2431 3 : goto error;
2432 24 : continue;
2433 : }
2434 1285 : if ((mask & OMP_CLAUSE_ALIGNED)
2435 1285 : && gfc_match_omp_variable_list ("aligned (",
2436 : &c->lists[OMP_LIST_ALIGNED],
2437 : false, &end_colon,
2438 : &head) == MATCH_YES)
2439 : {
2440 112 : gfc_expr *alignment = NULL;
2441 112 : gfc_omp_namelist *n;
2442 :
2443 112 : if (end_colon && gfc_match (" %e )", &alignment) != MATCH_YES)
2444 : {
2445 0 : gfc_free_omp_namelist (*head, OMP_LIST_ALIGNED);
2446 0 : gfc_current_locus = old_loc;
2447 0 : *head = NULL;
2448 0 : break;
2449 : }
2450 268 : for (n = *head; n; n = n->next)
2451 156 : if (n->next && alignment)
2452 42 : n->expr = gfc_copy_expr (alignment);
2453 : else
2454 114 : n->expr = alignment;
2455 112 : continue;
2456 112 : }
2457 1183 : if ((mask & OMP_CLAUSE_MEMORDER)
2458 1190 : && (m = gfc_match_dupl_memorder ((c->memorder
2459 17 : == OMP_MEMORDER_UNSET),
2460 : "acq_rel")) != MATCH_NO)
2461 : {
2462 10 : if (m == MATCH_ERROR)
2463 0 : goto error;
2464 10 : c->memorder = OMP_MEMORDER_ACQ_REL;
2465 10 : continue;
2466 : }
2467 1170 : if ((mask & OMP_CLAUSE_MEMORDER)
2468 1170 : && (m = gfc_match_dupl_memorder ((c->memorder
2469 7 : == OMP_MEMORDER_UNSET),
2470 : "acquire")) != MATCH_NO)
2471 : {
2472 7 : if (m == MATCH_ERROR)
2473 0 : goto error;
2474 7 : c->memorder = OMP_MEMORDER_ACQUIRE;
2475 7 : continue;
2476 : }
2477 1156 : if ((mask & OMP_CLAUSE_AFFINITY)
2478 1156 : && gfc_match ("affinity ( ") == MATCH_YES)
2479 : {
2480 41 : gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
2481 41 : m = gfc_match_iterator (&ns_iter, true);
2482 41 : if (m == MATCH_ERROR)
2483 : break;
2484 31 : if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES)
2485 : {
2486 1 : gfc_error ("Expected %<:%> at %C");
2487 1 : break;
2488 : }
2489 30 : if (ns_iter)
2490 18 : gfc_current_ns = ns_iter;
2491 30 : head = NULL;
2492 30 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_AFFINITY],
2493 : false, NULL, &head, true);
2494 30 : gfc_current_ns = ns_curr;
2495 30 : if (m == MATCH_ERROR)
2496 : break;
2497 27 : if (ns_iter)
2498 : {
2499 45 : for (gfc_omp_namelist *n = *head; n; n = n->next)
2500 : {
2501 27 : n->u2.ns = ns_iter;
2502 27 : ns_iter->refs++;
2503 : }
2504 : }
2505 27 : continue;
2506 27 : }
2507 1115 : if ((mask & OMP_CLAUSE_ALLOCATE)
2508 1115 : && gfc_match ("allocate ( ") == MATCH_YES)
2509 : {
2510 279 : gfc_expr *allocator = NULL;
2511 279 : gfc_expr *align = NULL;
2512 279 : old_loc = gfc_current_locus;
2513 279 : if ((m = gfc_match ("allocator ( %e )", &allocator)) == MATCH_YES)
2514 50 : gfc_match (" , align ( %e )", &align);
2515 229 : else if ((m = gfc_match ("align ( %e )", &align)) == MATCH_YES)
2516 29 : gfc_match (" , allocator ( %e )", &allocator);
2517 :
2518 279 : if (m == MATCH_YES)
2519 : {
2520 79 : if (gfc_match (" : ") != MATCH_YES)
2521 : {
2522 5 : gfc_error ("Expected %<:%> at %C");
2523 8 : goto error;
2524 : }
2525 : }
2526 : else
2527 : {
2528 200 : m = gfc_match_expr (&allocator);
2529 200 : if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES)
2530 : {
2531 : /* If no ":" then there is no allocator, we backtrack
2532 : and read the variable list. */
2533 101 : gfc_free_expr (allocator);
2534 101 : allocator = NULL;
2535 101 : gfc_current_locus = old_loc;
2536 : }
2537 : }
2538 274 : gfc_omp_namelist **head = NULL;
2539 274 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_ALLOCATE],
2540 : true, NULL, &head);
2541 :
2542 274 : if (m != MATCH_YES)
2543 : {
2544 3 : gfc_free_expr (allocator);
2545 3 : gfc_free_expr (align);
2546 3 : gfc_error ("Expected variable list at %C");
2547 3 : goto error;
2548 : }
2549 :
2550 725 : for (gfc_omp_namelist *n = *head; n; n = n->next)
2551 : {
2552 454 : n->u2.allocator = allocator;
2553 454 : n->u.align = (align) ? gfc_copy_expr (align) : NULL;
2554 : }
2555 271 : gfc_free_expr (align);
2556 271 : continue;
2557 271 : }
2558 896 : if ((mask & OMP_CLAUSE_AT)
2559 836 : && (m = gfc_match_dupl_check (c->at == OMP_AT_UNSET, "at", true))
2560 : != MATCH_NO)
2561 : {
2562 66 : if (m == MATCH_ERROR)
2563 2 : goto error;
2564 64 : if (gfc_match ("compilation )") == MATCH_YES)
2565 15 : c->at = OMP_AT_COMPILATION;
2566 49 : else if (gfc_match ("execution )") == MATCH_YES)
2567 45 : c->at = OMP_AT_EXECUTION;
2568 : else
2569 : {
2570 4 : gfc_error ("Expected COMPILATION or EXECUTION in AT clause "
2571 : "at %C");
2572 4 : goto error;
2573 : }
2574 60 : continue;
2575 : }
2576 1413 : if ((mask & OMP_CLAUSE_ASYNC)
2577 770 : && (m = gfc_match_dupl_check (!c->async, "async")) != MATCH_NO)
2578 : {
2579 643 : if (m == MATCH_ERROR)
2580 0 : goto error;
2581 643 : c->async = true;
2582 643 : m = gfc_match (" ( %e )", &c->async_expr);
2583 643 : if (m == MATCH_ERROR)
2584 : {
2585 0 : gfc_current_locus = old_loc;
2586 0 : break;
2587 : }
2588 643 : else if (m == MATCH_NO)
2589 : {
2590 133 : c->async_expr
2591 133 : = gfc_get_constant_expr (BT_INTEGER,
2592 : gfc_default_integer_kind,
2593 : &gfc_current_locus);
2594 133 : mpz_set_si (c->async_expr->value.integer, GOMP_ASYNC_NOVAL);
2595 : }
2596 643 : continue;
2597 : }
2598 190 : if ((mask & OMP_CLAUSE_AUTO)
2599 127 : && (m = gfc_match_dupl_check (!c->par_auto, "auto"))
2600 : != MATCH_NO)
2601 : {
2602 63 : if (m == MATCH_ERROR)
2603 0 : goto error;
2604 63 : c->par_auto = true;
2605 63 : continue;
2606 : }
2607 125 : if ((mask & OMP_CLAUSE_ATTACH)
2608 62 : && gfc_match ("attach ( ") == MATCH_YES
2609 125 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2610 : OMP_MAP_ATTACH, false,
2611 : allow_derived))
2612 61 : continue;
2613 : break;
2614 36 : case 'b':
2615 70 : if ((mask & OMP_CLAUSE_BIND)
2616 36 : && (m = gfc_match_dupl_check (c->bind == OMP_BIND_UNSET, "bind",
2617 : true)) != MATCH_NO)
2618 : {
2619 36 : if (m == MATCH_ERROR)
2620 1 : goto error;
2621 35 : if (gfc_match ("teams )") == MATCH_YES)
2622 11 : c->bind = OMP_BIND_TEAMS;
2623 24 : else if (gfc_match ("parallel )") == MATCH_YES)
2624 15 : c->bind = OMP_BIND_PARALLEL;
2625 9 : else if (gfc_match ("thread )") == MATCH_YES)
2626 8 : c->bind = OMP_BIND_THREAD;
2627 : else
2628 : {
2629 1 : gfc_error ("Expected TEAMS, PARALLEL or THREAD as binding in "
2630 : "BIND at %C");
2631 1 : break;
2632 : }
2633 34 : continue;
2634 : }
2635 : break;
2636 7109 : case 'c':
2637 7382 : if ((mask & OMP_CLAUSE_CAPTURE)
2638 7109 : && (m = gfc_match_dupl_check (!c->capture, "capture"))
2639 : != MATCH_NO)
2640 : {
2641 274 : if (m == MATCH_ERROR)
2642 1 : goto error;
2643 273 : c->capture = true;
2644 273 : continue;
2645 : }
2646 6835 : if (mask & OMP_CLAUSE_COLLAPSE)
2647 : {
2648 1996 : gfc_expr *cexpr = NULL;
2649 1996 : if ((m = gfc_match_dupl_check (!c->collapse, "collapse", true,
2650 : &cexpr)) != MATCH_NO)
2651 : {
2652 1506 : int collapse;
2653 1506 : if (m == MATCH_ERROR)
2654 0 : goto error;
2655 1506 : if (gfc_extract_int (cexpr, &collapse, -1))
2656 4 : collapse = 1;
2657 1502 : else if (collapse <= 0)
2658 : {
2659 8 : gfc_error_now ("COLLAPSE clause argument not constant "
2660 : "positive integer at %C");
2661 8 : collapse = 1;
2662 : }
2663 1506 : gfc_free_expr (cexpr);
2664 1506 : c->collapse = collapse;
2665 1506 : continue;
2666 1506 : }
2667 : }
2668 5495 : if ((mask & OMP_CLAUSE_COMPARE)
2669 5329 : && (m = gfc_match_dupl_check (!c->compare, "compare"))
2670 : != MATCH_NO)
2671 : {
2672 167 : if (m == MATCH_ERROR)
2673 1 : goto error;
2674 166 : c->compare = true;
2675 166 : continue;
2676 : }
2677 5174 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
2678 5162 : && gfc_match ("contains ( ") == MATCH_YES)
2679 : {
2680 12 : if (gfc_omp_absent_contains_clause (&c->assume, false)
2681 : != MATCH_YES)
2682 0 : goto error;
2683 12 : continue;
2684 : }
2685 7266 : if ((mask & OMP_CLAUSE_COPY)
2686 3723 : && gfc_match ("copy ( ") == MATCH_YES
2687 7267 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2688 : OMP_MAP_TOFROM, true,
2689 : allow_derived))
2690 2116 : continue;
2691 3034 : if (mask & OMP_CLAUSE_COPYIN)
2692 : {
2693 2628 : if (openacc)
2694 : {
2695 2529 : if (gfc_match ("copyin ( ") == MATCH_YES)
2696 : {
2697 1458 : bool readonly = gfc_match ("readonly : ") == MATCH_YES;
2698 1458 : head = NULL;
2699 1458 : if (gfc_match_omp_variable_list ("",
2700 : &c->lists[OMP_LIST_MAP],
2701 : true, NULL, &head, true,
2702 : allow_derived)
2703 : == MATCH_YES)
2704 : {
2705 1452 : gfc_omp_namelist *n;
2706 3349 : for (n = *head; n; n = n->next)
2707 : {
2708 1897 : n->u.map.op = OMP_MAP_TO;
2709 1897 : n->u.map.readonly = readonly;
2710 : }
2711 1452 : continue;
2712 1452 : }
2713 : }
2714 : }
2715 99 : else if (gfc_match_omp_variable_list ("copyin (",
2716 : &c->lists[OMP_LIST_COPYIN],
2717 : true) == MATCH_YES)
2718 97 : continue;
2719 : }
2720 2556 : if ((mask & OMP_CLAUSE_COPYOUT)
2721 1216 : && gfc_match ("copyout ( ") == MATCH_YES
2722 2556 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2723 : OMP_MAP_FROM, true, allow_derived))
2724 1071 : continue;
2725 498 : if ((mask & OMP_CLAUSE_COPYPRIVATE)
2726 414 : && gfc_match_omp_variable_list ("copyprivate (",
2727 : &c->lists[OMP_LIST_COPYPRIVATE],
2728 : true) == MATCH_YES)
2729 84 : continue;
2730 651 : if ((mask & OMP_CLAUSE_CREATE)
2731 328 : && gfc_match ("create ( ") == MATCH_YES
2732 651 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2733 : OMP_MAP_ALLOC, true, allow_derived))
2734 321 : continue;
2735 : break;
2736 3739 : case 'd':
2737 3739 : if ((mask & OMP_CLAUSE_DEFAULTMAP)
2738 3739 : && gfc_match ("defaultmap ( ") == MATCH_YES)
2739 : {
2740 180 : enum gfc_omp_defaultmap behavior;
2741 180 : gfc_omp_defaultmap_category category
2742 : = OMP_DEFAULTMAP_CAT_UNCATEGORIZED;
2743 180 : if (gfc_match ("alloc ") == MATCH_YES)
2744 : behavior = OMP_DEFAULTMAP_ALLOC;
2745 174 : else if (gfc_match ("tofrom ") == MATCH_YES)
2746 : behavior = OMP_DEFAULTMAP_TOFROM;
2747 142 : else if (gfc_match ("to ") == MATCH_YES)
2748 : behavior = OMP_DEFAULTMAP_TO;
2749 132 : else if (gfc_match ("from ") == MATCH_YES)
2750 : behavior = OMP_DEFAULTMAP_FROM;
2751 129 : else if (gfc_match ("firstprivate ") == MATCH_YES)
2752 : behavior = OMP_DEFAULTMAP_FIRSTPRIVATE;
2753 94 : else if (gfc_match ("present ") == MATCH_YES)
2754 : behavior = OMP_DEFAULTMAP_PRESENT;
2755 90 : else if (gfc_match ("none ") == MATCH_YES)
2756 : behavior = OMP_DEFAULTMAP_NONE;
2757 10 : else if (gfc_match ("default ") == MATCH_YES)
2758 : behavior = OMP_DEFAULTMAP_DEFAULT;
2759 : else
2760 : {
2761 1 : gfc_error ("Expected ALLOC, TO, FROM, TOFROM, FIRSTPRIVATE, "
2762 : "PRESENT, NONE or DEFAULT at %C");
2763 1 : break;
2764 : }
2765 179 : if (')' == gfc_peek_ascii_char ())
2766 : ;
2767 102 : else if (gfc_match (": ") != MATCH_YES)
2768 : break;
2769 : else
2770 : {
2771 102 : if (gfc_match ("scalar ") == MATCH_YES)
2772 : category = OMP_DEFAULTMAP_CAT_SCALAR;
2773 67 : else if (gfc_match ("aggregate ") == MATCH_YES)
2774 : category = OMP_DEFAULTMAP_CAT_AGGREGATE;
2775 43 : else if (gfc_match ("allocatable ") == MATCH_YES)
2776 : category = OMP_DEFAULTMAP_CAT_ALLOCATABLE;
2777 31 : else if (gfc_match ("pointer ") == MATCH_YES)
2778 : category = OMP_DEFAULTMAP_CAT_POINTER;
2779 14 : else if (gfc_match ("all ") == MATCH_YES)
2780 : category = OMP_DEFAULTMAP_CAT_ALL;
2781 : else
2782 : {
2783 1 : gfc_error ("Expected SCALAR, AGGREGATE, ALLOCATABLE, "
2784 : "POINTER or ALL at %C");
2785 1 : break;
2786 : }
2787 : }
2788 1193 : for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; ++i)
2789 : {
2790 1028 : if (i != category
2791 1028 : && category != OMP_DEFAULTMAP_CAT_UNCATEGORIZED
2792 486 : && category != OMP_DEFAULTMAP_CAT_ALL
2793 486 : && i != OMP_DEFAULTMAP_CAT_UNCATEGORIZED
2794 341 : && i != OMP_DEFAULTMAP_CAT_ALL)
2795 254 : continue;
2796 774 : if (c->defaultmap[i] != OMP_DEFAULTMAP_UNSET)
2797 : {
2798 13 : const char *pcategory = NULL;
2799 13 : switch (i)
2800 : {
2801 : case OMP_DEFAULTMAP_CAT_UNCATEGORIZED: break;
2802 : case OMP_DEFAULTMAP_CAT_ALL: pcategory = "ALL"; break;
2803 1 : case OMP_DEFAULTMAP_CAT_SCALAR: pcategory = "SCALAR"; break;
2804 2 : case OMP_DEFAULTMAP_CAT_AGGREGATE:
2805 2 : pcategory = "AGGREGATE";
2806 2 : break;
2807 1 : case OMP_DEFAULTMAP_CAT_ALLOCATABLE:
2808 1 : pcategory = "ALLOCATABLE";
2809 1 : break;
2810 2 : case OMP_DEFAULTMAP_CAT_POINTER:
2811 2 : pcategory = "POINTER";
2812 2 : break;
2813 : default: gcc_unreachable ();
2814 : }
2815 6 : if (i == OMP_DEFAULTMAP_CAT_UNCATEGORIZED)
2816 4 : gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP with "
2817 : "unspecified category");
2818 : else
2819 9 : gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP for "
2820 : "category %s", pcategory);
2821 13 : goto error;
2822 : }
2823 : }
2824 165 : c->defaultmap[category] = behavior;
2825 165 : if (gfc_match (")") != MATCH_YES)
2826 : break;
2827 165 : continue;
2828 165 : }
2829 4526 : if ((mask & OMP_CLAUSE_DEFAULT)
2830 3559 : && (m = gfc_match_dupl_check (c->default_sharing
2831 : == OMP_DEFAULT_UNKNOWN, "default",
2832 : true)) != MATCH_NO)
2833 : {
2834 1012 : if (m == MATCH_ERROR)
2835 6 : goto error;
2836 1006 : if (gfc_match ("none") == MATCH_YES)
2837 596 : c->default_sharing = OMP_DEFAULT_NONE;
2838 410 : else if (openacc)
2839 : {
2840 225 : if (gfc_match ("present") == MATCH_YES)
2841 195 : c->default_sharing = OMP_DEFAULT_PRESENT;
2842 : }
2843 : else
2844 : {
2845 185 : if (gfc_match ("firstprivate") == MATCH_YES)
2846 8 : c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE;
2847 177 : else if (gfc_match ("private") == MATCH_YES)
2848 24 : c->default_sharing = OMP_DEFAULT_PRIVATE;
2849 153 : else if (gfc_match ("shared") == MATCH_YES)
2850 153 : c->default_sharing = OMP_DEFAULT_SHARED;
2851 : }
2852 1006 : if (c->default_sharing == OMP_DEFAULT_UNKNOWN)
2853 : {
2854 30 : if (openacc)
2855 30 : gfc_error ("Expected NONE or PRESENT in DEFAULT clause "
2856 : "at %C");
2857 : else
2858 0 : gfc_error ("Expected NONE, FIRSTPRIVATE, PRIVATE or SHARED "
2859 : "in DEFAULT clause at %C");
2860 30 : goto error;
2861 : }
2862 976 : if (gfc_match (" )") != MATCH_YES)
2863 9 : goto error;
2864 967 : continue;
2865 : }
2866 2855 : if ((mask & OMP_CLAUSE_DELETE)
2867 345 : && gfc_match ("delete ( ") == MATCH_YES
2868 2855 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
2869 : OMP_MAP_RELEASE, true,
2870 : allow_derived))
2871 308 : continue;
2872 : /* DOACROSS: match 'doacross' and 'depend' with sink/source.
2873 : DEPEND: match 'depend' but not sink/source. */
2874 2239 : m = MATCH_NO;
2875 2239 : if (((mask & OMP_CLAUSE_DOACROSS)
2876 383 : && gfc_match ("doacross ( ") == MATCH_YES)
2877 2595 : || (((mask & OMP_CLAUSE_DEPEND) || (mask & OMP_CLAUSE_DOACROSS))
2878 1598 : && (m = gfc_match ("depend ( ")) == MATCH_YES))
2879 : {
2880 1100 : bool has_omp_all_memory;
2881 1100 : bool is_depend = m == MATCH_YES;
2882 1100 : gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
2883 1100 : match m_it = MATCH_NO;
2884 1100 : if (is_depend)
2885 1073 : m_it = gfc_match_iterator (&ns_iter, false);
2886 1073 : if (m_it == MATCH_ERROR)
2887 : break;
2888 1095 : if (m_it == MATCH_YES && gfc_match (" , ") != MATCH_YES)
2889 : break;
2890 1095 : m = MATCH_YES;
2891 1095 : gfc_omp_depend_doacross_op depend_op = OMP_DEPEND_OUT;
2892 1095 : if (gfc_match ("inoutset") == MATCH_YES)
2893 : depend_op = OMP_DEPEND_INOUTSET;
2894 1083 : else if (gfc_match ("inout") == MATCH_YES)
2895 : depend_op = OMP_DEPEND_INOUT;
2896 991 : else if (gfc_match ("in") == MATCH_YES)
2897 : depend_op = OMP_DEPEND_IN;
2898 704 : else if (gfc_match ("out") == MATCH_YES)
2899 : depend_op = OMP_DEPEND_OUT;
2900 442 : else if (gfc_match ("mutexinoutset") == MATCH_YES)
2901 : depend_op = OMP_DEPEND_MUTEXINOUTSET;
2902 424 : else if (gfc_match ("depobj") == MATCH_YES)
2903 : depend_op = OMP_DEPEND_DEPOBJ;
2904 387 : else if (gfc_match ("source") == MATCH_YES)
2905 : {
2906 143 : if (m_it == MATCH_YES)
2907 : {
2908 1 : gfc_error ("ITERATOR may not be combined with SOURCE "
2909 : "at %C");
2910 17 : goto error;
2911 : }
2912 142 : if (!(mask & OMP_CLAUSE_DOACROSS))
2913 : {
2914 1 : gfc_error ("SOURCE at %C not permitted as dependence-type"
2915 : " for this directive");
2916 1 : goto error;
2917 : }
2918 141 : if (c->doacross_source)
2919 : {
2920 0 : gfc_error ("Duplicated clause with SOURCE dependence-type"
2921 : " at %C");
2922 0 : goto error;
2923 : }
2924 141 : gfc_gobble_whitespace ();
2925 141 : m = gfc_match (": ");
2926 141 : if (m != MATCH_YES && !is_depend)
2927 : {
2928 1 : gfc_error ("Expected %<:%> at %C");
2929 1 : goto error;
2930 : }
2931 140 : if (gfc_match (")") != MATCH_YES
2932 146 : && !(m == MATCH_YES
2933 6 : && gfc_match ("omp_cur_iteration )") == MATCH_YES))
2934 : {
2935 2 : gfc_error ("Expected %<)%> or %<omp_cur_iteration)%> "
2936 : "at %C");
2937 2 : goto error;
2938 : }
2939 138 : if (is_depend)
2940 130 : gfc_warning (OPT_Wdeprecated_openmp,
2941 : "%<source%> modifier with %<depend%> clause "
2942 : "at %L deprecated since OpenMP 5.2, use with "
2943 : "%<doacross%>", &old_loc);
2944 138 : c->doacross_source = true;
2945 138 : c->depend_source = is_depend;
2946 1078 : continue;
2947 : }
2948 244 : else if (gfc_match ("sink ") == MATCH_YES)
2949 : {
2950 244 : if (!(mask & OMP_CLAUSE_DOACROSS))
2951 : {
2952 2 : gfc_error ("SINK at %C not permitted as dependence-type "
2953 : "for this directive");
2954 2 : goto error;
2955 : }
2956 242 : if (gfc_match (": ") != MATCH_YES)
2957 : {
2958 1 : gfc_error ("Expected %<:%> at %C");
2959 1 : goto error;
2960 : }
2961 241 : if (m_it == MATCH_YES)
2962 : {
2963 0 : gfc_error ("ITERATOR may not be combined with SINK "
2964 : "at %C");
2965 0 : goto error;
2966 : }
2967 241 : if (is_depend)
2968 226 : gfc_warning (OPT_Wdeprecated_openmp,
2969 : "%<sink%> modifier with %<depend%> clause at "
2970 : "%L deprecated since OpenMP 5.2, use with "
2971 : "%<doacross%>", &old_loc);
2972 241 : m = gfc_match_omp_doacross_sink (&c->lists[OMP_LIST_DEPEND],
2973 : is_depend);
2974 241 : if (m == MATCH_YES)
2975 238 : continue;
2976 3 : goto error;
2977 : }
2978 : else
2979 : m = MATCH_NO;
2980 708 : if (!(mask & OMP_CLAUSE_DEPEND))
2981 : {
2982 0 : gfc_error ("Expected dependence-type SINK or SOURCE at %C");
2983 0 : goto error;
2984 : }
2985 708 : head = NULL;
2986 708 : if (ns_iter)
2987 40 : gfc_current_ns = ns_iter;
2988 708 : if (m == MATCH_YES)
2989 708 : m = gfc_match_omp_variable_list (" : ",
2990 : &c->lists[OMP_LIST_DEPEND],
2991 : false, NULL, &head, true,
2992 : false, &has_omp_all_memory);
2993 708 : if (m != MATCH_YES)
2994 2 : goto error;
2995 706 : gfc_current_ns = ns_curr;
2996 706 : if (has_omp_all_memory && depend_op != OMP_DEPEND_INOUT
2997 21 : && depend_op != OMP_DEPEND_OUT)
2998 : {
2999 4 : gfc_error ("%<omp_all_memory%> used with DEPEND kind "
3000 : "other than OUT or INOUT at %C");
3001 4 : goto error;
3002 : }
3003 702 : gfc_omp_namelist *n;
3004 1435 : for (n = *head; n; n = n->next)
3005 : {
3006 733 : n->u.depend_doacross_op = depend_op;
3007 733 : n->u2.ns = ns_iter;
3008 733 : if (ns_iter)
3009 39 : ns_iter->refs++;
3010 : }
3011 702 : continue;
3012 702 : }
3013 1160 : if ((mask & OMP_CLAUSE_DESTROY)
3014 1139 : && gfc_match_omp_variable_list ("destroy (",
3015 : &c->lists[OMP_LIST_DESTROY],
3016 : true) == MATCH_YES)
3017 21 : continue;
3018 1244 : if ((mask & OMP_CLAUSE_DETACH)
3019 164 : && !openacc
3020 127 : && !c->detach
3021 1244 : && gfc_match_omp_detach (&c->detach) == MATCH_YES)
3022 126 : continue;
3023 1029 : if ((mask & OMP_CLAUSE_DETACH)
3024 38 : && openacc
3025 37 : && gfc_match ("detach ( ") == MATCH_YES
3026 1029 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3027 : OMP_MAP_DETACH, false,
3028 : allow_derived))
3029 37 : continue;
3030 991 : if ((mask & OMP_CLAUSE_DEVICEPTR)
3031 87 : && gfc_match ("deviceptr ( ") == MATCH_YES
3032 993 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3033 : OMP_MAP_FORCE_DEVICEPTR, false,
3034 : allow_derived))
3035 36 : continue;
3036 1010 : if ((mask & OMP_CLAUSE_DEVICE_TYPE)
3037 919 : && gfc_match_dupl_check (c->device_type == OMP_DEVICE_TYPE_UNSET,
3038 : "device_type", true) == MATCH_YES)
3039 : {
3040 92 : if (gfc_match ("host") == MATCH_YES)
3041 32 : c->device_type = OMP_DEVICE_TYPE_HOST;
3042 60 : else if (gfc_match ("nohost") == MATCH_YES)
3043 21 : c->device_type = OMP_DEVICE_TYPE_NOHOST;
3044 39 : else if (gfc_match ("any") == MATCH_YES)
3045 38 : c->device_type = OMP_DEVICE_TYPE_ANY;
3046 : else
3047 : {
3048 1 : gfc_error ("Expected HOST, NOHOST or ANY at %C");
3049 1 : break;
3050 : }
3051 91 : if (gfc_match (" )") != MATCH_YES)
3052 : break;
3053 91 : continue;
3054 : }
3055 875 : if ((mask & OMP_CLAUSE_DEVICE_RESIDENT)
3056 876 : && gfc_match_omp_variable_list
3057 49 : ("device_resident (",
3058 : &c->lists[OMP_LIST_DEVICE_RESIDENT], true) == MATCH_YES)
3059 48 : continue;
3060 1091 : if ((mask & OMP_CLAUSE_DEVICE)
3061 703 : && openacc
3062 314 : && gfc_match ("device ( ") == MATCH_YES
3063 1092 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3064 : OMP_MAP_FORCE_TO, true,
3065 : /* allow_derived = */ true))
3066 312 : continue;
3067 467 : if ((mask & OMP_CLAUSE_DEVICE)
3068 391 : && !openacc
3069 856 : && ((m = gfc_match_dupl_check (!c->device, "device", true))
3070 : != MATCH_NO))
3071 : {
3072 349 : if (m == MATCH_ERROR)
3073 0 : goto error;
3074 349 : c->ancestor = false;
3075 349 : if (gfc_match ("device_num : ") == MATCH_YES)
3076 : {
3077 18 : if (gfc_match ("%e )", &c->device) != MATCH_YES)
3078 : {
3079 1 : gfc_error ("Expected integer expression at %C");
3080 1 : break;
3081 : }
3082 : }
3083 331 : else if (gfc_match ("ancestor : ") == MATCH_YES)
3084 : {
3085 45 : bool has_requires = false;
3086 45 : c->ancestor = true;
3087 82 : for (gfc_namespace *ns = gfc_current_ns; ns; ns = ns->parent)
3088 80 : if (ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD)
3089 : {
3090 : has_requires = true;
3091 : break;
3092 : }
3093 45 : if (!has_requires)
3094 : {
3095 2 : gfc_error ("%<ancestor%> device modifier not "
3096 : "preceded by %<requires%> directive "
3097 : "with %<reverse_offload%> clause at %C");
3098 5 : break;
3099 : }
3100 43 : locus old_loc2 = gfc_current_locus;
3101 43 : if (gfc_match ("%e )", &c->device) == MATCH_YES)
3102 : {
3103 43 : int device = 0;
3104 43 : if (!gfc_extract_int (c->device, &device) && device != 1)
3105 : {
3106 1 : gfc_current_locus = old_loc2;
3107 1 : gfc_error ("the %<device%> clause expression must "
3108 : "evaluate to %<1%> at %C");
3109 1 : break;
3110 : }
3111 : }
3112 : else
3113 : {
3114 0 : gfc_error ("Expected integer expression at %C");
3115 0 : break;
3116 : }
3117 : }
3118 286 : else if (gfc_match ("%e )", &c->device) != MATCH_YES)
3119 : {
3120 13 : gfc_error ("Expected integer expression or a single device-"
3121 : "modifier %<device_num%> or %<ancestor%> at %C");
3122 13 : break;
3123 : }
3124 332 : continue;
3125 332 : }
3126 118 : if ((mask & OMP_CLAUSE_DIST_SCHEDULE)
3127 97 : && c->dist_sched_kind == OMP_SCHED_NONE
3128 215 : && gfc_match ("dist_schedule ( static") == MATCH_YES)
3129 : {
3130 97 : m = MATCH_NO;
3131 97 : c->dist_sched_kind = OMP_SCHED_STATIC;
3132 97 : m = gfc_match (" , %e )", &c->dist_chunk_size);
3133 97 : if (m != MATCH_YES)
3134 14 : m = gfc_match_char (')');
3135 14 : if (m != MATCH_YES)
3136 : {
3137 0 : c->dist_sched_kind = OMP_SCHED_NONE;
3138 0 : gfc_current_locus = old_loc;
3139 : }
3140 : else
3141 97 : continue;
3142 : }
3143 32 : if ((mask & OMP_CLAUSE_DYN_GROUPPRIVATE)
3144 21 : && gfc_match_dupl_check (!c->dyn_groupprivate,
3145 : "dyn_groupprivate", true) == MATCH_YES)
3146 : {
3147 12 : if (gfc_match ("fallback ( abort ) : ") == MATCH_YES)
3148 1 : c->fallback = OMP_FALLBACK_ABORT;
3149 11 : else if (gfc_match ("fallback ( default_mem ) : ") == MATCH_YES)
3150 1 : c->fallback = OMP_FALLBACK_DEFAULT_MEM;
3151 10 : else if (gfc_match ("fallback ( null ) : ") == MATCH_YES)
3152 1 : c->fallback = OMP_FALLBACK_NULL;
3153 12 : if (gfc_match_expr (&c->dyn_groupprivate) != MATCH_YES)
3154 0 : return MATCH_ERROR;
3155 12 : if (gfc_match (" )") != MATCH_YES)
3156 1 : goto error;
3157 11 : continue;
3158 : }
3159 : break;
3160 90 : case 'e':
3161 90 : if ((mask & OMP_CLAUSE_ENTER))
3162 : {
3163 90 : m = gfc_match_omp_to_link ("enter (", &c->lists[OMP_LIST_ENTER]);
3164 90 : if (m == MATCH_ERROR)
3165 0 : goto error;
3166 90 : if (m == MATCH_YES)
3167 90 : continue;
3168 : }
3169 : break;
3170 2282 : case 'f':
3171 2331 : if ((mask & OMP_CLAUSE_FAIL)
3172 2282 : && (m = gfc_match_dupl_check (c->fail == OMP_MEMORDER_UNSET,
3173 : "fail", true)) != MATCH_NO)
3174 : {
3175 58 : if (m == MATCH_ERROR)
3176 3 : goto error;
3177 55 : if (gfc_match ("seq_cst") == MATCH_YES)
3178 6 : c->fail = OMP_MEMORDER_SEQ_CST;
3179 49 : else if (gfc_match ("acquire") == MATCH_YES)
3180 14 : c->fail = OMP_MEMORDER_ACQUIRE;
3181 35 : else if (gfc_match ("relaxed") == MATCH_YES)
3182 30 : c->fail = OMP_MEMORDER_RELAXED;
3183 : else
3184 : {
3185 5 : gfc_error ("Expected SEQ_CST, ACQUIRE or RELAXED at %C");
3186 5 : break;
3187 : }
3188 50 : if (gfc_match (" )") != MATCH_YES)
3189 1 : goto error;
3190 49 : continue;
3191 : }
3192 2267 : if ((mask & OMP_CLAUSE_FILTER)
3193 2224 : && (m = gfc_match_dupl_check (!c->filter, "filter", true,
3194 : &c->filter)) != MATCH_NO)
3195 : {
3196 44 : if (m == MATCH_ERROR)
3197 1 : goto error;
3198 43 : continue;
3199 : }
3200 2244 : if ((mask & OMP_CLAUSE_FINAL)
3201 2180 : && (m = gfc_match_dupl_check (!c->final_expr, "final", true,
3202 : &c->final_expr)) != MATCH_NO)
3203 : {
3204 64 : if (m == MATCH_ERROR)
3205 0 : goto error;
3206 64 : continue;
3207 : }
3208 2142 : if ((mask & OMP_CLAUSE_FINALIZE)
3209 2116 : && (m = gfc_match_dupl_check (!c->finalize, "finalize"))
3210 : != MATCH_NO)
3211 : {
3212 26 : if (m == MATCH_ERROR)
3213 0 : goto error;
3214 26 : c->finalize = true;
3215 26 : continue;
3216 : }
3217 3104 : if ((mask & OMP_CLAUSE_FIRSTPRIVATE)
3218 2090 : && gfc_match_omp_variable_list ("firstprivate (",
3219 : &c->lists[OMP_LIST_FIRSTPRIVATE],
3220 : true) == MATCH_YES)
3221 1014 : continue;
3222 2075 : if ((mask & OMP_CLAUSE_FROM)
3223 1076 : && gfc_match_motion_var_list ("from (", &c->lists[OMP_LIST_FROM],
3224 : &head) == MATCH_YES)
3225 999 : continue;
3226 142 : if ((mask & OMP_CLAUSE_FULL)
3227 77 : && (m = gfc_match_dupl_check (!c->full, "full")) != MATCH_NO)
3228 : {
3229 65 : if (m == MATCH_ERROR)
3230 0 : goto error;
3231 65 : c->full = true;
3232 65 : continue;
3233 : }
3234 : break;
3235 1231 : case 'g':
3236 2423 : if ((mask & OMP_CLAUSE_GANG)
3237 1231 : && (m = gfc_match_dupl_check (!c->gang, "gang")) != MATCH_NO)
3238 : {
3239 1197 : if (m == MATCH_ERROR)
3240 0 : goto error;
3241 1197 : c->gang = true;
3242 1197 : m = match_oacc_clause_gwv (c, GOMP_DIM_GANG);
3243 1197 : if (m == MATCH_ERROR)
3244 : {
3245 5 : gfc_current_locus = old_loc;
3246 5 : break;
3247 : }
3248 1192 : continue;
3249 : }
3250 68 : if ((mask & OMP_CLAUSE_GRAINSIZE)
3251 34 : && (m = gfc_match_dupl_check (!c->grainsize, "grainsize", true))
3252 : != MATCH_NO)
3253 : {
3254 34 : if (m == MATCH_ERROR)
3255 0 : goto error;
3256 34 : if (gfc_match ("strict : ") == MATCH_YES)
3257 1 : c->grainsize_strict = true;
3258 34 : if (gfc_match (" %e )", &c->grainsize) != MATCH_YES)
3259 0 : goto error;
3260 34 : continue;
3261 : }
3262 : break;
3263 465 : case 'h':
3264 513 : if ((mask & OMP_CLAUSE_HAS_DEVICE_ADDR)
3265 513 : && gfc_match_omp_variable_list
3266 48 : ("has_device_addr (", &c->lists[OMP_LIST_HAS_DEVICE_ADDR],
3267 : false, NULL, NULL, true) == MATCH_YES)
3268 48 : continue;
3269 460 : if ((mask & OMP_CLAUSE_HINT)
3270 417 : && (m = gfc_match_dupl_check (!c->hint, "hint", true, &c->hint))
3271 : != MATCH_NO)
3272 : {
3273 43 : if (m == MATCH_ERROR)
3274 0 : goto error;
3275 43 : continue;
3276 : }
3277 374 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3278 374 : && gfc_match ("holds ( ") == MATCH_YES)
3279 : {
3280 19 : gfc_expr *e;
3281 19 : if (gfc_match ("%e )", &e) != MATCH_YES)
3282 0 : goto error;
3283 19 : if (c->assume == NULL)
3284 12 : c->assume = gfc_get_omp_assumptions ();
3285 19 : gfc_expr_list *el = XCNEW (gfc_expr_list);
3286 19 : el->expr = e;
3287 19 : el->next = c->assume->holds;
3288 19 : c->assume->holds = el;
3289 19 : continue;
3290 19 : }
3291 709 : if ((mask & OMP_CLAUSE_HOST)
3292 355 : && gfc_match ("host ( ") == MATCH_YES
3293 710 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3294 : OMP_MAP_FORCE_FROM, true,
3295 : /* allow_derived = */ true))
3296 354 : continue;
3297 : break;
3298 2119 : case 'i':
3299 2142 : if ((mask & OMP_CLAUSE_IF_PRESENT)
3300 2119 : && (m = gfc_match_dupl_check (!c->if_present, "if_present"))
3301 : != MATCH_NO)
3302 : {
3303 23 : if (m == MATCH_ERROR)
3304 0 : goto error;
3305 23 : c->if_present = true;
3306 23 : continue;
3307 : }
3308 2096 : if ((mask & OMP_CLAUSE_IF)
3309 2096 : && (m = gfc_match_dupl_check (!c->if_expr, "if", true))
3310 : != MATCH_NO)
3311 : {
3312 1347 : if (m == MATCH_ERROR)
3313 12 : goto error;
3314 1335 : if (!openacc)
3315 : {
3316 : /* This should match the enum gfc_omp_if_kind order. */
3317 : static const char *ifs[OMP_IF_LAST] = {
3318 : "cancel : %e )",
3319 : "parallel : %e )",
3320 : "simd : %e )",
3321 : "task : %e )",
3322 : "taskloop : %e )",
3323 : "target : %e )",
3324 : "target data : %e )",
3325 : "target update : %e )",
3326 : "target enter data : %e )",
3327 : "target exit data : %e )" };
3328 : int i;
3329 4841 : for (i = 0; i < OMP_IF_LAST; i++)
3330 4443 : if (c->if_exprs[i] == NULL
3331 4443 : && gfc_match (ifs[i], &c->if_exprs[i]) == MATCH_YES)
3332 : break;
3333 536 : if (i < OMP_IF_LAST)
3334 138 : continue;
3335 : }
3336 1197 : if (gfc_match (" %e )", &c->if_expr) == MATCH_YES)
3337 1192 : continue;
3338 5 : goto error;
3339 : }
3340 866 : if ((mask & OMP_CLAUSE_IN_REDUCTION)
3341 749 : && gfc_match_omp_clause_reduction (pc, c, openacc, allow_derived,
3342 : openmp_target) == MATCH_YES)
3343 117 : continue;
3344 657 : if ((mask & OMP_CLAUSE_INBRANCH)
3345 632 : && (m = gfc_match_dupl_check (!c->inbranch && !c->notinbranch,
3346 : "inbranch")) != MATCH_NO)
3347 : {
3348 25 : if (m == MATCH_ERROR)
3349 0 : goto error;
3350 25 : c->inbranch = true;
3351 25 : continue;
3352 : }
3353 849 : if ((mask & OMP_CLAUSE_INDEPENDENT)
3354 607 : && (m = gfc_match_dupl_check (!c->independent, "independent"))
3355 : != MATCH_NO)
3356 : {
3357 242 : if (m == MATCH_ERROR)
3358 0 : goto error;
3359 242 : c->independent = true;
3360 242 : continue;
3361 : }
3362 365 : if ((mask & OMP_CLAUSE_INDIRECT)
3363 365 : && (m = gfc_match_dupl_check (!c->indirect, "indirect"))
3364 : != MATCH_NO)
3365 : {
3366 61 : if (m == MATCH_ERROR)
3367 5 : goto error;
3368 60 : gfc_expr *indirect_expr = NULL;
3369 60 : m = gfc_match (" ( %e )", &indirect_expr);
3370 60 : if (m == MATCH_YES)
3371 : {
3372 13 : if (!gfc_resolve_expr (indirect_expr)
3373 13 : || indirect_expr->ts.type != BT_LOGICAL
3374 23 : || indirect_expr->expr_type != EXPR_CONSTANT)
3375 : {
3376 4 : gfc_error ("INDIRECT clause at %C requires a constant "
3377 : "logical expression");
3378 4 : gfc_free_expr (indirect_expr);
3379 4 : goto error;
3380 : }
3381 9 : c->indirect = indirect_expr->value.logical;
3382 9 : gfc_free_expr (indirect_expr);
3383 : }
3384 : else
3385 47 : c->indirect = 1;
3386 56 : continue;
3387 56 : }
3388 304 : if ((mask & OMP_CLAUSE_INIT)
3389 304 : && gfc_match ("init ( ") == MATCH_YES)
3390 : {
3391 108 : m = gfc_match_omp_init (&c->lists[OMP_LIST_INIT]);
3392 108 : if (m == MATCH_YES)
3393 63 : continue;
3394 45 : goto error;
3395 : }
3396 196 : if ((mask & OMP_CLAUSE_INTEROP)
3397 196 : && (m = gfc_match_dupl_check (!c->lists[OMP_LIST_INTEROP],
3398 : "interop", true)) != MATCH_NO)
3399 : {
3400 : /* Note: the interop objects are saved in reverse order to match
3401 : the order in C/C++. */
3402 125 : if (m == MATCH_YES
3403 63 : && (gfc_match_omp_variable_list ("",
3404 : &c->lists[OMP_LIST_INTEROP],
3405 : false, NULL, NULL, false,
3406 : false, NULL, false, true)
3407 : == MATCH_YES))
3408 62 : continue;
3409 1 : goto error;
3410 : }
3411 253 : if ((mask & OMP_CLAUSE_IS_DEVICE_PTR)
3412 253 : && gfc_match_omp_variable_list
3413 120 : ("is_device_ptr (",
3414 : &c->lists[OMP_LIST_IS_DEVICE_PTR], false) == MATCH_YES)
3415 120 : continue;
3416 : break;
3417 2334 : case 'l':
3418 2334 : if ((mask & OMP_CLAUSE_LASTPRIVATE)
3419 2334 : && gfc_match ("lastprivate ( ") == MATCH_YES)
3420 : {
3421 1431 : bool conditional = gfc_match ("conditional : ") == MATCH_YES;
3422 1431 : head = NULL;
3423 1431 : if (gfc_match_omp_variable_list ("",
3424 : &c->lists[OMP_LIST_LASTPRIVATE],
3425 : false, NULL, &head) == MATCH_YES)
3426 : {
3427 1431 : gfc_omp_namelist *n;
3428 3737 : for (n = *head; n; n = n->next)
3429 2306 : n->u.lastprivate_conditional = conditional;
3430 1431 : continue;
3431 1431 : }
3432 0 : gfc_current_locus = old_loc;
3433 0 : break;
3434 : }
3435 903 : end_colon = false;
3436 903 : head = NULL;
3437 903 : if ((mask & OMP_CLAUSE_LINEAR)
3438 903 : && gfc_match ("linear (") == MATCH_YES)
3439 : {
3440 836 : bool old_linear_modifier = false;
3441 836 : gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
3442 836 : gfc_expr *step = NULL;
3443 836 : locus saved_loc = gfc_current_locus;
3444 :
3445 836 : if (gfc_match_omp_variable_list (" ref (",
3446 : &c->lists[OMP_LIST_LINEAR],
3447 : false, NULL, &head)
3448 : == MATCH_YES)
3449 : {
3450 : linear_op = OMP_LINEAR_REF;
3451 : old_linear_modifier = true;
3452 : }
3453 808 : else if (gfc_match_omp_variable_list (" val (",
3454 : &c->lists[OMP_LIST_LINEAR],
3455 : false, NULL, &head)
3456 : == MATCH_YES)
3457 : {
3458 : linear_op = OMP_LINEAR_VAL;
3459 : old_linear_modifier = true;
3460 : }
3461 797 : else if (gfc_match_omp_variable_list (" uval (",
3462 : &c->lists[OMP_LIST_LINEAR],
3463 : false, NULL, &head)
3464 : == MATCH_YES)
3465 : {
3466 : linear_op = OMP_LINEAR_UVAL;
3467 : old_linear_modifier = true;
3468 : }
3469 788 : else if (gfc_match_omp_variable_list ("",
3470 : &c->lists[OMP_LIST_LINEAR],
3471 : false, &end_colon, &head)
3472 : == MATCH_YES)
3473 : linear_op = OMP_LINEAR_DEFAULT;
3474 : else
3475 : {
3476 2 : gfc_current_locus = old_loc;
3477 2 : break;
3478 : }
3479 : if (linear_op != OMP_LINEAR_DEFAULT)
3480 : {
3481 48 : if (gfc_match (" :") == MATCH_YES)
3482 31 : end_colon = true;
3483 17 : else if (gfc_match (" )") != MATCH_YES)
3484 : {
3485 0 : gfc_free_omp_namelist (*head, OMP_LIST_LINEAR);
3486 0 : gfc_current_locus = old_loc;
3487 0 : *head = NULL;
3488 0 : break;
3489 : }
3490 : }
3491 834 : gfc_gobble_whitespace ();
3492 834 : if (old_linear_modifier && end_colon)
3493 : {
3494 31 : if (gfc_match (" %e )", &step) != MATCH_YES)
3495 : {
3496 1 : gfc_free_omp_namelist (*head, OMP_LIST_LINEAR);
3497 1 : gfc_current_locus = old_loc;
3498 1 : *head = NULL;
3499 5 : goto error;
3500 : }
3501 : }
3502 833 : if (old_linear_modifier)
3503 : {
3504 47 : char var_names[512]{};
3505 47 : int count, offset = 0;
3506 106 : for (gfc_omp_namelist *n = *head; n; n = n->next)
3507 : {
3508 59 : if (!n->next)
3509 47 : count = snprintf (var_names + offset,
3510 47 : sizeof (var_names) - offset,
3511 47 : "%s", n->sym->name);
3512 : else
3513 12 : count = snprintf (var_names + offset,
3514 12 : sizeof (var_names) - offset,
3515 12 : "%s, ", n->sym->name);
3516 59 : if (count < 0 || count >= ((int)sizeof (var_names))
3517 59 : - offset)
3518 : {
3519 0 : snprintf (var_names, 512, "%s, ..., ",
3520 0 : (*head)->sym->name);
3521 0 : while (n->next)
3522 : n = n->next;
3523 0 : offset = strlen (var_names);
3524 0 : snprintf (var_names + offset,
3525 0 : sizeof (var_names) - offset,
3526 0 : "%s", n->sym->name);
3527 0 : break;
3528 : }
3529 59 : offset += count;
3530 : }
3531 47 : char *var_names_for_warn = var_names;
3532 47 : const char *op_name;
3533 47 : switch (linear_op)
3534 : {
3535 : case OMP_LINEAR_REF: op_name = "ref"; break;
3536 10 : case OMP_LINEAR_VAL: op_name = "val"; break;
3537 9 : case OMP_LINEAR_UVAL: op_name = "uval"; break;
3538 0 : default: gcc_unreachable ();
3539 : }
3540 47 : gfc_warning (OPT_Wdeprecated_openmp,
3541 : "Specification of the list items as "
3542 : "arguments to the modifiers at %L is "
3543 : "deprecated; since OpenMP 5.2, use "
3544 : "%<linear(%s : %s%s)%>", &saved_loc,
3545 : var_names_for_warn, op_name,
3546 47 : step == nullptr ? "" : ", step(...)");
3547 : }
3548 786 : else if (end_colon)
3549 : {
3550 713 : bool has_error = false;
3551 : bool has_modifiers = false;
3552 : bool has_step = false;
3553 713 : bool duplicate_step = false;
3554 713 : bool duplicate_mod = false;
3555 713 : while (true)
3556 : {
3557 713 : old_loc = gfc_current_locus;
3558 713 : bool close_paren = gfc_match ("val )") == MATCH_YES;
3559 713 : if (close_paren || gfc_match ("val , ") == MATCH_YES)
3560 : {
3561 17 : if (linear_op != OMP_LINEAR_DEFAULT)
3562 : {
3563 : duplicate_mod = true;
3564 : break;
3565 : }
3566 16 : linear_op = OMP_LINEAR_VAL;
3567 16 : has_modifiers = true;
3568 16 : if (close_paren)
3569 : break;
3570 10 : continue;
3571 : }
3572 696 : close_paren = gfc_match ("uval )") == MATCH_YES;
3573 696 : if (close_paren || gfc_match ("uval , ") == MATCH_YES)
3574 : {
3575 7 : if (linear_op != OMP_LINEAR_DEFAULT)
3576 : {
3577 : duplicate_mod = true;
3578 : break;
3579 : }
3580 7 : linear_op = OMP_LINEAR_UVAL;
3581 7 : has_modifiers = true;
3582 7 : if (close_paren)
3583 : break;
3584 2 : continue;
3585 : }
3586 689 : close_paren = gfc_match ("ref )") == MATCH_YES;
3587 689 : if (close_paren || gfc_match ("ref , ") == MATCH_YES)
3588 : {
3589 16 : if (linear_op != OMP_LINEAR_DEFAULT)
3590 : {
3591 : duplicate_mod = true;
3592 : break;
3593 : }
3594 15 : linear_op = OMP_LINEAR_REF;
3595 15 : has_modifiers = true;
3596 15 : if (close_paren)
3597 : break;
3598 7 : continue;
3599 : }
3600 673 : close_paren = (gfc_match ("step ( %e ) )", &step)
3601 : == MATCH_YES);
3602 684 : if (close_paren
3603 673 : || gfc_match ("step ( %e ) , ", &step) == MATCH_YES)
3604 : {
3605 38 : if (has_step)
3606 : {
3607 : duplicate_step = true;
3608 : break;
3609 : }
3610 37 : has_modifiers = has_step = true;
3611 37 : if (close_paren)
3612 : break;
3613 11 : continue;
3614 : }
3615 635 : if (!has_modifiers
3616 635 : && gfc_match ("%e )", &step) == MATCH_YES)
3617 : {
3618 635 : if ((step->expr_type == EXPR_FUNCTION
3619 634 : || step->expr_type == EXPR_VARIABLE)
3620 31 : && strcmp (step->symtree->name, "step") == 0)
3621 : {
3622 1 : gfc_current_locus = old_loc;
3623 1 : gfc_match ("step (");
3624 1 : has_error = true;
3625 : }
3626 : break;
3627 : }
3628 : has_error = true;
3629 : break;
3630 : }
3631 49 : if (duplicate_mod || duplicate_step)
3632 : {
3633 3 : gfc_error ("Multiple %qs modifiers specified at %C",
3634 : duplicate_mod ? "linear" : "step");
3635 3 : has_error = true;
3636 : }
3637 683 : if (has_error)
3638 : {
3639 4 : gfc_free_omp_namelist (*head, OMP_LIST_LINEAR);
3640 4 : *head = NULL;
3641 4 : goto error;
3642 : }
3643 : }
3644 829 : if (step == NULL)
3645 : {
3646 130 : step = gfc_get_constant_expr (BT_INTEGER,
3647 : gfc_default_integer_kind,
3648 : &old_loc);
3649 130 : mpz_set_si (step->value.integer, 1);
3650 : }
3651 829 : (*head)->expr = step;
3652 829 : if (linear_op != OMP_LINEAR_DEFAULT || old_linear_modifier)
3653 176 : for (gfc_omp_namelist *n = *head; n; n = n->next)
3654 : {
3655 94 : n->u.linear.op = linear_op;
3656 94 : n->u.linear.old_modifier = old_linear_modifier;
3657 : }
3658 829 : continue;
3659 829 : }
3660 71 : if ((mask & OMP_CLAUSE_LINK)
3661 67 : && openacc
3662 75 : && (gfc_match_oacc_clause_link ("link (",
3663 : &c->lists[OMP_LIST_LINK])
3664 : == MATCH_YES))
3665 4 : continue;
3666 110 : else if ((mask & OMP_CLAUSE_LINK)
3667 63 : && !openacc
3668 122 : && (gfc_match_omp_to_link ("link (",
3669 : &c->lists[OMP_LIST_LINK])
3670 : == MATCH_YES))
3671 47 : continue;
3672 28 : if ((mask & OMP_CLAUSE_LOCAL)
3673 16 : && (gfc_match_omp_to_link ("local (", &c->lists[OMP_LIST_LOCAL])
3674 : == MATCH_YES))
3675 12 : continue;
3676 : break;
3677 5222 : case 'm':
3678 5222 : if ((mask & OMP_CLAUSE_MAP)
3679 5222 : && gfc_match ("map ( ") == MATCH_YES)
3680 : {
3681 5130 : locus old_loc2 = gfc_current_locus;
3682 5130 : int always_modifier = 0;
3683 5130 : int close_modifier = 0;
3684 5130 : int present_modifier = 0;
3685 5130 : locus second_always_locus = old_loc2;
3686 5130 : locus second_close_locus = old_loc2;
3687 5130 : locus second_present_locus = old_loc2;
3688 :
3689 5654 : for (;;)
3690 : {
3691 5392 : locus current_locus = gfc_current_locus;
3692 5392 : if (gfc_match ("always ") == MATCH_YES)
3693 : {
3694 141 : if (always_modifier++ == 1)
3695 5 : second_always_locus = current_locus;
3696 : }
3697 5251 : else if (gfc_match ("close ") == MATCH_YES)
3698 : {
3699 66 : if (close_modifier++ == 1)
3700 5 : second_close_locus = current_locus;
3701 : }
3702 5185 : else if (gfc_match ("present ") == MATCH_YES)
3703 : {
3704 55 : if (present_modifier++ == 1)
3705 4 : second_present_locus = current_locus;
3706 : }
3707 : else
3708 : break;
3709 262 : if (gfc_match (", ") != MATCH_YES)
3710 62 : gfc_warning (OPT_Wdeprecated_openmp,
3711 : "The specification of modifiers without "
3712 : "comma separators for the %<map%> clause "
3713 : "at %C has been deprecated since "
3714 : "OpenMP 5.2");
3715 262 : }
3716 :
3717 5130 : gfc_omp_map_op map_op = OMP_MAP_TOFROM;
3718 5130 : int always_present_modifier
3719 5130 : = always_modifier && present_modifier;
3720 :
3721 5130 : if (gfc_match ("alloc : ") == MATCH_YES)
3722 601 : map_op = (present_modifier ? OMP_MAP_PRESENT_ALLOC
3723 : : OMP_MAP_ALLOC);
3724 4529 : else if (gfc_match ("tofrom : ") == MATCH_YES)
3725 841 : map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_TOFROM
3726 837 : : present_modifier ? OMP_MAP_PRESENT_TOFROM
3727 833 : : always_modifier ? OMP_MAP_ALWAYS_TOFROM
3728 : : OMP_MAP_TOFROM);
3729 3688 : else if (gfc_match ("to : ") == MATCH_YES)
3730 1629 : map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_TO
3731 1623 : : present_modifier ? OMP_MAP_PRESENT_TO
3732 1612 : : always_modifier ? OMP_MAP_ALWAYS_TO
3733 : : OMP_MAP_TO);
3734 2059 : else if (gfc_match ("from : ") == MATCH_YES)
3735 1529 : map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_FROM
3736 1525 : : present_modifier ? OMP_MAP_PRESENT_FROM
3737 1521 : : always_modifier ? OMP_MAP_ALWAYS_FROM
3738 : : OMP_MAP_FROM);
3739 530 : else if (gfc_match ("release : ") == MATCH_YES)
3740 : map_op = OMP_MAP_RELEASE;
3741 513 : else if (gfc_match ("delete : ") == MATCH_YES)
3742 : map_op = OMP_MAP_DELETE;
3743 : else
3744 : {
3745 466 : gfc_current_locus = old_loc2;
3746 466 : always_modifier = 0;
3747 466 : close_modifier = 0;
3748 : }
3749 :
3750 1270 : if (always_modifier > 1)
3751 : {
3752 5 : gfc_error ("too many %<always%> modifiers at %L",
3753 : &second_always_locus);
3754 21 : break;
3755 : }
3756 5125 : if (close_modifier > 1)
3757 : {
3758 4 : gfc_error ("too many %<close%> modifiers at %L",
3759 : &second_close_locus);
3760 4 : break;
3761 : }
3762 5121 : if (present_modifier > 1)
3763 : {
3764 4 : gfc_error ("too many %<present%> modifiers at %L",
3765 : &second_present_locus);
3766 4 : break;
3767 : }
3768 :
3769 5117 : head = NULL;
3770 5117 : if (gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_MAP],
3771 : false, NULL, &head,
3772 : true, true) == MATCH_YES)
3773 : {
3774 5114 : gfc_omp_namelist *n;
3775 11799 : for (n = *head; n; n = n->next)
3776 6685 : n->u.map.op = map_op;
3777 5114 : continue;
3778 5114 : }
3779 3 : gfc_current_locus = old_loc;
3780 3 : break;
3781 : }
3782 126 : if ((mask & OMP_CLAUSE_MERGEABLE)
3783 92 : && (m = gfc_match_dupl_check (!c->mergeable, "mergeable"))
3784 : != MATCH_NO)
3785 : {
3786 34 : if (m == MATCH_ERROR)
3787 0 : goto error;
3788 34 : c->mergeable = true;
3789 34 : continue;
3790 : }
3791 111 : if ((mask & OMP_CLAUSE_MESSAGE)
3792 58 : && (m = gfc_match_dupl_check (!c->message, "message", true,
3793 : &c->message)) != MATCH_NO)
3794 : {
3795 58 : if (m == MATCH_ERROR)
3796 5 : goto error;
3797 53 : continue;
3798 : }
3799 : break;
3800 2910 : case 'n':
3801 2962 : if ((mask & OMP_CLAUSE_NO_CREATE)
3802 1343 : && gfc_match ("no_create ( ") == MATCH_YES
3803 2962 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
3804 : OMP_MAP_IF_PRESENT, true,
3805 : allow_derived))
3806 52 : continue;
3807 2859 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3808 2884 : && (m = gfc_match_dupl_check (!c->assume
3809 26 : || !c->assume->no_openmp_constructs,
3810 : "no_openmp_constructs")) != MATCH_NO)
3811 : {
3812 2 : if (m == MATCH_ERROR)
3813 1 : goto error;
3814 1 : if (c->assume == NULL)
3815 0 : c->assume = gfc_get_omp_assumptions ();
3816 1 : c->assume->no_openmp_constructs = true;
3817 1 : continue;
3818 : }
3819 2869 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3820 2880 : && (m = gfc_match_dupl_check (!c->assume
3821 24 : || !c->assume->no_openmp_routines,
3822 : "no_openmp_routines")) != MATCH_NO)
3823 : {
3824 13 : if (m == MATCH_ERROR)
3825 0 : goto error;
3826 13 : if (c->assume == NULL)
3827 12 : c->assume = gfc_get_omp_assumptions ();
3828 13 : c->assume->no_openmp_routines = true;
3829 13 : continue;
3830 : }
3831 2847 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3832 2853 : && (m = gfc_match_dupl_check (!c->assume || !c->assume->no_openmp,
3833 : "no_openmp")) != MATCH_NO)
3834 : {
3835 4 : if (m == MATCH_ERROR)
3836 0 : goto error;
3837 4 : if (c->assume == NULL)
3838 4 : c->assume = gfc_get_omp_assumptions ();
3839 4 : c->assume->no_openmp = true;
3840 4 : continue;
3841 : }
3842 2845 : if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3843 2846 : && (m = gfc_match_dupl_check (!c->assume
3844 7 : || !c->assume->no_parallelism,
3845 : "no_parallelism")) != MATCH_NO)
3846 : {
3847 6 : if (m == MATCH_ERROR)
3848 0 : goto error;
3849 6 : if (c->assume == NULL)
3850 6 : c->assume = gfc_get_omp_assumptions ();
3851 6 : c->assume->no_parallelism = true;
3852 6 : continue;
3853 : }
3854 :
3855 2843 : if ((mask & OMP_CLAUSE_NOVARIANTS)
3856 2833 : && (m = gfc_match_dupl_check (!c->novariants, "novariants", true,
3857 : &c->novariants))
3858 : != MATCH_NO)
3859 : {
3860 12 : if (m == MATCH_ERROR)
3861 2 : goto error;
3862 10 : continue;
3863 : }
3864 2834 : if ((mask & OMP_CLAUSE_NOCONTEXT)
3865 2821 : && (m = gfc_match_dupl_check (!c->nocontext, "nocontext", true,
3866 : &c->nocontext))
3867 : != MATCH_NO)
3868 : {
3869 15 : if (m == MATCH_ERROR)
3870 2 : goto error;
3871 13 : continue;
3872 : }
3873 2820 : if ((mask & OMP_CLAUSE_NOGROUP)
3874 2806 : && (m = gfc_match_dupl_check (!c->nogroup, "nogroup"))
3875 : != MATCH_NO)
3876 : {
3877 14 : if (m == MATCH_ERROR)
3878 0 : goto error;
3879 14 : c->nogroup = true;
3880 14 : continue;
3881 : }
3882 2942 : if ((mask & OMP_CLAUSE_NOHOST)
3883 2792 : && (m = gfc_match_dupl_check (!c->nohost, "nohost")) != MATCH_NO)
3884 : {
3885 151 : if (m == MATCH_ERROR)
3886 1 : goto error;
3887 150 : c->nohost = true;
3888 150 : continue;
3889 : }
3890 2683 : if ((mask & OMP_CLAUSE_NOTEMPORAL)
3891 2641 : && gfc_match_omp_variable_list ("nontemporal (",
3892 : &c->lists[OMP_LIST_NONTEMPORAL],
3893 : true) == MATCH_YES)
3894 42 : continue;
3895 2623 : if ((mask & OMP_CLAUSE_NOTINBRANCH)
3896 2600 : && (m = gfc_match_dupl_check (!c->notinbranch && !c->inbranch,
3897 : "notinbranch")) != MATCH_NO)
3898 : {
3899 25 : if (m == MATCH_ERROR)
3900 1 : goto error;
3901 24 : c->notinbranch = true;
3902 24 : continue;
3903 : }
3904 2703 : if ((mask & OMP_CLAUSE_NOWAIT)
3905 2574 : && (m = gfc_match_dupl_check (!c->nowait, "nowait")) != MATCH_NO)
3906 : {
3907 132 : if (m == MATCH_ERROR)
3908 3 : goto error;
3909 129 : c->nowait = true;
3910 129 : continue;
3911 : }
3912 3124 : if ((mask & OMP_CLAUSE_NUM_GANGS)
3913 2442 : && (m = gfc_match_dupl_check (!c->num_gangs_expr, "num_gangs",
3914 : true)) != MATCH_NO)
3915 : {
3916 686 : if (m == MATCH_ERROR)
3917 2 : goto error;
3918 684 : if (gfc_match (" %e )", &c->num_gangs_expr) != MATCH_YES)
3919 2 : goto error;
3920 682 : continue;
3921 : }
3922 1782 : if ((mask & OMP_CLAUSE_NUM_TASKS)
3923 1756 : && (m = gfc_match_dupl_check (!c->num_tasks, "num_tasks", true))
3924 : != MATCH_NO)
3925 : {
3926 26 : if (m == MATCH_ERROR)
3927 0 : goto error;
3928 26 : if (gfc_match ("strict : ") == MATCH_YES)
3929 1 : c->num_tasks_strict = true;
3930 26 : if (gfc_match (" %e )", &c->num_tasks) != MATCH_YES)
3931 0 : goto error;
3932 26 : continue;
3933 : }
3934 1857 : if ((mask & OMP_CLAUSE_NUM_TEAMS)
3935 1730 : && (m = gfc_match_dupl_check (!c->num_teams_upper, "num_teams",
3936 : true)) != MATCH_NO)
3937 : {
3938 127 : if (m == MATCH_ERROR)
3939 0 : goto error;
3940 127 : if (gfc_match ("%e ", &c->num_teams_upper) != MATCH_YES)
3941 0 : goto error;
3942 127 : if (gfc_peek_ascii_char () == ':')
3943 : {
3944 21 : c->num_teams_lower = c->num_teams_upper;
3945 21 : c->num_teams_upper = NULL;
3946 21 : if (gfc_match (": %e ", &c->num_teams_upper) != MATCH_YES)
3947 0 : goto error;
3948 : }
3949 127 : if (gfc_match (") ") != MATCH_YES)
3950 0 : goto error;
3951 127 : continue;
3952 : }
3953 2565 : if ((mask & OMP_CLAUSE_NUM_THREADS)
3954 1603 : && (m = gfc_match_dupl_check (!c->num_threads, "num_threads", true,
3955 : &c->num_threads)) != MATCH_NO)
3956 : {
3957 962 : if (m == MATCH_ERROR)
3958 0 : goto error;
3959 962 : continue;
3960 : }
3961 1240 : if ((mask & OMP_CLAUSE_NUM_WORKERS)
3962 641 : && (m = gfc_match_dupl_check (!c->num_workers_expr, "num_workers",
3963 : true, &c->num_workers_expr))
3964 : != MATCH_NO)
3965 : {
3966 603 : if (m == MATCH_ERROR)
3967 4 : goto error;
3968 599 : continue;
3969 : }
3970 : break;
3971 591 : case 'o':
3972 591 : if ((mask & OMP_CLAUSE_ORDERED)
3973 591 : && (m = gfc_match_dupl_check (!c->ordered, "ordered"))
3974 : != MATCH_NO)
3975 : {
3976 343 : if (m == MATCH_ERROR)
3977 0 : goto error;
3978 343 : gfc_expr *cexpr = NULL;
3979 343 : m = gfc_match (" ( %e )", &cexpr);
3980 :
3981 343 : c->ordered = true;
3982 343 : if (m == MATCH_YES)
3983 : {
3984 144 : int ordered = 0;
3985 144 : if (gfc_extract_int (cexpr, &ordered, -1))
3986 0 : ordered = 0;
3987 144 : else if (ordered <= 0)
3988 : {
3989 0 : gfc_error_now ("ORDERED clause argument not"
3990 : " constant positive integer at %C");
3991 0 : ordered = 0;
3992 : }
3993 144 : c->orderedc = ordered;
3994 144 : gfc_free_expr (cexpr);
3995 144 : continue;
3996 144 : }
3997 :
3998 199 : continue;
3999 199 : }
4000 482 : if ((mask & OMP_CLAUSE_ORDER)
4001 248 : && (m = gfc_match_dupl_check (!c->order_concurrent, "order", true))
4002 : != MATCH_NO)
4003 : {
4004 247 : if (m == MATCH_ERROR)
4005 10 : goto error;
4006 237 : if (gfc_match (" reproducible : concurrent )") == MATCH_YES)
4007 55 : c->order_reproducible = true;
4008 182 : else if (gfc_match (" concurrent )") == MATCH_YES)
4009 : ;
4010 50 : else if (gfc_match (" unconstrained : concurrent )") == MATCH_YES)
4011 47 : c->order_unconstrained = true;
4012 : else
4013 : {
4014 3 : gfc_error ("Expected ORDER(CONCURRENT) at %C "
4015 : "with optional %<reproducible%> or "
4016 : "%<unconstrained%> modifier");
4017 3 : goto error;
4018 : }
4019 234 : c->order_concurrent = true;
4020 234 : continue;
4021 : }
4022 : break;
4023 3101 : case 'p':
4024 3101 : if (mask & OMP_CLAUSE_PARTIAL)
4025 : {
4026 276 : if ((m = gfc_match_dupl_check (!c->partial, "partial"))
4027 : != MATCH_NO)
4028 : {
4029 276 : int expr;
4030 276 : if (m == MATCH_ERROR)
4031 0 : goto error;
4032 :
4033 276 : c->partial = -1;
4034 :
4035 276 : gfc_expr *cexpr = NULL;
4036 276 : m = gfc_match (" ( %e )", &cexpr);
4037 276 : if (m == MATCH_NO)
4038 : ;
4039 251 : else if (m == MATCH_YES
4040 251 : && !gfc_extract_int (cexpr, &expr, -1)
4041 502 : && expr > 0)
4042 247 : c->partial = expr;
4043 : else
4044 4 : gfc_error_now ("PARTIAL clause argument not constant "
4045 : "positive integer at %C");
4046 276 : gfc_free_expr (cexpr);
4047 276 : continue;
4048 276 : }
4049 : }
4050 2894 : if ((mask & OMP_CLAUSE_COPY)
4051 877 : && gfc_match ("pcopy ( ") == MATCH_YES
4052 2895 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4053 : OMP_MAP_TOFROM, true, allow_derived))
4054 69 : continue;
4055 2830 : if ((mask & OMP_CLAUSE_COPYIN)
4056 1910 : && gfc_match ("pcopyin ( ") == MATCH_YES
4057 2830 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4058 : OMP_MAP_TO, true, allow_derived))
4059 74 : continue;
4060 2755 : if ((mask & OMP_CLAUSE_COPYOUT)
4061 735 : && gfc_match ("pcopyout ( ") == MATCH_YES
4062 2755 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4063 : OMP_MAP_FROM, true, allow_derived))
4064 73 : continue;
4065 2624 : if ((mask & OMP_CLAUSE_CREATE)
4066 672 : && gfc_match ("pcreate ( ") == MATCH_YES
4067 2624 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4068 : OMP_MAP_ALLOC, true, allow_derived))
4069 15 : continue;
4070 3010 : if ((mask & OMP_CLAUSE_PRESENT)
4071 647 : && gfc_match ("present ( ") == MATCH_YES
4072 3012 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4073 : OMP_MAP_FORCE_PRESENT, false,
4074 : allow_derived))
4075 416 : continue;
4076 2201 : if ((mask & OMP_CLAUSE_COPY)
4077 231 : && gfc_match ("present_or_copy ( ") == MATCH_YES
4078 2201 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4079 : OMP_MAP_TOFROM, true,
4080 : allow_derived))
4081 23 : continue;
4082 2195 : if ((mask & OMP_CLAUSE_COPYIN)
4083 1309 : && gfc_match ("present_or_copyin ( ") == MATCH_YES
4084 2195 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4085 : OMP_MAP_TO, true, allow_derived))
4086 40 : continue;
4087 2150 : if ((mask & OMP_CLAUSE_COPYOUT)
4088 173 : && gfc_match ("present_or_copyout ( ") == MATCH_YES
4089 2150 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4090 : OMP_MAP_FROM, true, allow_derived))
4091 35 : continue;
4092 2108 : if ((mask & OMP_CLAUSE_CREATE)
4093 143 : && gfc_match ("present_or_create ( ") == MATCH_YES
4094 2108 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4095 : OMP_MAP_ALLOC, true, allow_derived))
4096 28 : continue;
4097 2086 : if ((mask & OMP_CLAUSE_PRIORITY)
4098 2052 : && (m = gfc_match_dupl_check (!c->priority, "priority", true,
4099 : &c->priority)) != MATCH_NO)
4100 : {
4101 34 : if (m == MATCH_ERROR)
4102 0 : goto error;
4103 34 : continue;
4104 : }
4105 3959 : if ((mask & OMP_CLAUSE_PRIVATE)
4106 2018 : && gfc_match_omp_variable_list ("private (",
4107 : &c->lists[OMP_LIST_PRIVATE],
4108 : true) == MATCH_YES)
4109 1941 : continue;
4110 141 : if ((mask & OMP_CLAUSE_PROC_BIND)
4111 141 : && (m = gfc_match_dupl_check ((c->proc_bind
4112 64 : == OMP_PROC_BIND_UNKNOWN),
4113 : "proc_bind", true)) != MATCH_NO)
4114 : {
4115 64 : if (m == MATCH_ERROR)
4116 0 : goto error;
4117 64 : if (gfc_match ("primary )") == MATCH_YES)
4118 1 : c->proc_bind = OMP_PROC_BIND_PRIMARY;
4119 63 : else if (gfc_match ("master )") == MATCH_YES)
4120 : {
4121 9 : gfc_warning (OPT_Wdeprecated_openmp,
4122 : "%<master%> affinity policy at %C deprecated "
4123 : "since OpenMP 5.1, use %<primary%>");
4124 9 : c->proc_bind = OMP_PROC_BIND_MASTER;
4125 : }
4126 54 : else if (gfc_match ("spread )") == MATCH_YES)
4127 53 : c->proc_bind = OMP_PROC_BIND_SPREAD;
4128 1 : else if (gfc_match ("close )") == MATCH_YES)
4129 1 : c->proc_bind = OMP_PROC_BIND_CLOSE;
4130 : else
4131 0 : goto error;
4132 64 : continue;
4133 : }
4134 : break;
4135 4580 : case 'r':
4136 5070 : if ((mask & OMP_CLAUSE_ATOMIC)
4137 4580 : && (m = gfc_match_dupl_atomic ((c->atomic_op
4138 : == GFC_OMP_ATOMIC_UNSET),
4139 : "read")) != MATCH_NO)
4140 : {
4141 490 : if (m == MATCH_ERROR)
4142 0 : goto error;
4143 490 : c->atomic_op = GFC_OMP_ATOMIC_READ;
4144 490 : continue;
4145 : }
4146 8143 : if ((mask & OMP_CLAUSE_REDUCTION)
4147 4090 : && gfc_match_omp_clause_reduction (pc, c, openacc,
4148 : allow_derived) == MATCH_YES)
4149 4053 : continue;
4150 47 : if ((mask & OMP_CLAUSE_MEMORDER)
4151 65 : && (m = gfc_match_dupl_memorder ((c->memorder
4152 28 : == OMP_MEMORDER_UNSET),
4153 : "relaxed")) != MATCH_NO)
4154 : {
4155 10 : if (m == MATCH_ERROR)
4156 0 : goto error;
4157 10 : c->memorder = OMP_MEMORDER_RELAXED;
4158 10 : continue;
4159 : }
4160 44 : if ((mask & OMP_CLAUSE_MEMORDER)
4161 45 : && (m = gfc_match_dupl_memorder ((c->memorder
4162 18 : == OMP_MEMORDER_UNSET),
4163 : "release")) != MATCH_NO)
4164 : {
4165 18 : if (m == MATCH_ERROR)
4166 1 : goto error;
4167 17 : c->memorder = OMP_MEMORDER_RELEASE;
4168 17 : continue;
4169 : }
4170 : break;
4171 3036 : case 's':
4172 3129 : if ((mask & OMP_CLAUSE_SAFELEN)
4173 3036 : && (m = gfc_match_dupl_check (!c->safelen_expr, "safelen",
4174 : true, &c->safelen_expr))
4175 : != MATCH_NO)
4176 : {
4177 93 : if (m == MATCH_ERROR)
4178 0 : goto error;
4179 93 : continue;
4180 : }
4181 2943 : if ((mask & OMP_CLAUSE_SCHEDULE)
4182 2943 : && (m = gfc_match_dupl_check (c->sched_kind == OMP_SCHED_NONE,
4183 : "schedule", true)) != MATCH_NO)
4184 : {
4185 809 : if (m == MATCH_ERROR)
4186 0 : goto error;
4187 809 : int nmodifiers = 0;
4188 809 : locus old_loc2 = gfc_current_locus;
4189 827 : do
4190 : {
4191 818 : if (gfc_match ("simd") == MATCH_YES)
4192 : {
4193 18 : c->sched_simd = true;
4194 18 : nmodifiers++;
4195 : }
4196 800 : else if (gfc_match ("monotonic") == MATCH_YES)
4197 : {
4198 30 : c->sched_monotonic = true;
4199 30 : nmodifiers++;
4200 : }
4201 770 : else if (gfc_match ("nonmonotonic") == MATCH_YES)
4202 : {
4203 35 : c->sched_nonmonotonic = true;
4204 35 : nmodifiers++;
4205 : }
4206 : else
4207 : {
4208 735 : if (nmodifiers)
4209 0 : gfc_current_locus = old_loc2;
4210 : break;
4211 : }
4212 92 : if (nmodifiers == 1
4213 83 : && gfc_match (" , ") == MATCH_YES)
4214 9 : continue;
4215 74 : else if (gfc_match (" : ") == MATCH_YES)
4216 : break;
4217 0 : gfc_current_locus = old_loc2;
4218 0 : break;
4219 : }
4220 : while (1);
4221 809 : if (gfc_match ("static") == MATCH_YES)
4222 425 : c->sched_kind = OMP_SCHED_STATIC;
4223 384 : else if (gfc_match ("dynamic") == MATCH_YES)
4224 164 : c->sched_kind = OMP_SCHED_DYNAMIC;
4225 220 : else if (gfc_match ("guided") == MATCH_YES)
4226 127 : c->sched_kind = OMP_SCHED_GUIDED;
4227 93 : else if (gfc_match ("runtime") == MATCH_YES)
4228 85 : c->sched_kind = OMP_SCHED_RUNTIME;
4229 8 : else if (gfc_match ("auto") == MATCH_YES)
4230 8 : c->sched_kind = OMP_SCHED_AUTO;
4231 809 : if (c->sched_kind != OMP_SCHED_NONE)
4232 : {
4233 809 : m = MATCH_NO;
4234 809 : if (c->sched_kind != OMP_SCHED_RUNTIME
4235 809 : && c->sched_kind != OMP_SCHED_AUTO)
4236 716 : m = gfc_match (" , %e )", &c->chunk_size);
4237 716 : if (m != MATCH_YES)
4238 299 : m = gfc_match_char (')');
4239 299 : if (m != MATCH_YES)
4240 0 : c->sched_kind = OMP_SCHED_NONE;
4241 : }
4242 809 : if (c->sched_kind != OMP_SCHED_NONE)
4243 809 : continue;
4244 : else
4245 0 : gfc_current_locus = old_loc;
4246 : }
4247 2317 : if ((mask & OMP_CLAUSE_SELF)
4248 335 : && !(mask & OMP_CLAUSE_HOST) /* OpenACC compute construct */
4249 2374 : && (m = gfc_match_dupl_check (!c->self_expr, "self"))
4250 : != MATCH_NO)
4251 : {
4252 186 : if (m == MATCH_ERROR)
4253 3 : goto error;
4254 183 : m = gfc_match (" ( %e )", &c->self_expr);
4255 183 : if (m == MATCH_ERROR)
4256 : {
4257 0 : gfc_current_locus = old_loc;
4258 0 : break;
4259 : }
4260 183 : else if (m == MATCH_NO)
4261 9 : c->self_expr = gfc_get_logical_expr (gfc_default_logical_kind,
4262 : NULL, true);
4263 183 : continue;
4264 : }
4265 2042 : if ((mask & OMP_CLAUSE_SELF)
4266 149 : && (mask & OMP_CLAUSE_HOST) /* OpenACC 'update' directive */
4267 95 : && gfc_match ("self ( ") == MATCH_YES
4268 2043 : && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
4269 : OMP_MAP_FORCE_FROM, true,
4270 : /* allow_derived = */ true))
4271 94 : continue;
4272 2202 : if ((mask & OMP_CLAUSE_SEQ)
4273 1854 : && (m = gfc_match_dupl_check (!c->seq, "seq")) != MATCH_NO)
4274 : {
4275 348 : if (m == MATCH_ERROR)
4276 0 : goto error;
4277 348 : c->seq = true;
4278 348 : continue;
4279 : }
4280 1647 : if ((mask & OMP_CLAUSE_MEMORDER)
4281 1647 : && (m = gfc_match_dupl_memorder ((c->memorder
4282 141 : == OMP_MEMORDER_UNSET),
4283 : "seq_cst")) != MATCH_NO)
4284 : {
4285 141 : if (m == MATCH_ERROR)
4286 0 : goto error;
4287 141 : c->memorder = OMP_MEMORDER_SEQ_CST;
4288 141 : continue;
4289 : }
4290 2340 : if ((mask & OMP_CLAUSE_SHARED)
4291 1365 : && gfc_match_omp_variable_list ("shared (",
4292 : &c->lists[OMP_LIST_SHARED],
4293 : true) == MATCH_YES)
4294 975 : continue;
4295 508 : if ((mask & OMP_CLAUSE_SIMDLEN)
4296 390 : && (m = gfc_match_dupl_check (!c->simdlen_expr, "simdlen", true,
4297 : &c->simdlen_expr)) != MATCH_NO)
4298 : {
4299 118 : if (m == MATCH_ERROR)
4300 0 : goto error;
4301 118 : continue;
4302 : }
4303 294 : if ((mask & OMP_CLAUSE_SIMD)
4304 272 : && (m = gfc_match_dupl_check (!c->simd, "simd")) != MATCH_NO)
4305 : {
4306 22 : if (m == MATCH_ERROR)
4307 0 : goto error;
4308 22 : c->simd = true;
4309 22 : continue;
4310 : }
4311 289 : if ((mask & OMP_CLAUSE_SEVERITY)
4312 250 : && (m = gfc_match_dupl_check (!c->severity, "severity", true))
4313 : != MATCH_NO)
4314 : {
4315 45 : if (m == MATCH_ERROR)
4316 2 : goto error;
4317 43 : if (gfc_match ("fatal )") == MATCH_YES)
4318 10 : c->severity = OMP_SEVERITY_FATAL;
4319 33 : else if (gfc_match ("warning )") == MATCH_YES)
4320 29 : c->severity = OMP_SEVERITY_WARNING;
4321 : else
4322 : {
4323 4 : gfc_error ("Expected FATAL or WARNING in SEVERITY clause "
4324 : "at %C");
4325 4 : goto error;
4326 : }
4327 39 : continue;
4328 : }
4329 205 : if ((mask & OMP_CLAUSE_SIZES)
4330 205 : && ((m = gfc_match_dupl_check (!c->sizes_list, "sizes"))
4331 : != MATCH_NO))
4332 : {
4333 203 : if (m == MATCH_ERROR)
4334 0 : goto error;
4335 203 : m = match_omp_oacc_expr_list (" (", &c->sizes_list, false, true);
4336 203 : if (m == MATCH_ERROR)
4337 7 : goto error;
4338 196 : if (m == MATCH_YES)
4339 195 : continue;
4340 1 : gfc_error ("Expected %<(%> after %qs at %C", "sizes");
4341 1 : goto error;
4342 : }
4343 : break;
4344 1203 : case 't':
4345 1268 : if ((mask & OMP_CLAUSE_TASK_REDUCTION)
4346 1203 : && gfc_match_omp_clause_reduction (pc, c, openacc,
4347 : allow_derived) == MATCH_YES)
4348 65 : continue;
4349 1210 : if ((mask & OMP_CLAUSE_THREAD_LIMIT)
4350 1138 : && (m = gfc_match_dupl_check (!c->thread_limit, "thread_limit",
4351 : true, &c->thread_limit))
4352 : != MATCH_NO)
4353 : {
4354 72 : if (m == MATCH_ERROR)
4355 0 : goto error;
4356 72 : continue;
4357 : }
4358 1079 : if ((mask & OMP_CLAUSE_THREADS)
4359 1066 : && (m = gfc_match_dupl_check (!c->threads, "threads"))
4360 : != MATCH_NO)
4361 : {
4362 13 : if (m == MATCH_ERROR)
4363 0 : goto error;
4364 13 : c->threads = true;
4365 13 : continue;
4366 : }
4367 1250 : if ((mask & OMP_CLAUSE_TILE)
4368 221 : && !c->tile_list
4369 1274 : && match_omp_oacc_expr_list ("tile (", &c->tile_list,
4370 : true, false) == MATCH_YES)
4371 197 : continue;
4372 856 : if ((mask & OMP_CLAUSE_TO) && (mask & OMP_CLAUSE_LINK))
4373 : {
4374 : /* Declare target: 'to' is an alias for 'enter';
4375 : 'to' is deprecated since 5.2. */
4376 116 : m = gfc_match_omp_to_link ("to (", &c->lists[OMP_LIST_TO]);
4377 116 : if (m == MATCH_ERROR)
4378 0 : goto error;
4379 116 : if (m == MATCH_YES)
4380 : {
4381 116 : gfc_warning (OPT_Wdeprecated_openmp,
4382 : "%<to%> clause with %<declare target%> at %L "
4383 : "deprecated since OpenMP 5.2, use %<enter%>",
4384 : &old_loc);
4385 116 : continue;
4386 : }
4387 : }
4388 1456 : else if ((mask & OMP_CLAUSE_TO)
4389 740 : && gfc_match_motion_var_list ("to (", &c->lists[OMP_LIST_TO],
4390 : &head) == MATCH_YES)
4391 716 : continue;
4392 : break;
4393 1516 : case 'u':
4394 1574 : if ((mask & OMP_CLAUSE_UNIFORM)
4395 1516 : && gfc_match_omp_variable_list ("uniform (",
4396 : &c->lists[OMP_LIST_UNIFORM],
4397 : false) == MATCH_YES)
4398 58 : continue;
4399 1599 : if ((mask & OMP_CLAUSE_UNTIED)
4400 1458 : && (m = gfc_match_dupl_check (!c->untied, "untied")) != MATCH_NO)
4401 : {
4402 141 : if (m == MATCH_ERROR)
4403 0 : goto error;
4404 141 : c->untied = true;
4405 141 : continue;
4406 : }
4407 1561 : if ((mask & OMP_CLAUSE_ATOMIC)
4408 1317 : && (m = gfc_match_dupl_atomic ((c->atomic_op
4409 : == GFC_OMP_ATOMIC_UNSET),
4410 : "update")) != MATCH_NO)
4411 : {
4412 245 : if (m == MATCH_ERROR)
4413 1 : goto error;
4414 244 : c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
4415 244 : continue;
4416 : }
4417 1094 : if ((mask & OMP_CLAUSE_USE)
4418 1072 : && gfc_match_omp_variable_list ("use (",
4419 : &c->lists[OMP_LIST_USE],
4420 : true) == MATCH_YES)
4421 22 : continue;
4422 1110 : if ((mask & OMP_CLAUSE_USE_DEVICE)
4423 1050 : && gfc_match_omp_variable_list ("use_device (",
4424 : &c->lists[OMP_LIST_USE_DEVICE],
4425 : true) == MATCH_YES)
4426 60 : continue;
4427 1153 : if ((mask & OMP_CLAUSE_USE_DEVICE_PTR)
4428 1918 : && gfc_match_omp_variable_list
4429 928 : ("use_device_ptr (",
4430 : &c->lists[OMP_LIST_USE_DEVICE_PTR], false) == MATCH_YES)
4431 163 : continue;
4432 1592 : if ((mask & OMP_CLAUSE_USE_DEVICE_ADDR)
4433 1592 : && gfc_match_omp_variable_list
4434 765 : ("use_device_addr (", &c->lists[OMP_LIST_USE_DEVICE_ADDR],
4435 : false, NULL, NULL, true) == MATCH_YES)
4436 765 : continue;
4437 114 : if ((mask & OMP_CLAUSE_USES_ALLOCATORS)
4438 62 : && (gfc_match ("uses_allocators ( ") == MATCH_YES))
4439 : {
4440 56 : if (gfc_match_omp_clause_uses_allocators (c) != MATCH_YES)
4441 4 : goto error;
4442 52 : continue;
4443 : }
4444 : break;
4445 1570 : case 'v':
4446 : /* VECTOR_LENGTH must be matched before VECTOR, because the latter
4447 : doesn't unconditionally match '('. */
4448 2139 : if ((mask & OMP_CLAUSE_VECTOR_LENGTH)
4449 1570 : && (m = gfc_match_dupl_check (!c->vector_length_expr,
4450 : "vector_length", true,
4451 : &c->vector_length_expr))
4452 : != MATCH_NO)
4453 : {
4454 573 : if (m == MATCH_ERROR)
4455 4 : goto error;
4456 569 : continue;
4457 : }
4458 1989 : if ((mask & OMP_CLAUSE_VECTOR)
4459 997 : && (m = gfc_match_dupl_check (!c->vector, "vector")) != MATCH_NO)
4460 : {
4461 995 : if (m == MATCH_ERROR)
4462 0 : goto error;
4463 995 : c->vector = true;
4464 995 : m = match_oacc_clause_gwv (c, GOMP_DIM_VECTOR);
4465 995 : if (m == MATCH_ERROR)
4466 3 : goto error;
4467 992 : continue;
4468 : }
4469 : break;
4470 1482 : case 'w':
4471 1482 : if ((mask & OMP_CLAUSE_WAIT)
4472 1482 : && gfc_match ("wait") == MATCH_YES)
4473 : {
4474 192 : m = match_omp_oacc_expr_list (" (", &c->wait_list, false, false);
4475 192 : if (m == MATCH_ERROR)
4476 9 : goto error;
4477 183 : else if (m == MATCH_NO)
4478 : {
4479 47 : gfc_expr *expr
4480 47 : = gfc_get_constant_expr (BT_INTEGER,
4481 : gfc_default_integer_kind,
4482 : &gfc_current_locus);
4483 47 : mpz_set_si (expr->value.integer, GOMP_ASYNC_NOVAL);
4484 47 : gfc_expr_list **expr_list = &c->wait_list;
4485 56 : while (*expr_list)
4486 9 : expr_list = &(*expr_list)->next;
4487 47 : *expr_list = gfc_get_expr_list ();
4488 47 : (*expr_list)->expr = expr;
4489 47 : needs_space = true;
4490 : }
4491 183 : continue;
4492 183 : }
4493 1303 : if ((mask & OMP_CLAUSE_WEAK)
4494 1290 : && (m = gfc_match_dupl_check (!c->weak, "weak"))
4495 : != MATCH_NO)
4496 : {
4497 14 : if (m == MATCH_ERROR)
4498 1 : goto error;
4499 13 : c->weak = true;
4500 13 : continue;
4501 : }
4502 2137 : if ((mask & OMP_CLAUSE_WORKER)
4503 1276 : && (m = gfc_match_dupl_check (!c->worker, "worker")) != MATCH_NO)
4504 : {
4505 864 : if (m == MATCH_ERROR)
4506 0 : goto error;
4507 864 : c->worker = true;
4508 864 : m = match_oacc_clause_gwv (c, GOMP_DIM_WORKER);
4509 864 : if (m == MATCH_ERROR)
4510 3 : goto error;
4511 861 : continue;
4512 : }
4513 824 : if ((mask & OMP_CLAUSE_ATOMIC)
4514 412 : && (m = gfc_match_dupl_atomic ((c->atomic_op
4515 : == GFC_OMP_ATOMIC_UNSET),
4516 : "write")) != MATCH_NO)
4517 : {
4518 412 : if (m == MATCH_ERROR)
4519 0 : goto error;
4520 412 : c->atomic_op = GFC_OMP_ATOMIC_WRITE;
4521 412 : continue;
4522 : }
4523 : break;
4524 : }
4525 : break;
4526 45461 : }
4527 :
4528 34124 : end:
4529 33870 : if (error || gfc_match_omp_eos () != MATCH_YES)
4530 : {
4531 521 : if (!gfc_error_flag_test ())
4532 137 : gfc_error ("Failed to match clause at %C");
4533 521 : gfc_free_omp_clauses (c);
4534 521 : return MATCH_ERROR;
4535 : }
4536 :
4537 33603 : *cp = c;
4538 33603 : return MATCH_YES;
4539 :
4540 254 : error:
4541 254 : error = true;
4542 254 : goto end;
4543 : }
4544 :
4545 :
4546 : #define OACC_PARALLEL_CLAUSES \
4547 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
4548 : | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_REDUCTION \
4549 : | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
4550 : | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
4551 : | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
4552 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \
4553 : | OMP_CLAUSE_SELF)
4554 : #define OACC_KERNELS_CLAUSES \
4555 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
4556 : | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_DEVICEPTR \
4557 : | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
4558 : | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
4559 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \
4560 : | OMP_CLAUSE_SELF)
4561 : #define OACC_SERIAL_CLAUSES \
4562 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_REDUCTION \
4563 : | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
4564 : | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
4565 : | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
4566 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \
4567 : | OMP_CLAUSE_SELF)
4568 : #define OACC_DATA_CLAUSES \
4569 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_COPY \
4570 : | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_CREATE \
4571 : | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_ATTACH \
4572 : | OMP_CLAUSE_DEFAULT)
4573 : #define OACC_LOOP_CLAUSES \
4574 : (omp_mask (OMP_CLAUSE_COLLAPSE) | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER \
4575 : | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ | OMP_CLAUSE_INDEPENDENT \
4576 : | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_AUTO \
4577 : | OMP_CLAUSE_TILE)
4578 : #define OACC_PARALLEL_LOOP_CLAUSES \
4579 : (OACC_LOOP_CLAUSES | OACC_PARALLEL_CLAUSES)
4580 : #define OACC_KERNELS_LOOP_CLAUSES \
4581 : (OACC_LOOP_CLAUSES | OACC_KERNELS_CLAUSES)
4582 : #define OACC_SERIAL_LOOP_CLAUSES \
4583 : (OACC_LOOP_CLAUSES | OACC_SERIAL_CLAUSES)
4584 : #define OACC_HOST_DATA_CLAUSES \
4585 : (omp_mask (OMP_CLAUSE_USE_DEVICE) \
4586 : | OMP_CLAUSE_IF \
4587 : | OMP_CLAUSE_IF_PRESENT)
4588 : #define OACC_DECLARE_CLAUSES \
4589 : (omp_mask (OMP_CLAUSE_COPY) | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
4590 : | OMP_CLAUSE_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_DEVICE_RESIDENT \
4591 : | OMP_CLAUSE_PRESENT \
4592 : | OMP_CLAUSE_LINK)
4593 : #define OACC_UPDATE_CLAUSES \
4594 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_HOST \
4595 : | OMP_CLAUSE_DEVICE | OMP_CLAUSE_WAIT | OMP_CLAUSE_IF_PRESENT \
4596 : | OMP_CLAUSE_SELF)
4597 : #define OACC_ENTER_DATA_CLAUSES \
4598 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
4599 : | OMP_CLAUSE_COPYIN | OMP_CLAUSE_CREATE | OMP_CLAUSE_ATTACH)
4600 : #define OACC_EXIT_DATA_CLAUSES \
4601 : (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
4602 : | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE | OMP_CLAUSE_FINALIZE \
4603 : | OMP_CLAUSE_DETACH)
4604 : #define OACC_WAIT_CLAUSES \
4605 : omp_mask (OMP_CLAUSE_ASYNC) | OMP_CLAUSE_IF
4606 : #define OACC_ROUTINE_CLAUSES \
4607 : (omp_mask (OMP_CLAUSE_GANG) | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR \
4608 : | OMP_CLAUSE_SEQ \
4609 : | OMP_CLAUSE_NOHOST)
4610 :
4611 :
4612 : static match
4613 11804 : match_acc (gfc_exec_op op, const omp_mask mask)
4614 : {
4615 11804 : gfc_omp_clauses *c;
4616 11804 : if (gfc_match_omp_clauses (&c, mask, false, false, true) != MATCH_YES)
4617 : return MATCH_ERROR;
4618 11599 : new_st.op = op;
4619 11599 : new_st.ext.omp_clauses = c;
4620 11599 : return MATCH_YES;
4621 : }
4622 :
4623 : match
4624 1378 : gfc_match_oacc_parallel_loop (void)
4625 : {
4626 1378 : return match_acc (EXEC_OACC_PARALLEL_LOOP, OACC_PARALLEL_LOOP_CLAUSES);
4627 : }
4628 :
4629 :
4630 : match
4631 2974 : gfc_match_oacc_parallel (void)
4632 : {
4633 2974 : return match_acc (EXEC_OACC_PARALLEL, OACC_PARALLEL_CLAUSES);
4634 : }
4635 :
4636 :
4637 : match
4638 129 : gfc_match_oacc_kernels_loop (void)
4639 : {
4640 129 : return match_acc (EXEC_OACC_KERNELS_LOOP, OACC_KERNELS_LOOP_CLAUSES);
4641 : }
4642 :
4643 :
4644 : match
4645 906 : gfc_match_oacc_kernels (void)
4646 : {
4647 906 : return match_acc (EXEC_OACC_KERNELS, OACC_KERNELS_CLAUSES);
4648 : }
4649 :
4650 :
4651 : match
4652 230 : gfc_match_oacc_serial_loop (void)
4653 : {
4654 230 : return match_acc (EXEC_OACC_SERIAL_LOOP, OACC_SERIAL_LOOP_CLAUSES);
4655 : }
4656 :
4657 :
4658 : match
4659 359 : gfc_match_oacc_serial (void)
4660 : {
4661 359 : return match_acc (EXEC_OACC_SERIAL, OACC_SERIAL_CLAUSES);
4662 : }
4663 :
4664 :
4665 : match
4666 689 : gfc_match_oacc_data (void)
4667 : {
4668 689 : return match_acc (EXEC_OACC_DATA, OACC_DATA_CLAUSES);
4669 : }
4670 :
4671 :
4672 : match
4673 65 : gfc_match_oacc_host_data (void)
4674 : {
4675 65 : return match_acc (EXEC_OACC_HOST_DATA, OACC_HOST_DATA_CLAUSES);
4676 : }
4677 :
4678 :
4679 : match
4680 3585 : gfc_match_oacc_loop (void)
4681 : {
4682 3585 : return match_acc (EXEC_OACC_LOOP, OACC_LOOP_CLAUSES);
4683 : }
4684 :
4685 :
4686 : match
4687 178 : gfc_match_oacc_declare (void)
4688 : {
4689 178 : gfc_omp_clauses *c;
4690 178 : gfc_omp_namelist *n;
4691 178 : gfc_namespace *ns = gfc_current_ns;
4692 178 : gfc_oacc_declare *new_oc;
4693 178 : bool module_var = false;
4694 178 : locus where = gfc_current_locus;
4695 :
4696 178 : if (gfc_match_omp_clauses (&c, OACC_DECLARE_CLAUSES, false, false, true)
4697 : != MATCH_YES)
4698 : return MATCH_ERROR;
4699 :
4700 262 : for (n = c->lists[OMP_LIST_DEVICE_RESIDENT]; n != NULL; n = n->next)
4701 90 : n->sym->attr.oacc_declare_device_resident = 1;
4702 :
4703 192 : for (n = c->lists[OMP_LIST_LINK]; n != NULL; n = n->next)
4704 20 : n->sym->attr.oacc_declare_link = 1;
4705 :
4706 318 : for (n = c->lists[OMP_LIST_MAP]; n != NULL; n = n->next)
4707 : {
4708 156 : gfc_symbol *s = n->sym;
4709 :
4710 156 : if (gfc_current_ns->proc_name
4711 156 : && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
4712 : {
4713 52 : if (n->u.map.op != OMP_MAP_ALLOC && n->u.map.op != OMP_MAP_TO)
4714 : {
4715 6 : gfc_error ("Invalid clause in module with !$ACC DECLARE at %L",
4716 : &where);
4717 6 : return MATCH_ERROR;
4718 : }
4719 :
4720 : module_var = true;
4721 : }
4722 :
4723 150 : if (s->attr.use_assoc)
4724 : {
4725 0 : gfc_error ("Variable is USE-associated with !$ACC DECLARE at %L",
4726 : &where);
4727 0 : return MATCH_ERROR;
4728 : }
4729 :
4730 150 : if ((s->result == s && s->ns->contained != gfc_current_ns)
4731 150 : || ((s->attr.flavor == FL_UNKNOWN || s->attr.flavor == FL_VARIABLE)
4732 135 : && s->ns != gfc_current_ns))
4733 : {
4734 2 : gfc_error ("Variable %qs shall be declared in the same scoping unit "
4735 : "as !$ACC DECLARE at %L", s->name, &where);
4736 2 : return MATCH_ERROR;
4737 : }
4738 :
4739 148 : if ((s->attr.dimension || s->attr.codimension)
4740 76 : && s->attr.dummy && s->as->type != AS_EXPLICIT)
4741 : {
4742 2 : gfc_error ("Assumed-size dummy array with !$ACC DECLARE at %L",
4743 : &where);
4744 2 : return MATCH_ERROR;
4745 : }
4746 :
4747 146 : switch (n->u.map.op)
4748 : {
4749 49 : case OMP_MAP_FORCE_ALLOC:
4750 49 : case OMP_MAP_ALLOC:
4751 49 : s->attr.oacc_declare_create = 1;
4752 49 : break;
4753 :
4754 63 : case OMP_MAP_FORCE_TO:
4755 63 : case OMP_MAP_TO:
4756 63 : s->attr.oacc_declare_copyin = 1;
4757 63 : break;
4758 :
4759 1 : case OMP_MAP_FORCE_DEVICEPTR:
4760 1 : s->attr.oacc_declare_deviceptr = 1;
4761 1 : break;
4762 :
4763 : default:
4764 : break;
4765 : }
4766 : }
4767 :
4768 162 : new_oc = gfc_get_oacc_declare ();
4769 162 : new_oc->next = ns->oacc_declare;
4770 162 : new_oc->module_var = module_var;
4771 162 : new_oc->clauses = c;
4772 162 : new_oc->loc = gfc_current_locus;
4773 162 : ns->oacc_declare = new_oc;
4774 :
4775 162 : return MATCH_YES;
4776 : }
4777 :
4778 :
4779 : match
4780 760 : gfc_match_oacc_update (void)
4781 : {
4782 760 : gfc_omp_clauses *c;
4783 760 : locus here = gfc_current_locus;
4784 :
4785 760 : if (gfc_match_omp_clauses (&c, OACC_UPDATE_CLAUSES, false, false, true)
4786 : != MATCH_YES)
4787 : return MATCH_ERROR;
4788 :
4789 756 : if (!c->lists[OMP_LIST_MAP])
4790 : {
4791 1 : gfc_error ("%<acc update%> must contain at least one "
4792 : "%<device%> or %<host%> or %<self%> clause at %L", &here);
4793 1 : return MATCH_ERROR;
4794 : }
4795 :
4796 755 : new_st.op = EXEC_OACC_UPDATE;
4797 755 : new_st.ext.omp_clauses = c;
4798 755 : return MATCH_YES;
4799 : }
4800 :
4801 :
4802 : match
4803 877 : gfc_match_oacc_enter_data (void)
4804 : {
4805 877 : return match_acc (EXEC_OACC_ENTER_DATA, OACC_ENTER_DATA_CLAUSES);
4806 : }
4807 :
4808 :
4809 : match
4810 612 : gfc_match_oacc_exit_data (void)
4811 : {
4812 612 : return match_acc (EXEC_OACC_EXIT_DATA, OACC_EXIT_DATA_CLAUSES);
4813 : }
4814 :
4815 :
4816 : match
4817 203 : gfc_match_oacc_wait (void)
4818 : {
4819 203 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
4820 203 : gfc_expr_list *wait_list = NULL, *el;
4821 203 : bool space = true;
4822 203 : match m;
4823 :
4824 203 : m = match_omp_oacc_expr_list (" (", &wait_list, true, false);
4825 203 : if (m == MATCH_ERROR)
4826 : return m;
4827 197 : else if (m == MATCH_YES)
4828 126 : space = false;
4829 :
4830 197 : if (gfc_match_omp_clauses (&c, OACC_WAIT_CLAUSES, space, space, true)
4831 : == MATCH_ERROR)
4832 : return MATCH_ERROR;
4833 :
4834 184 : if (wait_list)
4835 261 : for (el = wait_list; el; el = el->next)
4836 : {
4837 140 : if (el->expr == NULL)
4838 : {
4839 2 : gfc_error ("Invalid argument to !$ACC WAIT at %C");
4840 2 : return MATCH_ERROR;
4841 : }
4842 :
4843 138 : if (!gfc_resolve_expr (el->expr)
4844 138 : || el->expr->ts.type != BT_INTEGER || el->expr->rank != 0)
4845 : {
4846 3 : gfc_error ("WAIT clause at %L requires a scalar INTEGER expression",
4847 3 : &el->expr->where);
4848 :
4849 3 : return MATCH_ERROR;
4850 : }
4851 : }
4852 179 : c->wait_list = wait_list;
4853 179 : new_st.op = EXEC_OACC_WAIT;
4854 179 : new_st.ext.omp_clauses = c;
4855 179 : return MATCH_YES;
4856 : }
4857 :
4858 :
4859 : match
4860 97 : gfc_match_oacc_cache (void)
4861 : {
4862 97 : bool readonly = false;
4863 97 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
4864 : /* The OpenACC cache directive explicitly only allows "array elements or
4865 : subarrays", which we're currently not checking here. Either check this
4866 : after the call of gfc_match_omp_variable_list, or add something like a
4867 : only_sections variant next to its allow_sections parameter. */
4868 97 : match m = gfc_match (" ( ");
4869 97 : if (m != MATCH_YES)
4870 : {
4871 0 : gfc_free_omp_clauses(c);
4872 0 : return m;
4873 : }
4874 :
4875 97 : if (gfc_match ("readonly : ") == MATCH_YES)
4876 8 : readonly = true;
4877 :
4878 97 : gfc_omp_namelist **head = NULL;
4879 97 : m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_CACHE], true,
4880 : NULL, &head, true);
4881 97 : if (m != MATCH_YES)
4882 : {
4883 2 : gfc_free_omp_clauses(c);
4884 2 : return m;
4885 : }
4886 :
4887 95 : if (readonly)
4888 24 : for (gfc_omp_namelist *n = *head; n; n = n->next)
4889 16 : n->u.map.readonly = true;
4890 :
4891 95 : if (gfc_current_state() != COMP_DO
4892 56 : && gfc_current_state() != COMP_DO_CONCURRENT)
4893 : {
4894 2 : gfc_error ("ACC CACHE directive must be inside of loop %C");
4895 2 : gfc_free_omp_clauses(c);
4896 2 : return MATCH_ERROR;
4897 : }
4898 :
4899 93 : new_st.op = EXEC_OACC_CACHE;
4900 93 : new_st.ext.omp_clauses = c;
4901 93 : return MATCH_YES;
4902 : }
4903 :
4904 : /* Determine the OpenACC 'routine' directive's level of parallelism. */
4905 :
4906 : static oacc_routine_lop
4907 734 : gfc_oacc_routine_lop (gfc_omp_clauses *clauses)
4908 : {
4909 734 : oacc_routine_lop ret = OACC_ROUTINE_LOP_SEQ;
4910 :
4911 734 : if (clauses)
4912 : {
4913 584 : unsigned n_lop_clauses = 0;
4914 :
4915 584 : if (clauses->gang)
4916 : {
4917 164 : ++n_lop_clauses;
4918 164 : ret = OACC_ROUTINE_LOP_GANG;
4919 : }
4920 584 : if (clauses->worker)
4921 : {
4922 114 : ++n_lop_clauses;
4923 114 : ret = OACC_ROUTINE_LOP_WORKER;
4924 : }
4925 584 : if (clauses->vector)
4926 : {
4927 116 : ++n_lop_clauses;
4928 116 : ret = OACC_ROUTINE_LOP_VECTOR;
4929 : }
4930 584 : if (clauses->seq)
4931 : {
4932 206 : ++n_lop_clauses;
4933 206 : ret = OACC_ROUTINE_LOP_SEQ;
4934 : }
4935 :
4936 584 : if (n_lop_clauses > 1)
4937 47 : ret = OACC_ROUTINE_LOP_ERROR;
4938 : }
4939 :
4940 734 : return ret;
4941 : }
4942 :
4943 : match
4944 698 : gfc_match_oacc_routine (void)
4945 : {
4946 698 : locus old_loc;
4947 698 : match m;
4948 698 : gfc_intrinsic_sym *isym = NULL;
4949 698 : gfc_symbol *sym = NULL;
4950 698 : gfc_omp_clauses *c = NULL;
4951 698 : gfc_oacc_routine_name *n = NULL;
4952 698 : oacc_routine_lop lop = OACC_ROUTINE_LOP_NONE;
4953 698 : bool nohost;
4954 :
4955 698 : old_loc = gfc_current_locus;
4956 :
4957 698 : m = gfc_match (" (");
4958 :
4959 698 : if (gfc_current_ns->proc_name
4960 696 : && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
4961 90 : && m == MATCH_YES)
4962 : {
4963 3 : gfc_error ("Only the !$ACC ROUTINE form without "
4964 : "list is allowed in interface block at %C");
4965 3 : goto cleanup;
4966 : }
4967 :
4968 608 : if (m == MATCH_YES)
4969 : {
4970 295 : char buffer[GFC_MAX_SYMBOL_LEN + 1];
4971 :
4972 295 : m = gfc_match_name (buffer);
4973 295 : if (m == MATCH_YES)
4974 : {
4975 294 : gfc_symtree *st = NULL;
4976 :
4977 : /* First look for an intrinsic symbol. */
4978 294 : isym = gfc_find_function (buffer);
4979 294 : if (!isym)
4980 294 : isym = gfc_find_subroutine (buffer);
4981 : /* If no intrinsic symbol found, search the current namespace. */
4982 294 : if (!isym)
4983 276 : st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);
4984 276 : if (st)
4985 : {
4986 270 : sym = st->n.sym;
4987 : /* If the name in a 'routine' directive refers to the containing
4988 : subroutine or function, then make sure that we'll later handle
4989 : this accordingly. */
4990 270 : if (gfc_current_ns->proc_name != NULL
4991 270 : && strcmp (sym->name, gfc_current_ns->proc_name->name) == 0)
4992 294 : sym = NULL;
4993 : }
4994 :
4995 294 : if (isym == NULL && st == NULL)
4996 : {
4997 6 : gfc_error ("Invalid NAME %qs in !$ACC ROUTINE ( NAME ) at %C",
4998 : buffer);
4999 6 : gfc_current_locus = old_loc;
5000 9 : return MATCH_ERROR;
5001 : }
5002 : }
5003 : else
5004 : {
5005 1 : gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C");
5006 1 : gfc_current_locus = old_loc;
5007 1 : return MATCH_ERROR;
5008 : }
5009 :
5010 288 : if (gfc_match_char (')') != MATCH_YES)
5011 : {
5012 2 : gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting"
5013 : " %<)%> after NAME");
5014 2 : gfc_current_locus = old_loc;
5015 2 : return MATCH_ERROR;
5016 : }
5017 : }
5018 :
5019 686 : if (gfc_match_omp_eos () != MATCH_YES
5020 686 : && (gfc_match_omp_clauses (&c, OACC_ROUTINE_CLAUSES, false, false, true)
5021 : != MATCH_YES))
5022 : return MATCH_ERROR;
5023 :
5024 683 : lop = gfc_oacc_routine_lop (c);
5025 683 : if (lop == OACC_ROUTINE_LOP_ERROR)
5026 : {
5027 47 : gfc_error ("Multiple loop axes specified for routine at %C");
5028 47 : goto cleanup;
5029 : }
5030 636 : nohost = c ? c->nohost : false;
5031 :
5032 636 : if (isym != NULL)
5033 : {
5034 : /* Diagnose any OpenACC 'routine' directive that doesn't match the
5035 : (implicit) one with a 'seq' clause. */
5036 16 : if (c && (c->gang || c->worker || c->vector))
5037 : {
5038 10 : gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )"
5039 : " at %C marked with incompatible GANG, WORKER, or VECTOR"
5040 : " clause");
5041 10 : goto cleanup;
5042 : }
5043 : /* ..., and no 'nohost' clause. */
5044 6 : if (nohost)
5045 : {
5046 2 : gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )"
5047 : " at %C marked with incompatible NOHOST clause");
5048 2 : goto cleanup;
5049 : }
5050 : }
5051 620 : else if (sym != NULL)
5052 : {
5053 151 : bool add = true;
5054 :
5055 : /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
5056 : match the first one. */
5057 151 : for (gfc_oacc_routine_name *n_p = gfc_current_ns->oacc_routine_names;
5058 346 : n_p;
5059 195 : n_p = n_p->next)
5060 235 : if (n_p->sym == sym)
5061 : {
5062 51 : add = false;
5063 51 : bool nohost_p = n_p->clauses ? n_p->clauses->nohost : false;
5064 51 : if (lop != gfc_oacc_routine_lop (n_p->clauses)
5065 51 : || nohost != nohost_p)
5066 : {
5067 40 : gfc_error ("!$ACC ROUTINE already applied at %C");
5068 40 : goto cleanup;
5069 : }
5070 : }
5071 :
5072 111 : if (add)
5073 : {
5074 100 : sym->attr.oacc_routine_lop = lop;
5075 100 : sym->attr.oacc_routine_nohost = nohost;
5076 :
5077 100 : n = gfc_get_oacc_routine_name ();
5078 100 : n->sym = sym;
5079 100 : n->clauses = c;
5080 100 : n->next = gfc_current_ns->oacc_routine_names;
5081 100 : n->loc = old_loc;
5082 100 : gfc_current_ns->oacc_routine_names = n;
5083 : }
5084 : }
5085 469 : else if (gfc_current_ns->proc_name)
5086 : {
5087 : /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
5088 : match the first one. */
5089 468 : oacc_routine_lop lop_p = gfc_current_ns->proc_name->attr.oacc_routine_lop;
5090 468 : bool nohost_p = gfc_current_ns->proc_name->attr.oacc_routine_nohost;
5091 468 : if (lop_p != OACC_ROUTINE_LOP_NONE
5092 86 : && (lop != lop_p
5093 86 : || nohost != nohost_p))
5094 : {
5095 56 : gfc_error ("!$ACC ROUTINE already applied at %C");
5096 56 : goto cleanup;
5097 : }
5098 :
5099 412 : if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
5100 : gfc_current_ns->proc_name->name,
5101 : &old_loc))
5102 1 : goto cleanup;
5103 411 : gfc_current_ns->proc_name->attr.oacc_routine_lop = lop;
5104 411 : gfc_current_ns->proc_name->attr.oacc_routine_nohost = nohost;
5105 : }
5106 : else
5107 : /* Something has gone wrong, possibly a syntax error. */
5108 1 : goto cleanup;
5109 :
5110 526 : if (gfc_pure (NULL) && c && (c->gang || c->worker || c->vector))
5111 : {
5112 6 : gfc_error ("!$ACC ROUTINE with GANG, WORKER, or VECTOR clause is not "
5113 : "permitted in PURE procedure at %C");
5114 6 : goto cleanup;
5115 : }
5116 :
5117 :
5118 520 : if (n)
5119 100 : n->clauses = c;
5120 420 : else if (gfc_current_ns->oacc_routine)
5121 0 : gfc_current_ns->oacc_routine_clauses = c;
5122 :
5123 520 : new_st.op = EXEC_OACC_ROUTINE;
5124 520 : new_st.ext.omp_clauses = c;
5125 520 : return MATCH_YES;
5126 :
5127 166 : cleanup:
5128 166 : gfc_current_locus = old_loc;
5129 166 : return MATCH_ERROR;
5130 : }
5131 :
5132 :
5133 : #define OMP_PARALLEL_CLAUSES \
5134 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5135 : | OMP_CLAUSE_SHARED | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION \
5136 : | OMP_CLAUSE_IF | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT \
5137 : | OMP_CLAUSE_PROC_BIND | OMP_CLAUSE_ALLOCATE)
5138 : #define OMP_DECLARE_SIMD_CLAUSES \
5139 : (omp_mask (OMP_CLAUSE_SIMDLEN) | OMP_CLAUSE_LINEAR \
5140 : | OMP_CLAUSE_UNIFORM | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_INBRANCH \
5141 : | OMP_CLAUSE_NOTINBRANCH)
5142 : #define OMP_DO_CLAUSES \
5143 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5144 : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
5145 : | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE \
5146 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ORDER | OMP_CLAUSE_ALLOCATE \
5147 : | OMP_CLAUSE_NOWAIT)
5148 : #define OMP_LOOP_CLAUSES \
5149 : (omp_mask (OMP_CLAUSE_BIND) | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_ORDER \
5150 : | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
5151 :
5152 : #define OMP_SCOPE_CLAUSES \
5153 : (omp_mask (OMP_CLAUSE_PRIVATE) |OMP_CLAUSE_FIRSTPRIVATE \
5154 : | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT)
5155 : #define OMP_SECTIONS_CLAUSES \
5156 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5157 : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
5158 : | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT)
5159 : #define OMP_SIMD_CLAUSES \
5160 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_LASTPRIVATE \
5161 : | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_SAFELEN \
5162 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_SIMDLEN \
5163 : | OMP_CLAUSE_IF | OMP_CLAUSE_ORDER | OMP_CLAUSE_NOTEMPORAL)
5164 : #define OMP_TASK_CLAUSES \
5165 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5166 : | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT \
5167 : | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE \
5168 : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_IN_REDUCTION \
5169 : | OMP_CLAUSE_DETACH | OMP_CLAUSE_AFFINITY | OMP_CLAUSE_ALLOCATE)
5170 : #define OMP_TASKLOOP_CLAUSES \
5171 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5172 : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF \
5173 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL \
5174 : | OMP_CLAUSE_MERGEABLE | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_GRAINSIZE \
5175 : | OMP_CLAUSE_NUM_TASKS | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_NOGROUP \
5176 : | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IN_REDUCTION | OMP_CLAUSE_ALLOCATE)
5177 : #define OMP_TASKGROUP_CLAUSES \
5178 : (omp_mask (OMP_CLAUSE_TASK_REDUCTION) | OMP_CLAUSE_ALLOCATE)
5179 : #define OMP_TARGET_CLAUSES \
5180 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
5181 : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_PRIVATE \
5182 : | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULTMAP \
5183 : | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_IN_REDUCTION \
5184 : | OMP_CLAUSE_THREAD_LIMIT | OMP_CLAUSE_ALLOCATE \
5185 : | OMP_CLAUSE_HAS_DEVICE_ADDR | OMP_CLAUSE_USES_ALLOCATORS \
5186 : | OMP_CLAUSE_DYN_GROUPPRIVATE | OMP_CLAUSE_DEVICE_TYPE)
5187 : #define OMP_TARGET_DATA_CLAUSES \
5188 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
5189 : | OMP_CLAUSE_USE_DEVICE_PTR | OMP_CLAUSE_USE_DEVICE_ADDR)
5190 : #define OMP_TARGET_ENTER_DATA_CLAUSES \
5191 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
5192 : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
5193 : #define OMP_TARGET_EXIT_DATA_CLAUSES \
5194 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
5195 : | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
5196 : #define OMP_TARGET_UPDATE_CLAUSES \
5197 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_IF | OMP_CLAUSE_TO \
5198 : | OMP_CLAUSE_FROM | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
5199 : #define OMP_TEAMS_CLAUSES \
5200 : (omp_mask (OMP_CLAUSE_NUM_TEAMS) | OMP_CLAUSE_THREAD_LIMIT \
5201 : | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
5202 : | OMP_CLAUSE_SHARED | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE)
5203 : #define OMP_DISTRIBUTE_CLAUSES \
5204 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5205 : | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_DIST_SCHEDULE \
5206 : | OMP_CLAUSE_ORDER | OMP_CLAUSE_ALLOCATE)
5207 : #define OMP_SINGLE_CLAUSES \
5208 : (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
5209 : | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_COPYPRIVATE)
5210 : #define OMP_ORDERED_CLAUSES \
5211 : (omp_mask (OMP_CLAUSE_THREADS) | OMP_CLAUSE_SIMD)
5212 : #define OMP_DECLARE_TARGET_CLAUSES \
5213 : (omp_mask (OMP_CLAUSE_ENTER) | OMP_CLAUSE_LINK | OMP_CLAUSE_DEVICE_TYPE \
5214 : | OMP_CLAUSE_TO | OMP_CLAUSE_INDIRECT | OMP_CLAUSE_LOCAL)
5215 : #define OMP_ATOMIC_CLAUSES \
5216 : (omp_mask (OMP_CLAUSE_ATOMIC) | OMP_CLAUSE_CAPTURE | OMP_CLAUSE_HINT \
5217 : | OMP_CLAUSE_MEMORDER | OMP_CLAUSE_COMPARE | OMP_CLAUSE_FAIL \
5218 : | OMP_CLAUSE_WEAK)
5219 : #define OMP_MASKED_CLAUSES \
5220 : (omp_mask (OMP_CLAUSE_FILTER))
5221 : #define OMP_ERROR_CLAUSES \
5222 : (omp_mask (OMP_CLAUSE_AT) | OMP_CLAUSE_MESSAGE | OMP_CLAUSE_SEVERITY)
5223 : #define OMP_WORKSHARE_CLAUSES \
5224 : omp_mask (OMP_CLAUSE_NOWAIT)
5225 : #define OMP_UNROLL_CLAUSES \
5226 : (omp_mask (OMP_CLAUSE_FULL) | OMP_CLAUSE_PARTIAL)
5227 : #define OMP_TILE_CLAUSES \
5228 : (omp_mask (OMP_CLAUSE_SIZES))
5229 : #define OMP_ALLOCATORS_CLAUSES \
5230 : omp_mask (OMP_CLAUSE_ALLOCATE)
5231 : #define OMP_INTEROP_CLAUSES \
5232 : (omp_mask (OMP_CLAUSE_DEPEND) | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_DEVICE \
5233 : | OMP_CLAUSE_INIT | OMP_CLAUSE_DESTROY | OMP_CLAUSE_USE)
5234 : #define OMP_DISPATCH_CLAUSES \
5235 : (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOVARIANTS \
5236 : | OMP_CLAUSE_NOCONTEXT | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_NOWAIT \
5237 : | OMP_CLAUSE_HAS_DEVICE_ADDR | OMP_CLAUSE_INTEROP)
5238 :
5239 :
5240 : static match
5241 16800 : match_omp (gfc_exec_op op, const omp_mask mask)
5242 : {
5243 16800 : gfc_omp_clauses *c;
5244 16800 : if (gfc_match_omp_clauses (&c, mask, true, true, false,
5245 : op == EXEC_OMP_TARGET) != MATCH_YES)
5246 : return MATCH_ERROR;
5247 16552 : new_st.op = op;
5248 16552 : new_st.ext.omp_clauses = c;
5249 16552 : return MATCH_YES;
5250 : }
5251 :
5252 : /* Handles both declarative and (deprecated) executable ALLOCATE directive;
5253 : accepts optional list (for executable) and common blocks.
5254 : If no variables have been provided, the single omp namelist has sym == NULL.
5255 :
5256 : Note that the executable ALLOCATE directive permits structure elements only
5257 : in OpenMP 5.0 and 5.1 but not longer in 5.2. See also the comment on the
5258 : 'omp allocators' directive below. The accidental change was reverted for
5259 : OpenMP TR12, permitting them again. See also gfc_match_omp_allocators.
5260 :
5261 : Hence, structure elements are rejected for now, also to make resolving
5262 : OMP_LIST_ALLOCATE simpler (check for duplicates, same symbol in
5263 : Fortran allocate stmt). TODO: Permit structure elements. */
5264 :
5265 : match
5266 274 : gfc_match_omp_allocate (void)
5267 : {
5268 274 : match m;
5269 274 : bool first = true;
5270 274 : gfc_omp_namelist *vars = NULL;
5271 274 : gfc_expr *align = NULL;
5272 274 : gfc_expr *allocator = NULL;
5273 274 : locus loc = gfc_current_locus;
5274 :
5275 274 : m = gfc_match_omp_variable_list (" (", &vars, true, NULL, NULL, true, true,
5276 : NULL, true);
5277 :
5278 274 : if (m == MATCH_ERROR)
5279 : return m;
5280 :
5281 502 : while (true)
5282 : {
5283 502 : gfc_gobble_whitespace ();
5284 502 : if (gfc_match_omp_eos () == MATCH_YES)
5285 : break;
5286 234 : if (!first)
5287 28 : gfc_match (", ");
5288 234 : first = false;
5289 234 : if ((m = gfc_match_dupl_check (!align, "align", true, &align))
5290 : != MATCH_NO)
5291 : {
5292 62 : if (m == MATCH_ERROR)
5293 1 : goto error;
5294 61 : continue;
5295 : }
5296 172 : if ((m = gfc_match_dupl_check (!allocator, "allocator",
5297 : true, &allocator)) != MATCH_NO)
5298 : {
5299 171 : if (m == MATCH_ERROR)
5300 1 : goto error;
5301 170 : continue;
5302 : }
5303 1 : gfc_error ("Expected ALIGN or ALLOCATOR clause at %C");
5304 1 : return MATCH_ERROR;
5305 : }
5306 541 : for (gfc_omp_namelist *n = vars; n; n = n->next)
5307 276 : if (n->expr)
5308 : {
5309 3 : if ((n->expr->ref && n->expr->ref->type == REF_COMPONENT)
5310 3 : || (n->expr->ref->next && n->expr->ref->type == REF_COMPONENT))
5311 1 : gfc_error ("Sorry, structure-element list item at %L in ALLOCATE "
5312 : "directive is not yet supported", &n->expr->where);
5313 : else
5314 2 : gfc_error ("Unexpected expression as list item at %L in ALLOCATE "
5315 : "directive", &n->expr->where);
5316 :
5317 3 : gfc_free_omp_namelist (vars, OMP_LIST_ALLOCATE);
5318 3 : goto error;
5319 : }
5320 :
5321 265 : new_st.op = EXEC_OMP_ALLOCATE;
5322 265 : new_st.ext.omp_clauses = gfc_get_omp_clauses ();
5323 265 : if (vars == NULL)
5324 : {
5325 27 : vars = gfc_get_omp_namelist ();
5326 27 : vars->where = loc;
5327 27 : vars->u.align = align;
5328 27 : vars->u2.allocator = allocator;
5329 27 : new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = vars;
5330 : }
5331 : else
5332 : {
5333 238 : new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = vars;
5334 511 : for (; vars; vars = vars->next)
5335 : {
5336 273 : vars->u.align = (align) ? gfc_copy_expr (align) : NULL;
5337 273 : vars->u2.allocator = allocator;
5338 : }
5339 238 : gfc_free_expr (align);
5340 : }
5341 : return MATCH_YES;
5342 :
5343 5 : error:
5344 5 : gfc_free_expr (align);
5345 5 : gfc_free_expr (allocator);
5346 5 : return MATCH_ERROR;
5347 : }
5348 :
5349 : /* In line with OpenMP 5.2 derived-type components are rejected.
5350 : See also comment before gfc_match_omp_allocate. */
5351 :
5352 : match
5353 26 : gfc_match_omp_allocators (void)
5354 : {
5355 26 : return match_omp (EXEC_OMP_ALLOCATORS, OMP_ALLOCATORS_CLAUSES);
5356 : }
5357 :
5358 :
5359 : match
5360 22 : gfc_match_omp_assume (void)
5361 : {
5362 22 : gfc_omp_clauses *c;
5363 22 : locus loc = gfc_current_locus;
5364 22 : if ((gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_ASSUMPTIONS))
5365 : != MATCH_YES)
5366 22 : || (omp_verify_merge_absent_contains (ST_OMP_ASSUME, c->assume, NULL,
5367 : &loc) != MATCH_YES))
5368 6 : return MATCH_ERROR;
5369 16 : new_st.op = EXEC_OMP_ASSUME;
5370 16 : new_st.ext.omp_clauses = c;
5371 16 : return MATCH_YES;
5372 : }
5373 :
5374 :
5375 : match
5376 28 : gfc_match_omp_assumes (void)
5377 : {
5378 28 : gfc_omp_clauses *c;
5379 28 : locus loc = gfc_current_locus;
5380 28 : if (!gfc_current_ns->proc_name
5381 27 : || (gfc_current_ns->proc_name->attr.flavor != FL_MODULE
5382 23 : && !gfc_current_ns->proc_name->attr.subroutine
5383 10 : && !gfc_current_ns->proc_name->attr.function))
5384 : {
5385 2 : gfc_error ("!$OMP ASSUMES at %C must be in the specification part of a "
5386 : "subprogram or module");
5387 2 : return MATCH_ERROR;
5388 : }
5389 26 : if ((gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_ASSUMPTIONS))
5390 : != MATCH_YES)
5391 50 : || (omp_verify_merge_absent_contains (ST_OMP_ASSUMES, c->assume,
5392 24 : gfc_current_ns->omp_assumes, &loc)
5393 : != MATCH_YES))
5394 5 : return MATCH_ERROR;
5395 21 : if (gfc_current_ns->omp_assumes == NULL)
5396 : {
5397 19 : gfc_current_ns->omp_assumes = c->assume;
5398 19 : c->assume = NULL;
5399 : }
5400 2 : else if (gfc_current_ns->omp_assumes && c->assume)
5401 : {
5402 2 : gfc_current_ns->omp_assumes->no_openmp |= c->assume->no_openmp;
5403 2 : gfc_current_ns->omp_assumes->no_openmp_routines
5404 2 : |= c->assume->no_openmp_routines;
5405 2 : gfc_current_ns->omp_assumes->no_openmp_constructs
5406 2 : |= c->assume->no_openmp_constructs;
5407 2 : gfc_current_ns->omp_assumes->no_parallelism |= c->assume->no_parallelism;
5408 2 : if (gfc_current_ns->omp_assumes->holds && c->assume->holds)
5409 : {
5410 : gfc_expr_list *el = gfc_current_ns->omp_assumes->holds;
5411 1 : for ( ; el->next ; el = el->next)
5412 : ;
5413 1 : el->next = c->assume->holds;
5414 1 : }
5415 1 : else if (c->assume->holds)
5416 0 : gfc_current_ns->omp_assumes->holds = c->assume->holds;
5417 2 : c->assume->holds = NULL;
5418 : }
5419 21 : gfc_free_omp_clauses (c);
5420 21 : return MATCH_YES;
5421 : }
5422 :
5423 :
5424 : match
5425 162 : gfc_match_omp_critical (void)
5426 : {
5427 162 : char n[GFC_MAX_SYMBOL_LEN+1];
5428 162 : gfc_omp_clauses *c = NULL;
5429 :
5430 162 : if (gfc_match (" ( %n )", n) != MATCH_YES)
5431 115 : n[0] = '\0';
5432 :
5433 162 : if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_HINT),
5434 162 : /* first = */ n[0] == '\0') != MATCH_YES)
5435 : return MATCH_ERROR;
5436 :
5437 160 : new_st.op = EXEC_OMP_CRITICAL;
5438 160 : new_st.ext.omp_clauses = c;
5439 160 : if (n[0])
5440 47 : c->critical_name = xstrdup (n);
5441 : return MATCH_YES;
5442 : }
5443 :
5444 :
5445 : match
5446 160 : gfc_match_omp_end_critical (void)
5447 : {
5448 160 : char n[GFC_MAX_SYMBOL_LEN+1];
5449 :
5450 160 : if (gfc_match (" ( %n )", n) != MATCH_YES)
5451 113 : n[0] = '\0';
5452 160 : if (gfc_match_omp_eos () != MATCH_YES)
5453 : {
5454 1 : gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
5455 1 : return MATCH_ERROR;
5456 : }
5457 :
5458 159 : new_st.op = EXEC_OMP_END_CRITICAL;
5459 159 : new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
5460 159 : return MATCH_YES;
5461 : }
5462 :
5463 : /* depobj(depobj) depend(dep-type:loc)|destroy|update(dep-type)
5464 : dep-type = in/out/inout/mutexinoutset/depobj/source/sink
5465 : depend: !source, !sink
5466 : update: !source, !sink, !depobj
5467 : locator = exactly one list item .*/
5468 : match
5469 125 : gfc_match_omp_depobj (void)
5470 : {
5471 125 : gfc_omp_clauses *c = NULL;
5472 125 : gfc_expr *depobj;
5473 :
5474 125 : if (gfc_match (" ( %v ) ", &depobj) != MATCH_YES)
5475 : {
5476 2 : gfc_error ("Expected %<( depobj )%> at %C");
5477 2 : return MATCH_ERROR;
5478 : }
5479 123 : if (gfc_match ("update ( ") == MATCH_YES)
5480 : {
5481 12 : c = gfc_get_omp_clauses ();
5482 12 : if (gfc_match ("inoutset )") == MATCH_YES)
5483 2 : c->depobj_update = OMP_DEPEND_INOUTSET;
5484 10 : else if (gfc_match ("inout )") == MATCH_YES)
5485 1 : c->depobj_update = OMP_DEPEND_INOUT;
5486 9 : else if (gfc_match ("in )") == MATCH_YES)
5487 2 : c->depobj_update = OMP_DEPEND_IN;
5488 7 : else if (gfc_match ("out )") == MATCH_YES)
5489 2 : c->depobj_update = OMP_DEPEND_OUT;
5490 5 : else if (gfc_match ("mutexinoutset )") == MATCH_YES)
5491 2 : c->depobj_update = OMP_DEPEND_MUTEXINOUTSET;
5492 : else
5493 : {
5494 3 : gfc_error ("Expected IN, OUT, INOUT, INOUTSET or MUTEXINOUTSET "
5495 : "followed by %<)%> at %C");
5496 3 : goto error;
5497 : }
5498 : }
5499 111 : else if (gfc_match ("destroy ") == MATCH_YES)
5500 : {
5501 16 : gfc_expr *destroyobj = NULL;
5502 16 : c = gfc_get_omp_clauses ();
5503 16 : c->destroy = true;
5504 :
5505 16 : if (gfc_match (" ( %v ) ", &destroyobj) == MATCH_YES)
5506 : {
5507 3 : if (destroyobj->symtree != depobj->symtree)
5508 2 : gfc_warning (OPT_Wopenmp, "The same depend object should be used as"
5509 : " DEPOBJ argument at %L and as DESTROY argument at %L",
5510 : &depobj->where, &destroyobj->where);
5511 3 : gfc_free_expr (destroyobj);
5512 : }
5513 : }
5514 95 : else if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_DEPEND), true, false)
5515 : != MATCH_YES)
5516 2 : goto error;
5517 :
5518 118 : if (c->depobj_update == OMP_DEPEND_UNSET && !c->destroy)
5519 : {
5520 93 : if (!c->doacross_source && !c->lists[OMP_LIST_DEPEND])
5521 : {
5522 1 : gfc_error ("Expected DEPEND, UPDATE, or DESTROY clause at %C");
5523 1 : goto error;
5524 : }
5525 92 : if (c->lists[OMP_LIST_DEPEND]->u.depend_doacross_op == OMP_DEPEND_DEPOBJ)
5526 : {
5527 1 : gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall not "
5528 : "have dependence-type DEPOBJ",
5529 : c->lists[OMP_LIST_DEPEND]
5530 : ? &c->lists[OMP_LIST_DEPEND]->where : &gfc_current_locus);
5531 1 : goto error;
5532 : }
5533 91 : if (c->lists[OMP_LIST_DEPEND]->next)
5534 : {
5535 1 : gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall have "
5536 : "only a single locator",
5537 : &c->lists[OMP_LIST_DEPEND]->next->where);
5538 1 : goto error;
5539 : }
5540 : }
5541 :
5542 115 : c->depobj = depobj;
5543 115 : new_st.op = EXEC_OMP_DEPOBJ;
5544 115 : new_st.ext.omp_clauses = c;
5545 115 : return MATCH_YES;
5546 :
5547 8 : error:
5548 8 : gfc_free_expr (depobj);
5549 8 : gfc_free_omp_clauses (c);
5550 8 : return MATCH_ERROR;
5551 : }
5552 :
5553 : match
5554 160 : gfc_match_omp_dispatch (void)
5555 : {
5556 160 : return match_omp (EXEC_OMP_DISPATCH, OMP_DISPATCH_CLAUSES);
5557 : }
5558 :
5559 : match
5560 57 : gfc_match_omp_distribute (void)
5561 : {
5562 57 : return match_omp (EXEC_OMP_DISTRIBUTE, OMP_DISTRIBUTE_CLAUSES);
5563 : }
5564 :
5565 :
5566 : match
5567 44 : gfc_match_omp_distribute_parallel_do (void)
5568 : {
5569 44 : return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO,
5570 44 : (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
5571 44 : | OMP_DO_CLAUSES)
5572 44 : & ~(omp_mask (OMP_CLAUSE_ORDERED)
5573 44 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_NOWAIT));
5574 : }
5575 :
5576 :
5577 : match
5578 34 : gfc_match_omp_distribute_parallel_do_simd (void)
5579 : {
5580 34 : return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD,
5581 34 : (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
5582 34 : | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
5583 34 : & ~(omp_mask (OMP_CLAUSE_ORDERED) | OMP_CLAUSE_NOWAIT));
5584 : }
5585 :
5586 :
5587 : match
5588 52 : gfc_match_omp_distribute_simd (void)
5589 : {
5590 52 : return match_omp (EXEC_OMP_DISTRIBUTE_SIMD,
5591 52 : OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
5592 : }
5593 :
5594 :
5595 : match
5596 1252 : gfc_match_omp_do (void)
5597 : {
5598 1252 : return match_omp (EXEC_OMP_DO, OMP_DO_CLAUSES);
5599 : }
5600 :
5601 :
5602 : match
5603 137 : gfc_match_omp_do_simd (void)
5604 : {
5605 137 : return match_omp (EXEC_OMP_DO_SIMD, OMP_DO_CLAUSES | OMP_SIMD_CLAUSES);
5606 : }
5607 :
5608 :
5609 : match
5610 70 : gfc_match_omp_loop (void)
5611 : {
5612 70 : return match_omp (EXEC_OMP_LOOP, OMP_LOOP_CLAUSES);
5613 : }
5614 :
5615 :
5616 : match
5617 35 : gfc_match_omp_teams_loop (void)
5618 : {
5619 35 : return match_omp (EXEC_OMP_TEAMS_LOOP, OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES);
5620 : }
5621 :
5622 :
5623 : match
5624 18 : gfc_match_omp_target_teams_loop (void)
5625 : {
5626 18 : return match_omp (EXEC_OMP_TARGET_TEAMS_LOOP,
5627 18 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES);
5628 : }
5629 :
5630 :
5631 : match
5632 31 : gfc_match_omp_parallel_loop (void)
5633 : {
5634 31 : return match_omp (EXEC_OMP_PARALLEL_LOOP,
5635 31 : OMP_PARALLEL_CLAUSES | OMP_LOOP_CLAUSES);
5636 : }
5637 :
5638 :
5639 : match
5640 16 : gfc_match_omp_target_parallel_loop (void)
5641 : {
5642 16 : return match_omp (EXEC_OMP_TARGET_PARALLEL_LOOP,
5643 16 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES
5644 16 : | OMP_LOOP_CLAUSES));
5645 : }
5646 :
5647 :
5648 : match
5649 101 : gfc_match_omp_error (void)
5650 : {
5651 101 : locus loc = gfc_current_locus;
5652 101 : match m = match_omp (EXEC_OMP_ERROR, OMP_ERROR_CLAUSES);
5653 101 : if (m != MATCH_YES)
5654 : return m;
5655 :
5656 82 : gfc_omp_clauses *c = new_st.ext.omp_clauses;
5657 82 : if (c->severity == OMP_SEVERITY_UNSET)
5658 45 : c->severity = OMP_SEVERITY_FATAL;
5659 82 : if (new_st.ext.omp_clauses->at == OMP_AT_EXECUTION)
5660 : return MATCH_YES;
5661 37 : if (c->message
5662 37 : && (!gfc_resolve_expr (c->message)
5663 16 : || c->message->ts.type != BT_CHARACTER
5664 14 : || c->message->ts.kind != gfc_default_character_kind
5665 13 : || c->message->rank != 0))
5666 : {
5667 4 : gfc_error ("MESSAGE clause at %L requires a scalar default-kind "
5668 : "CHARACTER expression",
5669 4 : &new_st.ext.omp_clauses->message->where);
5670 4 : return MATCH_ERROR;
5671 : }
5672 33 : if (c->message && !gfc_is_constant_expr (c->message))
5673 : {
5674 2 : gfc_error ("Constant character expression required in MESSAGE clause "
5675 2 : "at %L", &new_st.ext.omp_clauses->message->where);
5676 2 : return MATCH_ERROR;
5677 : }
5678 31 : if (c->message)
5679 : {
5680 10 : const char *msg = G_("$OMP ERROR encountered at %L: %s");
5681 10 : gcc_assert (c->message->expr_type == EXPR_CONSTANT);
5682 10 : gfc_charlen_t slen = c->message->value.character.length;
5683 10 : int i = gfc_validate_kind (BT_CHARACTER, gfc_default_character_kind,
5684 : false);
5685 10 : size_t size = slen * gfc_character_kinds[i].bit_size / 8;
5686 10 : unsigned char *s = XCNEWVAR (unsigned char, size + 1);
5687 10 : gfc_encode_character (gfc_default_character_kind, slen,
5688 10 : c->message->value.character.string,
5689 : (unsigned char *) s, size);
5690 10 : s[size] = '\0';
5691 10 : if (c->severity == OMP_SEVERITY_WARNING)
5692 6 : gfc_warning_now (0, msg, &loc, s);
5693 : else
5694 4 : gfc_error_now (msg, &loc, s);
5695 10 : free (s);
5696 : }
5697 : else
5698 : {
5699 21 : const char *msg = G_("$OMP ERROR encountered at %L");
5700 21 : if (c->severity == OMP_SEVERITY_WARNING)
5701 7 : gfc_warning_now (0, msg, &loc);
5702 : else
5703 14 : gfc_error_now (msg, &loc);
5704 : }
5705 : return MATCH_YES;
5706 : }
5707 :
5708 : match
5709 86 : gfc_match_omp_flush (void)
5710 : {
5711 86 : gfc_omp_namelist *list = NULL;
5712 86 : gfc_omp_clauses *c = NULL;
5713 86 : gfc_gobble_whitespace ();
5714 86 : enum gfc_omp_memorder mo = OMP_MEMORDER_UNSET;
5715 86 : if (gfc_match_omp_eos () == MATCH_NO && gfc_peek_ascii_char () != '(')
5716 : {
5717 14 : if (gfc_match ("seq_cst") == MATCH_YES)
5718 : mo = OMP_MEMORDER_SEQ_CST;
5719 11 : else if (gfc_match ("acq_rel") == MATCH_YES)
5720 : mo = OMP_MEMORDER_ACQ_REL;
5721 8 : else if (gfc_match ("release") == MATCH_YES)
5722 : mo = OMP_MEMORDER_RELEASE;
5723 5 : else if (gfc_match ("acquire") == MATCH_YES)
5724 : mo = OMP_MEMORDER_ACQUIRE;
5725 : else
5726 : {
5727 2 : gfc_error ("Expected SEQ_CST, AQC_REL, RELEASE, or ACQUIRE at %C");
5728 2 : return MATCH_ERROR;
5729 : }
5730 12 : c = gfc_get_omp_clauses ();
5731 12 : c->memorder = mo;
5732 : }
5733 84 : gfc_match_omp_variable_list (" (", &list, true);
5734 84 : if (list && mo != OMP_MEMORDER_UNSET)
5735 : {
5736 4 : gfc_error ("List specified together with memory order clause in FLUSH "
5737 : "directive at %C");
5738 4 : gfc_free_omp_namelist (list, OMP_LIST_NONE);
5739 4 : gfc_free_omp_clauses (c);
5740 4 : return MATCH_ERROR;
5741 : }
5742 80 : if (gfc_match_omp_eos () != MATCH_YES)
5743 : {
5744 0 : gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
5745 0 : gfc_free_omp_namelist (list, OMP_LIST_NONE);
5746 0 : gfc_free_omp_clauses (c);
5747 0 : return MATCH_ERROR;
5748 : }
5749 80 : new_st.op = EXEC_OMP_FLUSH;
5750 80 : new_st.ext.omp_namelist = list;
5751 80 : new_st.ext.omp_clauses = c;
5752 80 : return MATCH_YES;
5753 : }
5754 :
5755 :
5756 : match
5757 188 : gfc_match_omp_declare_simd (void)
5758 : {
5759 188 : locus where = gfc_current_locus;
5760 188 : gfc_symbol *proc_name;
5761 188 : gfc_omp_clauses *c;
5762 188 : gfc_omp_declare_simd *ods;
5763 188 : bool needs_space = false;
5764 :
5765 188 : switch (gfc_match (" ( "))
5766 : {
5767 144 : case MATCH_YES:
5768 144 : if (gfc_match_symbol (&proc_name, /* host assoc = */ true) != MATCH_YES
5769 144 : || gfc_match (" ) ") != MATCH_YES)
5770 0 : return MATCH_ERROR;
5771 : break;
5772 44 : case MATCH_NO: proc_name = NULL; needs_space = true; break;
5773 : case MATCH_ERROR: return MATCH_ERROR;
5774 : }
5775 :
5776 188 : if (gfc_match_omp_clauses (&c, OMP_DECLARE_SIMD_CLAUSES, true,
5777 : needs_space) != MATCH_YES)
5778 : return MATCH_ERROR;
5779 :
5780 183 : if (gfc_current_ns->is_block_data)
5781 : {
5782 1 : gfc_free_omp_clauses (c);
5783 1 : return MATCH_YES;
5784 : }
5785 :
5786 182 : ods = gfc_get_omp_declare_simd ();
5787 182 : ods->where = where;
5788 182 : ods->proc_name = proc_name;
5789 182 : ods->clauses = c;
5790 182 : ods->next = gfc_current_ns->omp_declare_simd;
5791 182 : gfc_current_ns->omp_declare_simd = ods;
5792 182 : return MATCH_YES;
5793 : }
5794 :
5795 :
5796 : static bool
5797 877 : match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2)
5798 : {
5799 877 : match m;
5800 877 : locus old_loc = gfc_current_locus;
5801 877 : char sname[GFC_MAX_SYMBOL_LEN + 1];
5802 877 : gfc_symbol *sym;
5803 877 : gfc_namespace *ns = gfc_current_ns;
5804 877 : gfc_expr *lvalue = NULL, *rvalue = NULL;
5805 877 : gfc_symtree *st;
5806 877 : gfc_actual_arglist *arglist;
5807 :
5808 877 : m = gfc_match (" %v =", &lvalue);
5809 877 : if (m != MATCH_YES)
5810 200 : gfc_current_locus = old_loc;
5811 : else
5812 : {
5813 677 : m = gfc_match (" %e )", &rvalue);
5814 677 : if (m == MATCH_YES)
5815 : {
5816 675 : ns->code = gfc_get_code (EXEC_ASSIGN);
5817 675 : ns->code->expr1 = lvalue;
5818 675 : ns->code->expr2 = rvalue;
5819 675 : ns->code->loc = old_loc;
5820 675 : return true;
5821 : }
5822 :
5823 2 : gfc_current_locus = old_loc;
5824 2 : gfc_free_expr (lvalue);
5825 : }
5826 :
5827 202 : m = gfc_match (" %n", sname);
5828 202 : if (m != MATCH_YES)
5829 : return false;
5830 :
5831 202 : if (strcmp (sname, omp_sym1->name) == 0
5832 200 : || strcmp (sname, omp_sym2->name) == 0)
5833 : return false;
5834 :
5835 200 : gfc_current_ns = ns->parent;
5836 200 : if (gfc_get_ha_sym_tree (sname, &st))
5837 : return false;
5838 :
5839 200 : sym = st->n.sym;
5840 200 : if (sym->attr.flavor != FL_PROCEDURE
5841 72 : && sym->attr.flavor != FL_UNKNOWN)
5842 : return false;
5843 :
5844 199 : if (!sym->attr.generic
5845 189 : && !sym->attr.subroutine
5846 71 : && !sym->attr.function)
5847 : {
5848 71 : if (!(sym->attr.external && !sym->attr.referenced))
5849 : {
5850 : /* ...create a symbol in this scope... */
5851 71 : if (sym->ns != gfc_current_ns
5852 71 : && gfc_get_sym_tree (sname, NULL, &st, false) == 1)
5853 : return false;
5854 :
5855 71 : if (sym != st->n.sym)
5856 71 : sym = st->n.sym;
5857 : }
5858 :
5859 : /* ...and then to try to make the symbol into a subroutine. */
5860 71 : if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
5861 : return false;
5862 : }
5863 :
5864 199 : gfc_set_sym_referenced (sym);
5865 199 : gfc_gobble_whitespace ();
5866 199 : if (gfc_peek_ascii_char () != '(')
5867 : return false;
5868 :
5869 195 : gfc_current_ns = ns;
5870 195 : m = gfc_match_actual_arglist (1, &arglist);
5871 195 : if (m != MATCH_YES)
5872 : return false;
5873 :
5874 195 : if (gfc_match_char (')') != MATCH_YES)
5875 : return false;
5876 :
5877 195 : ns->code = gfc_get_code (EXEC_CALL);
5878 195 : ns->code->symtree = st;
5879 195 : ns->code->ext.actual = arglist;
5880 195 : ns->code->loc = old_loc;
5881 195 : return true;
5882 : }
5883 :
5884 : static bool
5885 1156 : gfc_omp_udr_predef (gfc_omp_reduction_op rop, const char *name,
5886 : gfc_typespec *ts, const char **n)
5887 : {
5888 1156 : if (!gfc_numeric_ts (ts) && ts->type != BT_LOGICAL)
5889 : return false;
5890 :
5891 648 : switch (rop)
5892 : {
5893 21 : case OMP_REDUCTION_PLUS:
5894 21 : case OMP_REDUCTION_MINUS:
5895 21 : case OMP_REDUCTION_TIMES:
5896 21 : return ts->type != BT_LOGICAL;
5897 8 : case OMP_REDUCTION_AND:
5898 8 : case OMP_REDUCTION_OR:
5899 8 : case OMP_REDUCTION_EQV:
5900 8 : case OMP_REDUCTION_NEQV:
5901 8 : return ts->type == BT_LOGICAL;
5902 618 : case OMP_REDUCTION_USER:
5903 618 : if (name[0] != '.' && (ts->type == BT_INTEGER || ts->type == BT_REAL))
5904 : {
5905 546 : gfc_symbol *sym;
5906 :
5907 546 : gfc_find_symbol (name, NULL, 1, &sym);
5908 546 : if (sym != NULL)
5909 : {
5910 93 : if (sym->attr.intrinsic)
5911 0 : *n = sym->name;
5912 93 : else if ((sym->attr.flavor != FL_UNKNOWN
5913 81 : && sym->attr.flavor != FL_PROCEDURE)
5914 69 : || sym->attr.external
5915 54 : || sym->attr.generic
5916 54 : || sym->attr.entry
5917 54 : || sym->attr.result
5918 54 : || sym->attr.dummy
5919 54 : || sym->attr.subroutine
5920 50 : || sym->attr.pointer
5921 50 : || sym->attr.target
5922 50 : || sym->attr.cray_pointer
5923 50 : || sym->attr.cray_pointee
5924 50 : || (sym->attr.proc != PROC_UNKNOWN
5925 0 : && sym->attr.proc != PROC_INTRINSIC)
5926 50 : || sym->attr.if_source != IFSRC_UNKNOWN
5927 50 : || sym == sym->ns->proc_name)
5928 43 : *n = NULL;
5929 : else
5930 50 : *n = sym->name;
5931 : }
5932 : else
5933 453 : *n = name;
5934 546 : if (*n
5935 503 : && (strcmp (*n, "max") == 0 || strcmp (*n, "min") == 0))
5936 54 : return true;
5937 510 : else if (*n
5938 467 : && ts->type == BT_INTEGER
5939 383 : && (strcmp (*n, "iand") == 0
5940 377 : || strcmp (*n, "ior") == 0
5941 371 : || strcmp (*n, "ieor") == 0))
5942 : return true;
5943 : }
5944 : break;
5945 : default:
5946 : break;
5947 : }
5948 : return false;
5949 : }
5950 :
5951 : gfc_omp_udr *
5952 639 : gfc_omp_udr_find (gfc_symtree *st, gfc_typespec *ts)
5953 : {
5954 639 : gfc_omp_udr *omp_udr;
5955 :
5956 639 : if (st == NULL)
5957 : return NULL;
5958 :
5959 250 : for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
5960 154 : if (omp_udr->ts.type == ts->type
5961 89 : || ((omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
5962 0 : && (ts->type == BT_DERIVED || ts->type == BT_CLASS)))
5963 : {
5964 65 : if (omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
5965 : {
5966 12 : if (strcmp (omp_udr->ts.u.derived->name, ts->u.derived->name) == 0)
5967 : return omp_udr;
5968 : }
5969 53 : else if (omp_udr->ts.kind == ts->kind)
5970 : {
5971 19 : if (omp_udr->ts.type == BT_CHARACTER)
5972 : {
5973 17 : if (omp_udr->ts.u.cl->length == NULL
5974 15 : || ts->u.cl->length == NULL)
5975 : return omp_udr;
5976 15 : if (omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5977 : return omp_udr;
5978 15 : if (ts->u.cl->length->expr_type != EXPR_CONSTANT)
5979 : return omp_udr;
5980 15 : if (omp_udr->ts.u.cl->length->ts.type != BT_INTEGER)
5981 : return omp_udr;
5982 15 : if (ts->u.cl->length->ts.type != BT_INTEGER)
5983 : return omp_udr;
5984 15 : if (gfc_compare_expr (omp_udr->ts.u.cl->length,
5985 : ts->u.cl->length, INTRINSIC_EQ) != 0)
5986 15 : continue;
5987 : }
5988 2 : return omp_udr;
5989 : }
5990 : }
5991 : return NULL;
5992 : }
5993 :
5994 : match
5995 532 : gfc_match_omp_declare_reduction (void)
5996 : {
5997 532 : match m;
5998 532 : gfc_intrinsic_op op;
5999 532 : char name[GFC_MAX_SYMBOL_LEN + 3];
6000 532 : auto_vec<gfc_typespec, 5> tss;
6001 532 : gfc_typespec ts;
6002 532 : unsigned int i;
6003 532 : gfc_symtree *st;
6004 532 : locus where = gfc_current_locus;
6005 532 : locus end_loc = gfc_current_locus;
6006 532 : bool end_loc_set = false;
6007 532 : gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
6008 :
6009 532 : if (gfc_match_char ('(') != MATCH_YES)
6010 : return MATCH_ERROR;
6011 :
6012 530 : m = gfc_match (" %o : ", &op);
6013 530 : if (m == MATCH_ERROR)
6014 : return MATCH_ERROR;
6015 530 : if (m == MATCH_YES)
6016 : {
6017 117 : snprintf (name, sizeof name, "operator %s", gfc_op2string (op));
6018 117 : rop = (gfc_omp_reduction_op) op;
6019 : }
6020 : else
6021 : {
6022 413 : m = gfc_match_defined_op_name (name + 1, 1);
6023 413 : if (m == MATCH_ERROR)
6024 : return MATCH_ERROR;
6025 413 : if (m == MATCH_YES)
6026 : {
6027 41 : name[0] = '.';
6028 41 : strcat (name, ".");
6029 41 : if (gfc_match (" : ") != MATCH_YES)
6030 : return MATCH_ERROR;
6031 : }
6032 : else
6033 : {
6034 372 : if (gfc_match (" %n : ", name) != MATCH_YES)
6035 : return MATCH_ERROR;
6036 : }
6037 : rop = OMP_REDUCTION_USER;
6038 : }
6039 :
6040 529 : m = gfc_match_type_spec (&ts);
6041 529 : if (m != MATCH_YES)
6042 : return MATCH_ERROR;
6043 : /* Treat len=: the same as len=*. */
6044 528 : if (ts.type == BT_CHARACTER)
6045 61 : ts.deferred = false;
6046 528 : tss.safe_push (ts);
6047 :
6048 1093 : while (gfc_match_char (',') == MATCH_YES)
6049 : {
6050 37 : m = gfc_match_type_spec (&ts);
6051 37 : if (m != MATCH_YES)
6052 : return MATCH_ERROR;
6053 37 : tss.safe_push (ts);
6054 : }
6055 528 : if (gfc_match_char (':') != MATCH_YES)
6056 : return MATCH_ERROR;
6057 :
6058 527 : st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
6059 1084 : for (i = 0; i < tss.length (); i++)
6060 : {
6061 564 : gfc_symtree *omp_out, *omp_in;
6062 564 : gfc_symtree *omp_priv = NULL, *omp_orig = NULL;
6063 564 : gfc_namespace *combiner_ns, *initializer_ns = NULL;
6064 564 : gfc_omp_udr *prev_udr, *omp_udr;
6065 564 : const char *predef_name = NULL;
6066 :
6067 564 : omp_udr = gfc_get_omp_udr ();
6068 564 : omp_udr->name = gfc_get_string ("%s", name);
6069 564 : omp_udr->rop = rop;
6070 564 : omp_udr->ts = tss[i];
6071 564 : omp_udr->where = where;
6072 :
6073 564 : gfc_current_ns = combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
6074 564 : combiner_ns->proc_name = combiner_ns->parent->proc_name;
6075 :
6076 564 : gfc_get_sym_tree ("omp_out", combiner_ns, &omp_out, false);
6077 564 : gfc_get_sym_tree ("omp_in", combiner_ns, &omp_in, false);
6078 564 : combiner_ns->omp_udr_ns = 1;
6079 564 : omp_out->n.sym->ts = tss[i];
6080 564 : omp_in->n.sym->ts = tss[i];
6081 564 : omp_out->n.sym->attr.omp_udr_artificial_var = 1;
6082 564 : omp_in->n.sym->attr.omp_udr_artificial_var = 1;
6083 564 : omp_out->n.sym->attr.flavor = FL_VARIABLE;
6084 564 : omp_in->n.sym->attr.flavor = FL_VARIABLE;
6085 564 : gfc_commit_symbols ();
6086 564 : omp_udr->combiner_ns = combiner_ns;
6087 564 : omp_udr->omp_out = omp_out->n.sym;
6088 564 : omp_udr->omp_in = omp_in->n.sym;
6089 :
6090 564 : locus old_loc = gfc_current_locus;
6091 :
6092 564 : if (!match_udr_expr (omp_out, omp_in))
6093 : {
6094 4 : syntax:
6095 7 : gfc_current_locus = old_loc;
6096 7 : gfc_current_ns = combiner_ns->parent;
6097 7 : gfc_undo_symbols ();
6098 7 : gfc_free_omp_udr (omp_udr);
6099 7 : return MATCH_ERROR;
6100 : }
6101 :
6102 560 : if (gfc_match (" initializer ( ") == MATCH_YES)
6103 : {
6104 313 : gfc_current_ns = combiner_ns->parent;
6105 313 : initializer_ns = gfc_get_namespace (gfc_current_ns, 1);
6106 313 : gfc_current_ns = initializer_ns;
6107 313 : initializer_ns->proc_name = initializer_ns->parent->proc_name;
6108 :
6109 313 : gfc_get_sym_tree ("omp_priv", initializer_ns, &omp_priv, false);
6110 313 : gfc_get_sym_tree ("omp_orig", initializer_ns, &omp_orig, false);
6111 313 : initializer_ns->omp_udr_ns = 1;
6112 313 : omp_priv->n.sym->ts = tss[i];
6113 313 : omp_orig->n.sym->ts = tss[i];
6114 313 : omp_priv->n.sym->attr.omp_udr_artificial_var = 1;
6115 313 : omp_orig->n.sym->attr.omp_udr_artificial_var = 1;
6116 313 : omp_priv->n.sym->attr.flavor = FL_VARIABLE;
6117 313 : omp_orig->n.sym->attr.flavor = FL_VARIABLE;
6118 313 : gfc_commit_symbols ();
6119 313 : omp_udr->initializer_ns = initializer_ns;
6120 313 : omp_udr->omp_priv = omp_priv->n.sym;
6121 313 : omp_udr->omp_orig = omp_orig->n.sym;
6122 :
6123 313 : if (!match_udr_expr (omp_priv, omp_orig))
6124 3 : goto syntax;
6125 : }
6126 :
6127 557 : gfc_current_ns = combiner_ns->parent;
6128 557 : if (!end_loc_set)
6129 : {
6130 520 : end_loc_set = true;
6131 520 : end_loc = gfc_current_locus;
6132 : }
6133 557 : gfc_current_locus = old_loc;
6134 :
6135 557 : prev_udr = gfc_omp_udr_find (st, &tss[i]);
6136 557 : if (gfc_omp_udr_predef (rop, name, &tss[i], &predef_name)
6137 : /* Don't error on !$omp declare reduction (min : integer : ...)
6138 : just yet, there could be integer :: min afterwards,
6139 : making it valid. When the UDR is resolved, we'll get
6140 : to it again. */
6141 557 : && (rop != OMP_REDUCTION_USER || name[0] == '.'))
6142 : {
6143 29 : if (predef_name)
6144 0 : gfc_error_now ("Redefinition of predefined %s "
6145 : "!$OMP DECLARE REDUCTION at %L",
6146 : predef_name, &where);
6147 : else
6148 29 : gfc_error_now ("Redefinition of predefined "
6149 : "!$OMP DECLARE REDUCTION at %L", &where);
6150 : }
6151 528 : else if (prev_udr)
6152 : {
6153 6 : gfc_error_now ("Redefinition of !$OMP DECLARE REDUCTION at %L",
6154 : &where);
6155 6 : gfc_error_now ("Previous !$OMP DECLARE REDUCTION at %L",
6156 : &prev_udr->where);
6157 : }
6158 522 : else if (st)
6159 : {
6160 96 : omp_udr->next = st->n.omp_udr;
6161 96 : st->n.omp_udr = omp_udr;
6162 : }
6163 : else
6164 : {
6165 426 : st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name);
6166 426 : st->n.omp_udr = omp_udr;
6167 : }
6168 : }
6169 :
6170 520 : if (end_loc_set)
6171 : {
6172 520 : gfc_current_locus = end_loc;
6173 520 : if (gfc_match_omp_eos () != MATCH_YES)
6174 : {
6175 1 : gfc_error ("Unexpected junk after !$OMP DECLARE REDUCTION at %C");
6176 1 : gfc_current_locus = where;
6177 1 : return MATCH_ERROR;
6178 : }
6179 :
6180 : return MATCH_YES;
6181 : }
6182 0 : gfc_clear_error ();
6183 0 : return MATCH_ERROR;
6184 532 : }
6185 :
6186 :
6187 : match
6188 471 : gfc_match_omp_declare_target (void)
6189 : {
6190 471 : locus old_loc;
6191 471 : match m;
6192 471 : gfc_omp_clauses *c = NULL;
6193 471 : enum gfc_omp_list_type list;
6194 471 : gfc_omp_namelist *n;
6195 471 : gfc_symbol *s;
6196 :
6197 471 : old_loc = gfc_current_locus;
6198 :
6199 471 : if (gfc_current_ns->proc_name
6200 471 : && gfc_match_omp_eos () == MATCH_YES)
6201 : {
6202 138 : if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
6203 138 : gfc_current_ns->proc_name->name,
6204 : &old_loc))
6205 0 : goto cleanup;
6206 : return MATCH_YES;
6207 : }
6208 :
6209 333 : if (gfc_current_ns->proc_name
6210 333 : && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY)
6211 : {
6212 2 : gfc_error ("Only the !$OMP DECLARE TARGET form without "
6213 : "clauses is allowed in interface block at %C");
6214 2 : goto cleanup;
6215 : }
6216 :
6217 331 : m = gfc_match (" (");
6218 331 : if (m == MATCH_YES)
6219 : {
6220 85 : c = gfc_get_omp_clauses ();
6221 85 : gfc_current_locus = old_loc;
6222 85 : m = gfc_match_omp_to_link (" (", &c->lists[OMP_LIST_ENTER]);
6223 85 : if (m != MATCH_YES)
6224 0 : goto syntax;
6225 85 : if (gfc_match_omp_eos () != MATCH_YES)
6226 : {
6227 0 : gfc_error ("Unexpected junk after !$OMP DECLARE TARGET at %C");
6228 0 : goto cleanup;
6229 : }
6230 : }
6231 246 : else if (gfc_match_omp_clauses (&c, OMP_DECLARE_TARGET_CLAUSES) != MATCH_YES)
6232 : return MATCH_ERROR;
6233 :
6234 325 : gfc_buffer_error (false);
6235 :
6236 325 : static const enum gfc_omp_list_type to_enter_link_lists[]
6237 : = { OMP_LIST_TO, OMP_LIST_ENTER, OMP_LIST_LINK, OMP_LIST_LOCAL };
6238 1625 : for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists)
6239 1625 : && (list = to_enter_link_lists[listn], true); ++listn)
6240 1844 : for (n = c->lists[list]; n; n = n->next)
6241 544 : if (n->sym)
6242 503 : n->sym->mark = 0;
6243 41 : else if (n->u.common->head)
6244 41 : n->u.common->head->mark = 0;
6245 :
6246 325 : if (c->device_type == OMP_DEVICE_TYPE_UNSET)
6247 257 : c->device_type = OMP_DEVICE_TYPE_ANY;
6248 1300 : for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists)
6249 1625 : && (list = to_enter_link_lists[listn], true); ++listn)
6250 1844 : for (n = c->lists[list]; n; n = n->next)
6251 544 : if (n->sym)
6252 : {
6253 503 : if (n->sym->attr.in_common)
6254 1 : gfc_error_now ("OMP DECLARE TARGET variable at %L is an "
6255 : "element of a COMMON block", &n->where);
6256 502 : else if (n->sym->attr.omp_groupprivate && list != OMP_LIST_LOCAL)
6257 12 : gfc_error_now ("List item %qs at %L not appear in the %qs clause "
6258 : "as it was previously specified in a GROUPPRIVATE "
6259 : "directive", n->sym->name, &n->where,
6260 : list == OMP_LIST_LINK
6261 5 : ? "link" : list == OMP_LIST_TO ? "to" : "enter");
6262 495 : else if (n->sym->mark)
6263 9 : gfc_error_now ("Variable at %L mentioned multiple times in "
6264 : "clauses of the same OMP DECLARE TARGET directive",
6265 : &n->where);
6266 486 : else if ((n->sym->attr.omp_declare_target_link
6267 481 : || n->sym->attr.omp_declare_target_local)
6268 : && list != OMP_LIST_LINK
6269 7 : && list != OMP_LIST_LOCAL)
6270 1 : gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
6271 : "mentioned in %s clause and later in %s clause",
6272 : &n->where,
6273 : n->sym->attr.omp_declare_target_link ? "LINK"
6274 : : "LOCAL",
6275 : list == OMP_LIST_TO ? "TO" : "ENTER");
6276 485 : else if (n->sym->attr.omp_declare_target
6277 14 : && (list == OMP_LIST_LINK || list == OMP_LIST_LOCAL))
6278 1 : gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
6279 : "mentioned in TO or ENTER clause and later in "
6280 : "%s clause", &n->where,
6281 : list == OMP_LIST_LINK ? "LINK" : "LOCAL");
6282 : else
6283 : {
6284 484 : if (list == OMP_LIST_TO || list == OMP_LIST_ENTER)
6285 445 : gfc_add_omp_declare_target (&n->sym->attr, n->sym->name,
6286 : &n->sym->declared_at);
6287 484 : if (list == OMP_LIST_LINK)
6288 30 : gfc_add_omp_declare_target_link (&n->sym->attr, n->sym->name,
6289 30 : &n->sym->declared_at);
6290 484 : if (list == OMP_LIST_LOCAL)
6291 9 : gfc_add_omp_declare_target_local (&n->sym->attr, n->sym->name,
6292 9 : &n->sym->declared_at);
6293 : }
6294 503 : if (n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
6295 36 : && n->sym->attr.omp_device_type != c->device_type)
6296 : {
6297 12 : const char *dt = "any";
6298 12 : if (n->sym->attr.omp_device_type == OMP_DEVICE_TYPE_NOHOST)
6299 : dt = "nohost";
6300 8 : else if (n->sym->attr.omp_device_type == OMP_DEVICE_TYPE_HOST)
6301 4 : dt = "host";
6302 12 : if (n->sym->attr.omp_groupprivate)
6303 1 : gfc_error_now ("List item %qs at %L set in previous OMP "
6304 : "GROUPPRIVATE directive to the different "
6305 : "DEVICE_TYPE %qs", n->sym->name, &n->where, dt);
6306 : else
6307 11 : gfc_error_now ("List item %qs at %L set in previous OMP "
6308 : "DECLARE TARGET directive to the different "
6309 : "DEVICE_TYPE %qs", n->sym->name, &n->where, dt);
6310 : }
6311 503 : n->sym->attr.omp_device_type = c->device_type;
6312 503 : if (c->indirect && c->device_type != OMP_DEVICE_TYPE_ANY)
6313 : {
6314 1 : gfc_error_now ("DEVICE_TYPE must be ANY when used with INDIRECT "
6315 : "at %L", &n->where);
6316 1 : c->indirect = 0;
6317 : }
6318 503 : n->sym->attr.omp_declare_target_indirect = c->indirect;
6319 503 : if (list == OMP_LIST_LINK && c->device_type == OMP_DEVICE_TYPE_NOHOST)
6320 3 : gfc_error_now ("List item %qs at %L set with NOHOST specified may "
6321 : "not appear in a LINK clause", n->sym->name,
6322 : &n->where);
6323 503 : n->sym->mark = 1;
6324 : }
6325 : else /* common block */
6326 : {
6327 41 : if (n->u.common->omp_groupprivate && list != OMP_LIST_LOCAL)
6328 7 : gfc_error_now ("Common block %</%s/%> at %L not appear in the %qs "
6329 : "clause as it was previously specified in a "
6330 : "GROUPPRIVATE directive",
6331 7 : n->u.common->name, &n->where,
6332 : list == OMP_LIST_LINK
6333 5 : ? "link" : list == OMP_LIST_TO ? "to" : "enter");
6334 34 : else if (n->u.common->head && n->u.common->head->mark)
6335 4 : gfc_error_now ("Common block %</%s/%> at %L mentioned multiple "
6336 : "times in clauses of the same OMP DECLARE TARGET "
6337 4 : "directive", n->u.common->name, &n->where);
6338 30 : else if ((n->u.common->omp_declare_target_link
6339 26 : || n->u.common->omp_declare_target_local)
6340 : && list != OMP_LIST_LINK
6341 6 : && list != OMP_LIST_LOCAL)
6342 2 : gfc_error_now ("Common block %</%s/%> at %L previously mentioned "
6343 : "in %s clause and later in %s clause",
6344 1 : n->u.common->name, &n->where,
6345 : n->u.common->omp_declare_target_link ? "LINK"
6346 : : "LOCAL",
6347 : list == OMP_LIST_TO ? "TO" : "ENTER");
6348 29 : else if (n->u.common->omp_declare_target
6349 4 : && (list == OMP_LIST_LINK || list == OMP_LIST_LOCAL))
6350 1 : gfc_error_now ("Common block %</%s/%> at %L previously mentioned "
6351 : "in TO or ENTER clause and later in %s clause",
6352 1 : n->u.common->name, &n->where,
6353 : list == OMP_LIST_LINK ? "LINK" : "LOCAL");
6354 41 : if (n->u.common->omp_device_type != OMP_DEVICE_TYPE_UNSET
6355 21 : && n->u.common->omp_device_type != c->device_type)
6356 : {
6357 1 : const char *dt = "any";
6358 1 : if (n->u.common->omp_device_type == OMP_DEVICE_TYPE_NOHOST)
6359 : dt = "nohost";
6360 0 : else if (n->u.common->omp_device_type == OMP_DEVICE_TYPE_HOST)
6361 0 : dt = "host";
6362 1 : if (n->u.common->omp_groupprivate)
6363 1 : gfc_error_now ("Common block %</%s/%> at %L set in previous OMP "
6364 : "GROUPPRIVATE directive to the different "
6365 1 : "DEVICE_TYPE %qs", n->u.common->name, &n->where,
6366 : dt);
6367 : else
6368 0 : gfc_error_now ("Common block %</%s/%> at %L set in previous OMP "
6369 : "DECLARE TARGET directive to the different "
6370 0 : "DEVICE_TYPE %qs", n->u.common->name, &n->where,
6371 : dt);
6372 : }
6373 41 : n->u.common->omp_device_type = c->device_type;
6374 :
6375 41 : if (c->indirect && c->device_type != OMP_DEVICE_TYPE_ANY)
6376 : {
6377 0 : gfc_error_now ("DEVICE_TYPE must be ANY when used with INDIRECT "
6378 : "at %L", &n->where);
6379 0 : c->indirect = 0;
6380 : }
6381 41 : if (list == OMP_LIST_LINK && c->device_type == OMP_DEVICE_TYPE_NOHOST)
6382 1 : gfc_error_now ("Common block %</%s/%> at %L set with NOHOST "
6383 : "specified may not appear in a LINK clause",
6384 1 : n->u.common->name, &n->where);
6385 :
6386 41 : if (list == OMP_LIST_TO || list == OMP_LIST_ENTER)
6387 21 : n->u.common->omp_declare_target = 1;
6388 41 : if (list == OMP_LIST_LINK)
6389 15 : n->u.common->omp_declare_target_link = 1;
6390 41 : if (list == OMP_LIST_LOCAL)
6391 5 : n->u.common->omp_declare_target_local = 1;
6392 :
6393 110 : for (s = n->u.common->head; s; s = s->common_next)
6394 : {
6395 69 : s->mark = 1;
6396 69 : if (list == OMP_LIST_TO || list == OMP_LIST_ENTER)
6397 33 : gfc_add_omp_declare_target (&s->attr, s->name, &n->where);
6398 69 : if (list == OMP_LIST_LINK)
6399 31 : gfc_add_omp_declare_target_link (&s->attr, s->name, &n->where);
6400 69 : if (list == OMP_LIST_LOCAL)
6401 5 : gfc_add_omp_declare_target_local (&s->attr, s->name, &n->where);
6402 69 : s->attr.omp_device_type = c->device_type;
6403 69 : s->attr.omp_declare_target_indirect = c->indirect;
6404 : }
6405 : }
6406 325 : if ((c->device_type || c->indirect)
6407 325 : && !c->lists[OMP_LIST_ENTER]
6408 151 : && !c->lists[OMP_LIST_TO]
6409 47 : && !c->lists[OMP_LIST_LINK]
6410 10 : && !c->lists[OMP_LIST_LOCAL])
6411 2 : gfc_warning_now (OPT_Wopenmp,
6412 : "OMP DECLARE TARGET directive at %L with only "
6413 : "DEVICE_TYPE or INDIRECT clauses is ignored",
6414 : &old_loc);
6415 :
6416 325 : gfc_buffer_error (true);
6417 :
6418 325 : if (c)
6419 325 : gfc_free_omp_clauses (c);
6420 325 : return MATCH_YES;
6421 :
6422 0 : syntax:
6423 0 : gfc_error ("Syntax error in !$OMP DECLARE TARGET list at %C");
6424 :
6425 2 : cleanup:
6426 2 : gfc_current_locus = old_loc;
6427 2 : if (c)
6428 0 : gfc_free_omp_clauses (c);
6429 : return MATCH_ERROR;
6430 : }
6431 :
6432 : /* Skip over and ignore trait-property-extensions.
6433 :
6434 : trait-property-extension :
6435 : trait-property-name
6436 : identifier (trait-property-extension[, trait-property-extension[, ...]])
6437 : constant integer expression
6438 : */
6439 :
6440 : static match gfc_ignore_trait_property_extension_list (void);
6441 :
6442 : static match
6443 7 : gfc_ignore_trait_property_extension (void)
6444 : {
6445 7 : char buf[GFC_MAX_SYMBOL_LEN + 1];
6446 7 : gfc_expr *expr;
6447 :
6448 : /* Identifier form of trait-property name, possibly followed by
6449 : a list of (recursive) trait-property-extensions. */
6450 7 : if (gfc_match_name (buf) == MATCH_YES)
6451 : {
6452 0 : if (gfc_match (" (") == MATCH_YES)
6453 0 : return gfc_ignore_trait_property_extension_list ();
6454 : return MATCH_YES;
6455 : }
6456 :
6457 : /* Literal constant. */
6458 7 : if (gfc_match_literal_constant (&expr, 0) == MATCH_YES)
6459 : return MATCH_YES;
6460 :
6461 : /* FIXME: constant integer expressions. */
6462 0 : gfc_error ("Expected trait-property-extension at %C");
6463 0 : return MATCH_ERROR;
6464 : }
6465 :
6466 : static match
6467 5 : gfc_ignore_trait_property_extension_list (void)
6468 : {
6469 9 : while (1)
6470 : {
6471 7 : if (gfc_ignore_trait_property_extension () != MATCH_YES)
6472 : return MATCH_ERROR;
6473 7 : if (gfc_match (" ,") == MATCH_YES)
6474 2 : continue;
6475 5 : if (gfc_match (" )") == MATCH_YES)
6476 : return MATCH_YES;
6477 0 : gfc_error ("expected %<)%> at %C");
6478 0 : return MATCH_ERROR;
6479 : }
6480 : }
6481 :
6482 :
6483 : match
6484 110 : gfc_match_omp_interop (void)
6485 : {
6486 110 : return match_omp (EXEC_OMP_INTEROP, OMP_INTEROP_CLAUSES);
6487 : }
6488 :
6489 :
6490 : /* OpenMP 5.0:
6491 :
6492 : trait-selector:
6493 : trait-selector-name[([trait-score:]trait-property[,trait-property[,...]])]
6494 :
6495 : trait-score:
6496 : score(score-expression) */
6497 :
6498 : static match
6499 637 : gfc_match_omp_context_selector (gfc_omp_set_selector *oss)
6500 : {
6501 775 : do
6502 : {
6503 775 : char selector[GFC_MAX_SYMBOL_LEN + 1];
6504 :
6505 775 : if (gfc_match_name (selector) != MATCH_YES)
6506 : {
6507 2 : gfc_error ("expected trait selector name at %C");
6508 39 : return MATCH_ERROR;
6509 : }
6510 :
6511 773 : gfc_omp_selector *os = gfc_get_omp_selector ();
6512 773 : if (oss->code == OMP_TRAIT_SET_CONSTRUCT
6513 335 : && !strcmp (selector, "do"))
6514 48 : os->code = OMP_TRAIT_CONSTRUCT_FOR;
6515 725 : else if (oss->code == OMP_TRAIT_SET_CONSTRUCT
6516 287 : && !strcmp (selector, "for"))
6517 1 : os->code = OMP_TRAIT_INVALID;
6518 : else
6519 724 : os->code = omp_lookup_ts_code (oss->code, selector);
6520 773 : os->next = oss->trait_selectors;
6521 773 : oss->trait_selectors = os;
6522 :
6523 773 : if (os->code == OMP_TRAIT_INVALID)
6524 : {
6525 18 : gfc_warning (OPT_Wopenmp,
6526 : "unknown selector %qs for context selector set %qs "
6527 : "at %C",
6528 18 : selector, omp_tss_map[oss->code]);
6529 18 : if (gfc_match (" (") == MATCH_YES
6530 18 : && gfc_ignore_trait_property_extension_list () != MATCH_YES)
6531 : return MATCH_ERROR;
6532 18 : if (gfc_match (" ,") == MATCH_YES)
6533 1 : continue;
6534 598 : break;
6535 : }
6536 :
6537 755 : enum omp_tp_type property_kind = omp_ts_map[os->code].tp_type;
6538 755 : bool allow_score = omp_ts_map[os->code].allow_score;
6539 :
6540 755 : if (gfc_match (" (") == MATCH_YES)
6541 : {
6542 431 : if (property_kind == OMP_TRAIT_PROPERTY_NONE)
6543 : {
6544 6 : gfc_error ("selector %qs does not accept any properties at %C",
6545 : selector);
6546 6 : return MATCH_ERROR;
6547 : }
6548 :
6549 425 : if (gfc_match (" score") == MATCH_YES)
6550 : {
6551 63 : if (!allow_score)
6552 : {
6553 10 : gfc_error ("%<score%> cannot be specified in traits "
6554 : "in the %qs trait-selector-set at %C",
6555 10 : omp_tss_map[oss->code]);
6556 10 : return MATCH_ERROR;
6557 : }
6558 53 : if (gfc_match (" (") != MATCH_YES)
6559 : {
6560 0 : gfc_error ("expected %<(%> at %C");
6561 0 : return MATCH_ERROR;
6562 : }
6563 53 : if (gfc_match_expr (&os->score) != MATCH_YES)
6564 : return MATCH_ERROR;
6565 :
6566 52 : if (gfc_match (" )") != MATCH_YES)
6567 : {
6568 0 : gfc_error ("expected %<)%> at %C");
6569 0 : return MATCH_ERROR;
6570 : }
6571 :
6572 52 : if (gfc_match (" :") != MATCH_YES)
6573 : {
6574 0 : gfc_error ("expected : at %C");
6575 0 : return MATCH_ERROR;
6576 : }
6577 : }
6578 :
6579 414 : gfc_omp_trait_property *otp = gfc_get_omp_trait_property ();
6580 414 : otp->property_kind = property_kind;
6581 414 : otp->next = os->properties;
6582 414 : os->properties = otp;
6583 :
6584 414 : switch (property_kind)
6585 : {
6586 25 : case OMP_TRAIT_PROPERTY_ID:
6587 25 : {
6588 25 : char buf[GFC_MAX_SYMBOL_LEN + 1];
6589 25 : if (gfc_match_name (buf) == MATCH_YES)
6590 : {
6591 24 : otp->name = XNEWVEC (char, strlen (buf) + 1);
6592 24 : strcpy (otp->name, buf);
6593 : }
6594 : else
6595 : {
6596 1 : gfc_error ("expected identifier at %C");
6597 1 : free (otp);
6598 1 : os->properties = nullptr;
6599 1 : return MATCH_ERROR;
6600 : }
6601 : }
6602 24 : break;
6603 290 : case OMP_TRAIT_PROPERTY_NAME_LIST:
6604 343 : do
6605 : {
6606 290 : char buf[GFC_MAX_SYMBOL_LEN + 1];
6607 290 : if (gfc_match_name (buf) == MATCH_YES)
6608 : {
6609 170 : otp->name = XNEWVEC (char, strlen (buf) + 1);
6610 170 : strcpy (otp->name, buf);
6611 170 : otp->is_name = true;
6612 : }
6613 120 : else if (gfc_match_literal_constant (&otp->expr, 0)
6614 : != MATCH_YES
6615 120 : || otp->expr->ts.type != BT_CHARACTER)
6616 : {
6617 5 : gfc_error ("expected identifier or string literal "
6618 : "at %C");
6619 5 : free (otp);
6620 5 : os->properties = nullptr;
6621 5 : return MATCH_ERROR;
6622 : }
6623 :
6624 285 : if (gfc_match (" ,") == MATCH_YES)
6625 : {
6626 53 : otp = gfc_get_omp_trait_property ();
6627 53 : otp->property_kind = property_kind;
6628 53 : otp->next = os->properties;
6629 53 : os->properties = otp;
6630 : }
6631 : else
6632 : break;
6633 53 : }
6634 : while (1);
6635 232 : break;
6636 137 : case OMP_TRAIT_PROPERTY_DEV_NUM_EXPR:
6637 137 : case OMP_TRAIT_PROPERTY_BOOL_EXPR:
6638 137 : if (gfc_match_expr (&otp->expr) != MATCH_YES)
6639 : {
6640 3 : gfc_error ("expected expression at %C");
6641 3 : free (otp);
6642 3 : os->properties = nullptr;
6643 3 : return MATCH_ERROR;
6644 : }
6645 : break;
6646 15 : case OMP_TRAIT_PROPERTY_CLAUSE_LIST:
6647 15 : {
6648 15 : if (os->code == OMP_TRAIT_CONSTRUCT_SIMD)
6649 : {
6650 15 : gfc_matching_omp_context_selector = true;
6651 15 : if (gfc_match_omp_clauses (&otp->clauses,
6652 15 : OMP_DECLARE_SIMD_CLAUSES,
6653 : true, false, false)
6654 : != MATCH_YES)
6655 : {
6656 1 : gfc_matching_omp_context_selector = false;
6657 1 : gfc_error ("expected simd clause at %C");
6658 1 : return MATCH_ERROR;
6659 : }
6660 14 : gfc_matching_omp_context_selector = false;
6661 : }
6662 0 : else if (os->code == OMP_TRAIT_IMPLEMENTATION_REQUIRES)
6663 : {
6664 : /* FIXME: The "requires" selector was added in OpenMP 5.1.
6665 : Currently only the now-deprecated syntax
6666 : from OpenMP 5.0 is supported.
6667 : TODO: When implementing, update modules.cc as well. */
6668 0 : sorry_at (gfc_get_location (&gfc_current_locus),
6669 : "%<requires%> selector is not supported yet");
6670 0 : return MATCH_ERROR;
6671 : }
6672 : else
6673 0 : gcc_unreachable ();
6674 14 : break;
6675 : }
6676 0 : default:
6677 0 : gcc_unreachable ();
6678 : }
6679 :
6680 404 : if (gfc_match (" )") != MATCH_YES)
6681 : {
6682 2 : gfc_error ("expected %<)%> at %C");
6683 2 : return MATCH_ERROR;
6684 : }
6685 : }
6686 324 : else if (property_kind != OMP_TRAIT_PROPERTY_NONE
6687 324 : && property_kind != OMP_TRAIT_PROPERTY_CLAUSE_LIST
6688 8 : && property_kind != OMP_TRAIT_PROPERTY_EXTENSION)
6689 : {
6690 8 : if (gfc_match (" (") != MATCH_YES)
6691 : {
6692 8 : gfc_error ("expected %<(%> at %C");
6693 8 : return MATCH_ERROR;
6694 : }
6695 : }
6696 :
6697 718 : if (gfc_match (" ,") != MATCH_YES)
6698 : break;
6699 : }
6700 : while (1);
6701 :
6702 598 : return MATCH_YES;
6703 : }
6704 :
6705 : /* OpenMP 5.0:
6706 :
6707 : trait-set-selector[,trait-set-selector[,...]]
6708 :
6709 : trait-set-selector:
6710 : trait-set-selector-name = { trait-selector[, trait-selector[, ...]] }
6711 :
6712 : trait-set-selector-name:
6713 : constructor
6714 : device
6715 : implementation
6716 : user */
6717 :
6718 : static match
6719 577 : gfc_match_omp_context_selector_specification (gfc_omp_set_selector **oss_head)
6720 : {
6721 713 : do
6722 : {
6723 645 : match m;
6724 645 : char buf[GFC_MAX_SYMBOL_LEN + 1];
6725 645 : enum omp_tss_code set = OMP_TRAIT_SET_INVALID;
6726 :
6727 645 : m = gfc_match_name (buf);
6728 645 : if (m == MATCH_YES)
6729 643 : set = omp_lookup_tss_code (buf);
6730 :
6731 643 : if (set == OMP_TRAIT_SET_INVALID)
6732 : {
6733 5 : gfc_error ("expected context selector set name at %C");
6734 47 : return MATCH_ERROR;
6735 : }
6736 :
6737 640 : m = gfc_match (" =");
6738 640 : if (m != MATCH_YES)
6739 : {
6740 1 : gfc_error ("expected %<=%> at %C");
6741 1 : return MATCH_ERROR;
6742 : }
6743 :
6744 639 : m = gfc_match (" {");
6745 639 : if (m != MATCH_YES)
6746 : {
6747 2 : gfc_error ("expected %<{%> at %C");
6748 2 : return MATCH_ERROR;
6749 : }
6750 :
6751 637 : gfc_omp_set_selector *oss = gfc_get_omp_set_selector ();
6752 637 : oss->next = *oss_head;
6753 637 : oss->code = set;
6754 637 : *oss_head = oss;
6755 :
6756 637 : if (gfc_match_omp_context_selector (oss) != MATCH_YES)
6757 : return MATCH_ERROR;
6758 :
6759 598 : m = gfc_match (" }");
6760 598 : if (m != MATCH_YES)
6761 : {
6762 0 : gfc_error ("expected %<}%> at %C");
6763 0 : return MATCH_ERROR;
6764 : }
6765 :
6766 598 : m = gfc_match (" ,");
6767 598 : if (m != MATCH_YES)
6768 : break;
6769 68 : }
6770 : while (1);
6771 :
6772 530 : return MATCH_YES;
6773 : }
6774 :
6775 :
6776 : match
6777 419 : gfc_match_omp_declare_variant (void)
6778 : {
6779 419 : char buf[GFC_MAX_SYMBOL_LEN + 1];
6780 :
6781 419 : if (gfc_match (" (") != MATCH_YES)
6782 : {
6783 2 : gfc_error ("expected %<(%> at %C");
6784 2 : return MATCH_ERROR;
6785 : }
6786 :
6787 417 : gfc_symtree *base_proc_st, *variant_proc_st;
6788 417 : if (gfc_match_name (buf) != MATCH_YES)
6789 : {
6790 2 : gfc_error ("expected name at %C");
6791 2 : return MATCH_ERROR;
6792 : }
6793 :
6794 415 : if (gfc_get_ha_sym_tree (buf, &base_proc_st))
6795 : return MATCH_ERROR;
6796 :
6797 415 : if (gfc_match (" :") == MATCH_YES)
6798 : {
6799 16 : if (gfc_match_name (buf) != MATCH_YES)
6800 : {
6801 0 : gfc_error ("expected variant name at %C");
6802 0 : return MATCH_ERROR;
6803 : }
6804 :
6805 16 : if (gfc_get_ha_sym_tree (buf, &variant_proc_st))
6806 : return MATCH_ERROR;
6807 : }
6808 : else
6809 : {
6810 : /* Base procedure not specified. */
6811 399 : variant_proc_st = base_proc_st;
6812 399 : base_proc_st = NULL;
6813 : }
6814 :
6815 415 : gfc_omp_declare_variant *odv;
6816 415 : odv = gfc_get_omp_declare_variant ();
6817 415 : odv->where = gfc_current_locus;
6818 415 : odv->variant_proc_symtree = variant_proc_st;
6819 415 : odv->adjust_args_list = NULL;
6820 415 : odv->base_proc_symtree = base_proc_st;
6821 415 : odv->next = NULL;
6822 415 : odv->error_p = false;
6823 :
6824 : /* Add the new declare variant to the end of the list. */
6825 415 : gfc_omp_declare_variant **prev_next = &gfc_current_ns->omp_declare_variant;
6826 555 : while (*prev_next)
6827 140 : prev_next = &((*prev_next)->next);
6828 415 : *prev_next = odv;
6829 :
6830 415 : if (gfc_match (" )") != MATCH_YES)
6831 : {
6832 1 : gfc_error ("expected %<)%> at %C");
6833 1 : return MATCH_ERROR;
6834 : }
6835 :
6836 414 : bool has_match = false, has_adjust_args = false, has_append_args = false;
6837 414 : bool error_p = false;
6838 414 : locus adjust_args_loc;
6839 414 : locus append_args_loc;
6840 :
6841 414 : gfc_gobble_whitespace ();
6842 414 : gfc_match_char (',');
6843 632 : for (;;)
6844 : {
6845 523 : gfc_gobble_whitespace ();
6846 :
6847 523 : enum clause
6848 : {
6849 : clause_match,
6850 : clause_adjust_args,
6851 : clause_append_args
6852 : } ccode;
6853 :
6854 523 : if (gfc_match ("match") == MATCH_YES)
6855 : ccode = clause_match;
6856 119 : else if (gfc_match ("adjust_args") == MATCH_YES)
6857 : {
6858 517 : ccode = clause_adjust_args;
6859 : adjust_args_loc = gfc_current_locus;
6860 : }
6861 38 : else if (gfc_match ("append_args") == MATCH_YES)
6862 : {
6863 517 : ccode = clause_append_args;
6864 : append_args_loc = gfc_current_locus;
6865 : }
6866 : else
6867 : {
6868 : error_p = true;
6869 : break;
6870 : }
6871 :
6872 517 : if (gfc_match (" ( ") != MATCH_YES)
6873 : {
6874 1 : gfc_error ("expected %<(%> at %C");
6875 1 : return MATCH_ERROR;
6876 : }
6877 :
6878 516 : if (ccode == clause_match)
6879 : {
6880 403 : if (has_match)
6881 : {
6882 1 : gfc_error ("%qs clause at %L specified more than once",
6883 : "match", &gfc_current_locus);
6884 1 : return MATCH_ERROR;
6885 : }
6886 402 : has_match = true;
6887 402 : if (gfc_match_omp_context_selector_specification (&odv->set_selectors)
6888 : != MATCH_YES)
6889 : return MATCH_ERROR;
6890 362 : if (gfc_match (" )") != MATCH_YES)
6891 : {
6892 0 : gfc_error ("expected %<)%> at %C");
6893 0 : return MATCH_ERROR;
6894 : }
6895 : }
6896 113 : else if (ccode == clause_adjust_args)
6897 : {
6898 81 : has_adjust_args = true;
6899 81 : bool need_device_ptr_p = false;
6900 81 : bool need_device_addr_p = false;
6901 81 : if (gfc_match ("nothing ") == MATCH_YES)
6902 : ;
6903 58 : else if (gfc_match ("need_device_ptr ") == MATCH_YES)
6904 : need_device_ptr_p = true;
6905 9 : else if (gfc_match ("need_device_addr ") == MATCH_YES)
6906 : need_device_addr_p = true;
6907 : else
6908 : {
6909 2 : gfc_error ("expected %<nothing%>, %<need_device_ptr%> or "
6910 : "%<need_device_addr%> at %C");
6911 2 : return MATCH_ERROR;
6912 : }
6913 79 : if (gfc_match (": ") != MATCH_YES)
6914 : {
6915 1 : gfc_error ("expected %<:%> at %C");
6916 1 : return MATCH_ERROR;
6917 : }
6918 : gfc_omp_namelist *tail = NULL;
6919 : bool need_range = false, have_range = false;
6920 125 : while (true)
6921 : {
6922 125 : gfc_omp_namelist *p = gfc_get_omp_namelist ();
6923 125 : p->where = gfc_current_locus;
6924 125 : p->u.adj_args.need_ptr = need_device_ptr_p;
6925 125 : p->u.adj_args.need_addr = need_device_addr_p;
6926 125 : if (tail)
6927 : {
6928 47 : tail->next = p;
6929 47 : tail = tail->next;
6930 : }
6931 : else
6932 : {
6933 78 : gfc_omp_namelist **q = &odv->adjust_args_list;
6934 78 : if (*q)
6935 : {
6936 50 : for (; (*q)->next; q = &(*q)->next)
6937 : ;
6938 28 : (*q)->next = p;
6939 : }
6940 : else
6941 50 : *q = p;
6942 : tail = p;
6943 : }
6944 125 : if (gfc_match (": ") == MATCH_YES)
6945 : {
6946 2 : if (have_range)
6947 : {
6948 0 : gfc_error ("unexpected %<:%> at %C");
6949 2 : return MATCH_ERROR;
6950 : }
6951 2 : p->u.adj_args.range_start = have_range = true;
6952 2 : need_range = false;
6953 49 : continue;
6954 : }
6955 123 : if (have_range && gfc_match (", ") == MATCH_YES)
6956 : {
6957 1 : have_range = false;
6958 1 : continue;
6959 : }
6960 122 : if (have_range && gfc_match (") ") == MATCH_YES)
6961 : break;
6962 121 : locus saved_loc = gfc_current_locus;
6963 :
6964 : /* Without ranges, only arg names or integer literals permitted;
6965 : handle literals here as gfc_match_expr simplifies the expr. */
6966 121 : if (gfc_match_literal_constant (&p->expr, true) == MATCH_YES)
6967 : {
6968 17 : gfc_gobble_whitespace ();
6969 17 : char c = gfc_peek_ascii_char ();
6970 17 : if (c != ')' && c != ',' && c != ':')
6971 : {
6972 1 : gfc_free_expr (p->expr);
6973 1 : p->expr = NULL;
6974 1 : gfc_current_locus = saved_loc;
6975 : }
6976 : }
6977 121 : if (!p->expr && gfc_match ("omp_num_args") == MATCH_YES)
6978 : {
6979 6 : if (!have_range)
6980 3 : p->u.adj_args.range_start = need_range = true;
6981 : else
6982 : need_range = false;
6983 :
6984 6 : locus saved_loc2 = gfc_current_locus;
6985 6 : gfc_gobble_whitespace ();
6986 6 : char c = gfc_peek_ascii_char ();
6987 6 : if (c == '+' || c == '-')
6988 : {
6989 5 : if (gfc_match ("+ %e", &p->expr) == MATCH_YES)
6990 1 : p->u.adj_args.omp_num_args_plus = true;
6991 4 : else if (gfc_match ("- %e", &p->expr) == MATCH_YES)
6992 4 : p->u.adj_args.omp_num_args_minus = true;
6993 0 : else if (!gfc_error_check ())
6994 : {
6995 0 : gfc_error ("expected constant integer expression "
6996 : "at %C");
6997 0 : p->u.adj_args.error_p = true;
6998 0 : return MATCH_ERROR;
6999 : }
7000 5 : p->where = gfc_get_location_range (&saved_loc, 1,
7001 : &saved_loc, 1,
7002 : &gfc_current_locus);
7003 : }
7004 : else
7005 : {
7006 1 : p->where = gfc_get_location_range (&saved_loc, 1,
7007 : &saved_loc, 1,
7008 : &saved_loc2);
7009 1 : p->u.adj_args.omp_num_args_plus = true;
7010 : }
7011 : }
7012 115 : else if (!p->expr)
7013 : {
7014 99 : match m = gfc_match_expr (&p->expr);
7015 99 : if (m != MATCH_YES)
7016 : {
7017 1 : gfc_error ("expected dummy parameter name, "
7018 : "%<omp_num_args%> or constant positive integer"
7019 : " at %C");
7020 1 : p->u.adj_args.error_p = true;
7021 1 : return MATCH_ERROR;
7022 : }
7023 98 : if (p->expr->expr_type == EXPR_CONSTANT && !have_range)
7024 98 : need_range = true; /* Constant expr but not literal. */
7025 98 : p->where = p->expr->where;
7026 : }
7027 : else
7028 16 : p->where = p->expr->where;
7029 120 : gfc_gobble_whitespace ();
7030 120 : match m = gfc_match (": ");
7031 120 : if (need_range && m != MATCH_YES)
7032 : {
7033 1 : gfc_error ("expected %<:%> at %C");
7034 1 : return MATCH_ERROR;
7035 : }
7036 119 : if (m == MATCH_YES)
7037 : {
7038 6 : p->u.adj_args.range_start = have_range = true;
7039 6 : need_range = false;
7040 6 : continue;
7041 : }
7042 113 : need_range = have_range = false;
7043 113 : if (gfc_match (", ") == MATCH_YES)
7044 38 : continue;
7045 75 : if (gfc_match (") ") == MATCH_YES)
7046 : break;
7047 : }
7048 : }
7049 32 : else if (ccode == clause_append_args)
7050 : {
7051 32 : if (has_append_args)
7052 : {
7053 1 : gfc_error ("%qs clause at %L specified more than once",
7054 : "append_args", &gfc_current_locus);
7055 1 : return MATCH_ERROR;
7056 : }
7057 56 : has_append_args = true;
7058 : gfc_omp_namelist *append_args_last = NULL;
7059 81 : do
7060 : {
7061 56 : gfc_gobble_whitespace ();
7062 56 : if (gfc_match ("interop ") != MATCH_YES)
7063 : {
7064 0 : gfc_error ("expected %<interop%> at %C");
7065 3 : return MATCH_ERROR;
7066 : }
7067 56 : if (gfc_match ("( ") != MATCH_YES)
7068 : {
7069 0 : gfc_error ("expected %<(%> at %C");
7070 0 : return MATCH_ERROR;
7071 : }
7072 :
7073 56 : bool target, targetsync;
7074 56 : char *type_str = NULL;
7075 56 : int type_str_len;
7076 56 : locus loc = gfc_current_locus;
7077 56 : if (gfc_parser_omp_clause_init_modifiers (target, targetsync,
7078 : &type_str, type_str_len,
7079 : false) == MATCH_ERROR)
7080 : return MATCH_ERROR;
7081 :
7082 54 : gfc_omp_namelist *n = gfc_get_omp_namelist();
7083 54 : n->where = loc;
7084 54 : n->u.init.target = target;
7085 54 : n->u.init.targetsync = targetsync;
7086 54 : n->u.init.len = type_str_len;
7087 54 : n->u2.init_interop = type_str;
7088 54 : if (odv->append_args_list)
7089 : {
7090 25 : append_args_last->next = n;
7091 25 : append_args_last = n;
7092 : }
7093 : else
7094 29 : append_args_last = odv->append_args_list = n;
7095 :
7096 54 : gfc_gobble_whitespace ();
7097 54 : if (gfc_match_char (',') == MATCH_YES)
7098 25 : continue;
7099 29 : if (gfc_match_char (')') == MATCH_YES)
7100 : break;
7101 1 : gfc_error ("Expected %<,%> or %<)%> at %C");
7102 1 : return MATCH_ERROR;
7103 : }
7104 : while (true);
7105 : }
7106 466 : gfc_gobble_whitespace ();
7107 466 : if (gfc_match_omp_eos () == MATCH_YES)
7108 : break;
7109 109 : gfc_match_char (',');
7110 109 : }
7111 :
7112 363 : if (error_p || (!has_match && !has_adjust_args && !has_append_args))
7113 : {
7114 6 : gfc_error ("expected %<match%>, %<adjust_args%> or %<append_args%> at %C");
7115 6 : return MATCH_ERROR;
7116 : }
7117 :
7118 357 : if (!has_match)
7119 : {
7120 3 : gfc_error ("expected %<match%> clause at %C");
7121 3 : return MATCH_ERROR;
7122 : }
7123 :
7124 : return MATCH_YES;
7125 : }
7126 :
7127 :
7128 : static match
7129 160 : match_omp_metadirective (bool begin_p)
7130 : {
7131 160 : locus old_loc = gfc_current_locus;
7132 160 : gfc_omp_variant *variants_head;
7133 160 : gfc_omp_variant **next_variant = &variants_head;
7134 160 : bool default_seen = false;
7135 :
7136 : /* Parse the context selectors. */
7137 656 : for (;;)
7138 : {
7139 408 : bool default_p = false;
7140 408 : gfc_omp_set_selector *selectors = NULL;
7141 :
7142 408 : gfc_gobble_whitespace ();
7143 408 : if (gfc_match_eos () == MATCH_YES)
7144 : break;
7145 266 : gfc_match_char (',');
7146 266 : gfc_gobble_whitespace ();
7147 :
7148 266 : locus variant_locus = gfc_current_locus;
7149 :
7150 266 : if (gfc_match ("default ( ") == MATCH_YES)
7151 : {
7152 82 : default_p = true;
7153 82 : gfc_warning (OPT_Wdeprecated_openmp,
7154 : "%<default%> clause with metadirective at %L "
7155 : "deprecated since OpenMP 5.2", &variant_locus);
7156 : }
7157 184 : else if (gfc_match ("otherwise ( ") == MATCH_YES)
7158 : default_p = true;
7159 177 : else if (gfc_match ("when ( ") != MATCH_YES)
7160 : {
7161 1 : gfc_error ("expected %<when%>, %<otherwise%>, or %<default%> at %C");
7162 1 : gfc_current_locus = old_loc;
7163 18 : return MATCH_ERROR;
7164 : }
7165 89 : if (default_p && default_seen)
7166 : {
7167 3 : gfc_error ("too many %<otherwise%> or %<default%> clauses "
7168 : "in %<metadirective%> at %C");
7169 3 : gfc_current_locus = old_loc;
7170 3 : return MATCH_ERROR;
7171 : }
7172 262 : else if (default_seen)
7173 : {
7174 1 : gfc_error ("%<otherwise%> or %<default%> clause "
7175 : "must appear last in %<metadirective%> at %C");
7176 1 : gfc_current_locus = old_loc;
7177 1 : return MATCH_ERROR;
7178 : }
7179 :
7180 261 : if (!default_p)
7181 : {
7182 175 : if (gfc_match_omp_context_selector_specification (&selectors)
7183 : != MATCH_YES)
7184 : return MATCH_ERROR;
7185 :
7186 168 : if (gfc_match (" : ") != MATCH_YES)
7187 : {
7188 1 : gfc_error ("expected %<:%> at %C");
7189 1 : gfc_current_locus = old_loc;
7190 1 : return MATCH_ERROR;
7191 : }
7192 :
7193 167 : gfc_commit_symbols ();
7194 : }
7195 :
7196 253 : gfc_matching_omp_context_selector = true;
7197 253 : gfc_statement directive = match_omp_directive ();
7198 253 : gfc_matching_omp_context_selector = false;
7199 :
7200 253 : if (is_omp_declarative_stmt (directive))
7201 0 : sorry_at (gfc_get_location (&gfc_current_locus),
7202 : "declarative directive variants are not supported");
7203 :
7204 253 : if (gfc_error_flag_test ())
7205 : {
7206 2 : gfc_current_locus = old_loc;
7207 2 : return MATCH_ERROR;
7208 : }
7209 :
7210 251 : if (gfc_match (" )") != MATCH_YES)
7211 : {
7212 0 : gfc_error ("Expected %<)%> at %C");
7213 0 : gfc_current_locus = old_loc;
7214 0 : return MATCH_ERROR;
7215 : }
7216 :
7217 251 : gfc_commit_symbols ();
7218 :
7219 251 : if (begin_p
7220 251 : && directive != ST_NONE
7221 251 : && gfc_omp_end_stmt (directive) == ST_NONE)
7222 : {
7223 3 : gfc_error ("variant directive used in OMP BEGIN METADIRECTIVE "
7224 : "at %C must have a corresponding end directive");
7225 3 : gfc_current_locus = old_loc;
7226 3 : return MATCH_ERROR;
7227 : }
7228 :
7229 248 : if (default_p)
7230 : default_seen = true;
7231 :
7232 248 : gfc_omp_variant *omv = gfc_get_omp_variant ();
7233 248 : omv->selectors = selectors;
7234 248 : omv->stmt = directive;
7235 248 : omv->where = variant_locus;
7236 :
7237 248 : if (directive == ST_NONE)
7238 : {
7239 : /* The directive was a 'nothing' directive. */
7240 15 : omv->code = gfc_get_code (EXEC_CONTINUE);
7241 15 : omv->code->ext.omp_clauses = NULL;
7242 : }
7243 : else
7244 : {
7245 233 : omv->code = gfc_get_code (new_st.op);
7246 233 : omv->code->ext.omp_clauses = new_st.ext.omp_clauses;
7247 : /* Prevent the OpenMP clauses from being freed via NEW_ST. */
7248 233 : new_st.ext.omp_clauses = NULL;
7249 : }
7250 :
7251 248 : *next_variant = omv;
7252 248 : next_variant = &omv->next;
7253 248 : }
7254 :
7255 142 : if (gfc_match_omp_eos () != MATCH_YES)
7256 : {
7257 0 : gfc_error ("Unexpected junk after OMP METADIRECTIVE at %C");
7258 0 : gfc_current_locus = old_loc;
7259 0 : return MATCH_ERROR;
7260 : }
7261 :
7262 : /* Add a 'default (nothing)' clause if no default is explicitly given. */
7263 142 : if (!default_seen)
7264 : {
7265 65 : gfc_omp_variant *omv = gfc_get_omp_variant ();
7266 65 : omv->stmt = ST_NONE;
7267 65 : omv->code = gfc_get_code (EXEC_CONTINUE);
7268 65 : omv->code->ext.omp_clauses = NULL;
7269 65 : omv->where = old_loc;
7270 65 : omv->selectors = NULL;
7271 :
7272 65 : *next_variant = omv;
7273 65 : next_variant = &omv->next;
7274 : }
7275 :
7276 142 : new_st.op = EXEC_OMP_METADIRECTIVE;
7277 142 : new_st.ext.omp_variants = variants_head;
7278 :
7279 142 : return MATCH_YES;
7280 : }
7281 :
7282 : match
7283 43 : gfc_match_omp_begin_metadirective (void)
7284 : {
7285 43 : return match_omp_metadirective (true);
7286 : }
7287 :
7288 : match
7289 117 : gfc_match_omp_metadirective (void)
7290 : {
7291 117 : return match_omp_metadirective (false);
7292 : }
7293 :
7294 : /* Match 'omp threadprivate' or 'omp groupprivate'. */
7295 : static match
7296 259 : gfc_match_omp_thread_group_private (bool is_groupprivate)
7297 : {
7298 259 : locus old_loc;
7299 259 : char n[GFC_MAX_SYMBOL_LEN+1];
7300 259 : gfc_symbol *sym;
7301 259 : match m;
7302 259 : gfc_symtree *st;
7303 259 : struct sym_loc_t { gfc_symbol *sym; gfc_common_head *com; locus loc; };
7304 259 : auto_vec<sym_loc_t> syms;
7305 :
7306 259 : old_loc = gfc_current_locus;
7307 :
7308 259 : m = gfc_match (" ( ");
7309 259 : if (m != MATCH_YES)
7310 : return m;
7311 :
7312 369 : for (;;)
7313 : {
7314 314 : locus sym_loc = gfc_current_locus;
7315 314 : m = gfc_match_symbol (&sym, 0);
7316 314 : switch (m)
7317 : {
7318 209 : case MATCH_YES:
7319 209 : if (sym->attr.in_common)
7320 0 : gfc_error_now ("%qs variable at %L is an element of a COMMON block",
7321 : is_groupprivate ? "groupprivate" : "threadprivate",
7322 : &sym_loc);
7323 209 : else if (!is_groupprivate
7324 209 : && !gfc_add_threadprivate (&sym->attr, sym->name, &sym_loc))
7325 16 : goto cleanup;
7326 207 : else if (is_groupprivate)
7327 : {
7328 30 : if (!gfc_add_omp_groupprivate (&sym->attr, sym->name, &sym_loc))
7329 4 : goto cleanup;
7330 26 : syms.safe_push ({sym, nullptr, sym_loc});
7331 : }
7332 203 : goto next_item;
7333 : case MATCH_NO:
7334 : break;
7335 0 : case MATCH_ERROR:
7336 0 : goto cleanup;
7337 : }
7338 :
7339 105 : m = gfc_match (" / %n /", n);
7340 105 : if (m == MATCH_ERROR)
7341 0 : goto cleanup;
7342 105 : if (m == MATCH_NO || n[0] == '\0')
7343 0 : goto syntax;
7344 :
7345 105 : st = gfc_find_symtree (gfc_current_ns->common_root, n);
7346 105 : if (st == NULL)
7347 : {
7348 2 : gfc_error ("COMMON block /%s/ not found at %L", n, &sym_loc);
7349 2 : goto cleanup;
7350 : }
7351 103 : syms.safe_push ({nullptr, st->n.common, sym_loc});
7352 103 : if (is_groupprivate)
7353 30 : st->n.common->omp_groupprivate = 1;
7354 : else
7355 73 : st->n.common->threadprivate = 1;
7356 236 : for (sym = st->n.common->head; sym; sym = sym->common_next)
7357 141 : if (!is_groupprivate
7358 141 : && !gfc_add_threadprivate (&sym->attr, sym->name, &sym_loc))
7359 3 : goto cleanup;
7360 138 : else if (is_groupprivate
7361 138 : && !gfc_add_omp_groupprivate (&sym->attr, sym->name, &sym_loc))
7362 5 : goto cleanup;
7363 :
7364 95 : next_item:
7365 298 : if (gfc_match_char (')') == MATCH_YES)
7366 : break;
7367 55 : if (gfc_match_char (',') != MATCH_YES)
7368 0 : goto syntax;
7369 55 : }
7370 :
7371 243 : if (is_groupprivate)
7372 : {
7373 39 : gfc_omp_clauses *c;
7374 39 : m = gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_DEVICE_TYPE));
7375 39 : if (m == MATCH_ERROR)
7376 0 : return MATCH_ERROR;
7377 :
7378 39 : if (c->device_type == OMP_DEVICE_TYPE_UNSET)
7379 19 : c->device_type = OMP_DEVICE_TYPE_ANY;
7380 :
7381 86 : for (size_t i = 0; i < syms.length (); i++)
7382 47 : if (syms[i].sym)
7383 : {
7384 24 : sym_loc_t &n = syms[i];
7385 24 : if (n.sym->attr.in_common)
7386 0 : gfc_error_now ("Variable %qs at %L is an element of a COMMON "
7387 : "block", n.sym->name, &n.loc);
7388 24 : else if (n.sym->attr.omp_declare_target
7389 23 : || n.sym->attr.omp_declare_target_link)
7390 2 : gfc_error_now ("List item %qs at %L implies OMP DECLARE TARGET "
7391 : "with the LOCAL clause, but it has been specified"
7392 : " with a different clause before",
7393 : n.sym->name, &n.loc);
7394 24 : if (n.sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
7395 5 : && n.sym->attr.omp_device_type != c->device_type)
7396 : {
7397 2 : const char *dt = "any";
7398 2 : if (n.sym->attr.omp_device_type == OMP_DEVICE_TYPE_HOST)
7399 : dt = "host";
7400 0 : else if (n.sym->attr.omp_device_type == OMP_DEVICE_TYPE_NOHOST)
7401 0 : dt = "nohost";
7402 2 : gfc_error_now ("List item %qs at %L set in previous OMP DECLARE "
7403 : "TARGET directive to the different DEVICE_TYPE %qs",
7404 : n.sym->name, &n.loc, dt);
7405 : }
7406 24 : gfc_add_omp_declare_target_local (&n.sym->attr, n.sym->name,
7407 : &n.loc);
7408 24 : n.sym->attr.omp_device_type = c->device_type;
7409 : }
7410 : else /* Common block. */
7411 : {
7412 23 : sym_loc_t &n = syms[i];
7413 23 : if (n.com->omp_declare_target
7414 22 : || n.com->omp_declare_target_link)
7415 2 : gfc_error_now ("List item %</%s/%> at %L implies OMP DECLARE "
7416 : "TARGET with the LOCAL clause, but it has been "
7417 : "specified with a different clause before",
7418 2 : n.com->name, &n.loc);
7419 23 : if (n.com->omp_device_type != OMP_DEVICE_TYPE_UNSET
7420 5 : && n.com->omp_device_type != c->device_type)
7421 : {
7422 2 : const char *dt = "any";
7423 2 : if (n.com->omp_device_type == OMP_DEVICE_TYPE_HOST)
7424 : dt = "host";
7425 0 : else if (n.com->omp_device_type == OMP_DEVICE_TYPE_NOHOST)
7426 0 : dt = "nohost";
7427 2 : gfc_error_now ("List item %qs at %L set in previous OMP DECLARE"
7428 : " TARGET directive to the different DEVICE_TYPE "
7429 2 : "%qs", n.com->name, &n.loc, dt);
7430 : }
7431 23 : n.com->omp_declare_target_local = 1;
7432 23 : n.com->omp_device_type = c->device_type;
7433 46 : for (gfc_symbol *s = n.com->head; s; s = s->common_next)
7434 : {
7435 23 : gfc_add_omp_declare_target_local (&s->attr, s->name, &n.loc);
7436 23 : s->attr.omp_device_type = c->device_type;
7437 : }
7438 : }
7439 39 : free (c);
7440 : }
7441 :
7442 243 : if (gfc_match_omp_eos () != MATCH_YES)
7443 : {
7444 0 : gfc_error ("Unexpected junk after OMP %s at %C",
7445 : is_groupprivate ? "GROUPPRIVATE" : "THREADPRIVATE");
7446 0 : goto cleanup;
7447 : }
7448 :
7449 : return MATCH_YES;
7450 :
7451 0 : syntax:
7452 0 : gfc_error ("Syntax error in !$OMP %s list at %C",
7453 : is_groupprivate ? "GROUPPRIVATE" : "THREADPRIVATE");
7454 :
7455 16 : cleanup:
7456 16 : gfc_current_locus = old_loc;
7457 16 : return MATCH_ERROR;
7458 259 : }
7459 :
7460 :
7461 : match
7462 48 : gfc_match_omp_groupprivate (void)
7463 : {
7464 48 : return gfc_match_omp_thread_group_private (true);
7465 : }
7466 :
7467 :
7468 : match
7469 211 : gfc_match_omp_threadprivate (void)
7470 : {
7471 211 : return gfc_match_omp_thread_group_private (false);
7472 : }
7473 :
7474 :
7475 : match
7476 2145 : gfc_match_omp_parallel (void)
7477 : {
7478 2145 : return match_omp (EXEC_OMP_PARALLEL, OMP_PARALLEL_CLAUSES);
7479 : }
7480 :
7481 :
7482 : match
7483 1199 : gfc_match_omp_parallel_do (void)
7484 : {
7485 1199 : return match_omp (EXEC_OMP_PARALLEL_DO,
7486 1199 : (OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
7487 1199 : & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
7488 : }
7489 :
7490 :
7491 : match
7492 298 : gfc_match_omp_parallel_do_simd (void)
7493 : {
7494 298 : return match_omp (EXEC_OMP_PARALLEL_DO_SIMD,
7495 298 : (OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
7496 298 : & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
7497 : }
7498 :
7499 :
7500 : match
7501 14 : gfc_match_omp_parallel_masked (void)
7502 : {
7503 14 : return match_omp (EXEC_OMP_PARALLEL_MASKED,
7504 14 : OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES);
7505 : }
7506 :
7507 : match
7508 10 : gfc_match_omp_parallel_masked_taskloop (void)
7509 : {
7510 10 : return match_omp (EXEC_OMP_PARALLEL_MASKED_TASKLOOP,
7511 10 : (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES
7512 10 : | OMP_TASKLOOP_CLAUSES)
7513 10 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
7514 : }
7515 :
7516 : match
7517 13 : gfc_match_omp_parallel_masked_taskloop_simd (void)
7518 : {
7519 13 : return match_omp (EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD,
7520 13 : (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES
7521 13 : | OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES)
7522 13 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
7523 : }
7524 :
7525 : match
7526 14 : gfc_match_omp_parallel_master (void)
7527 : {
7528 14 : gfc_warning (OPT_Wdeprecated_openmp,
7529 : "%<master%> construct at %C deprecated since OpenMP 5.1, use "
7530 : "%<masked%>");
7531 14 : return match_omp (EXEC_OMP_PARALLEL_MASTER, OMP_PARALLEL_CLAUSES);
7532 : }
7533 :
7534 : match
7535 15 : gfc_match_omp_parallel_master_taskloop (void)
7536 : {
7537 15 : gfc_warning (OPT_Wdeprecated_openmp,
7538 : "%<master%> construct at %C deprecated since OpenMP 5.1, "
7539 : "use %<masked%>");
7540 15 : return match_omp (EXEC_OMP_PARALLEL_MASTER_TASKLOOP,
7541 15 : (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES)
7542 15 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
7543 : }
7544 :
7545 : match
7546 21 : gfc_match_omp_parallel_master_taskloop_simd (void)
7547 : {
7548 21 : gfc_warning (OPT_Wdeprecated_openmp,
7549 : "%<master%> construct at %C deprecated since OpenMP 5.1, "
7550 : "use %<masked%>");
7551 21 : return match_omp (EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD,
7552 21 : (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES
7553 21 : | OMP_SIMD_CLAUSES)
7554 21 : & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
7555 : }
7556 :
7557 : match
7558 59 : gfc_match_omp_parallel_sections (void)
7559 : {
7560 59 : return match_omp (EXEC_OMP_PARALLEL_SECTIONS,
7561 59 : (OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES)
7562 59 : & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
7563 : }
7564 :
7565 :
7566 : match
7567 56 : gfc_match_omp_parallel_workshare (void)
7568 : {
7569 56 : return match_omp (EXEC_OMP_PARALLEL_WORKSHARE, OMP_PARALLEL_CLAUSES);
7570 : }
7571 :
7572 : void
7573 48975 : gfc_check_omp_requires (gfc_namespace *ns, int ref_omp_requires)
7574 : {
7575 48975 : const char *msg = G_("Program unit at %L has OpenMP device "
7576 : "constructs/routines but does not set !$OMP REQUIRES %s "
7577 : "but other program units do");
7578 48975 : if (ns->omp_target_seen
7579 1211 : && (ns->omp_requires & OMP_REQ_TARGET_MASK)
7580 1211 : != (ref_omp_requires & OMP_REQ_TARGET_MASK))
7581 : {
7582 6 : gcc_assert (ns->proc_name);
7583 6 : if ((ref_omp_requires & OMP_REQ_REVERSE_OFFLOAD)
7584 5 : && !(ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD))
7585 4 : gfc_error (msg, &ns->proc_name->declared_at, "REVERSE_OFFLOAD");
7586 6 : if ((ref_omp_requires & OMP_REQ_UNIFIED_ADDRESS)
7587 1 : && !(ns->omp_requires & OMP_REQ_UNIFIED_ADDRESS))
7588 1 : gfc_error (msg, &ns->proc_name->declared_at, "UNIFIED_ADDRESS");
7589 6 : if ((ref_omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY)
7590 4 : && !(ns->omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY))
7591 2 : gfc_error (msg, &ns->proc_name->declared_at, "UNIFIED_SHARED_MEMORY");
7592 6 : if ((ref_omp_requires & OMP_REQ_SELF_MAPS)
7593 1 : && !(ns->omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY))
7594 1 : gfc_error (msg, &ns->proc_name->declared_at, "SELF_MAPS");
7595 : }
7596 48975 : }
7597 :
7598 : bool
7599 120 : gfc_omp_requires_add_clause (gfc_omp_requires_kind clause,
7600 : const char *clause_name, locus *loc,
7601 : const char *module_name)
7602 : {
7603 120 : gfc_namespace *prog_unit = gfc_current_ns;
7604 144 : while (prog_unit->parent)
7605 : {
7606 25 : if (gfc_state_stack->previous
7607 25 : && gfc_state_stack->previous->state == COMP_INTERFACE)
7608 : break;
7609 : prog_unit = prog_unit->parent;
7610 : }
7611 :
7612 : /* Requires added after use. */
7613 120 : if (prog_unit->omp_target_seen
7614 24 : && (clause & OMP_REQ_TARGET_MASK)
7615 24 : && !(prog_unit->omp_requires & clause))
7616 : {
7617 0 : if (module_name)
7618 0 : gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use "
7619 : "at %L comes after using a device construct/routine",
7620 : clause_name, module_name, loc);
7621 : else
7622 0 : gfc_error ("!$OMP REQUIRES clause %qs specified at %L comes after "
7623 : "using a device construct/routine", clause_name, loc);
7624 0 : return false;
7625 : }
7626 :
7627 : /* Overriding atomic_default_mem_order clause value. */
7628 120 : if ((clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
7629 34 : && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
7630 6 : && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
7631 6 : != (int) clause)
7632 : {
7633 3 : const char *other;
7634 3 : switch (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
7635 : {
7636 : case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST: other = "seq_cst"; break;
7637 0 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL: other = "acq_rel"; break;
7638 1 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE: other = "acquire"; break;
7639 1 : case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED: other = "relaxed"; break;
7640 0 : case OMP_REQ_ATOMIC_MEM_ORDER_RELEASE: other = "release"; break;
7641 0 : default: gcc_unreachable ();
7642 : }
7643 :
7644 3 : if (module_name)
7645 0 : gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
7646 : "specified via module %qs use at %L overrides a previous "
7647 : "%<atomic_default_mem_order(%s)%> (which might be through "
7648 : "using a module)", clause_name, module_name, loc, other);
7649 : else
7650 3 : gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
7651 : "specified at %L overrides a previous "
7652 : "%<atomic_default_mem_order(%s)%> (which might be through "
7653 : "using a module)", clause_name, loc, other);
7654 3 : return false;
7655 : }
7656 :
7657 : /* Requires via module not at program-unit level and not repeating clause. */
7658 117 : if (prog_unit != gfc_current_ns && !(prog_unit->omp_requires & clause))
7659 : {
7660 0 : if (clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
7661 0 : gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
7662 : "specified via module %qs use at %L but same clause is "
7663 : "not specified for the program unit", clause_name,
7664 : module_name, loc);
7665 : else
7666 0 : gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use at "
7667 : "%L but same clause is not specified for the program unit",
7668 : clause_name, module_name, loc);
7669 0 : return false;
7670 : }
7671 :
7672 117 : if (!gfc_state_stack->previous
7673 109 : || gfc_state_stack->previous->state != COMP_INTERFACE)
7674 116 : prog_unit->omp_requires |= clause;
7675 : return true;
7676 : }
7677 :
7678 : match
7679 92 : gfc_match_omp_requires (void)
7680 : {
7681 92 : static const char *clauses[] = {"reverse_offload",
7682 : "unified_address",
7683 : "unified_shared_memory",
7684 : "self_maps",
7685 : "dynamic_allocators",
7686 : "atomic_default"};
7687 92 : const char *clause = NULL;
7688 92 : int requires_clauses = 0;
7689 92 : bool first = true;
7690 92 : locus old_loc;
7691 :
7692 92 : if (gfc_current_ns->parent
7693 7 : && (!gfc_state_stack->previous
7694 7 : || gfc_state_stack->previous->state != COMP_INTERFACE))
7695 : {
7696 6 : gfc_error ("!$OMP REQUIRES at %C must appear in the specification part "
7697 : "of a program unit");
7698 6 : return MATCH_ERROR;
7699 : }
7700 :
7701 258 : while (true)
7702 : {
7703 172 : old_loc = gfc_current_locus;
7704 172 : gfc_omp_requires_kind requires_clause;
7705 86 : if ((first || gfc_match_char (',') != MATCH_YES)
7706 172 : && (first && gfc_match_space () != MATCH_YES))
7707 0 : goto error;
7708 172 : first = false;
7709 172 : gfc_gobble_whitespace ();
7710 172 : old_loc = gfc_current_locus;
7711 :
7712 172 : if (gfc_match_omp_eos () != MATCH_NO)
7713 : break;
7714 97 : if (gfc_match (clauses[0]) == MATCH_YES)
7715 : {
7716 34 : clause = clauses[0];
7717 34 : requires_clause = OMP_REQ_REVERSE_OFFLOAD;
7718 34 : if (requires_clauses & OMP_REQ_REVERSE_OFFLOAD)
7719 1 : goto duplicate_clause;
7720 : }
7721 63 : else if (gfc_match (clauses[1]) == MATCH_YES)
7722 : {
7723 9 : clause = clauses[1];
7724 9 : requires_clause = OMP_REQ_UNIFIED_ADDRESS;
7725 9 : if (requires_clauses & OMP_REQ_UNIFIED_ADDRESS)
7726 1 : goto duplicate_clause;
7727 : }
7728 54 : else if (gfc_match (clauses[2]) == MATCH_YES)
7729 : {
7730 14 : clause = clauses[2];
7731 14 : requires_clause = OMP_REQ_UNIFIED_SHARED_MEMORY;
7732 14 : if (requires_clauses & OMP_REQ_UNIFIED_SHARED_MEMORY)
7733 1 : goto duplicate_clause;
7734 : }
7735 40 : else if (gfc_match (clauses[3]) == MATCH_YES)
7736 : {
7737 1 : clause = clauses[3];
7738 1 : requires_clause = OMP_REQ_SELF_MAPS;
7739 1 : if (requires_clauses & OMP_REQ_SELF_MAPS)
7740 0 : goto duplicate_clause;
7741 : }
7742 39 : else if (gfc_match (clauses[4]) == MATCH_YES)
7743 : {
7744 7 : clause = clauses[4];
7745 7 : requires_clause = OMP_REQ_DYNAMIC_ALLOCATORS;
7746 7 : if (requires_clauses & OMP_REQ_DYNAMIC_ALLOCATORS)
7747 1 : goto duplicate_clause;
7748 : }
7749 32 : else if (gfc_match ("atomic_default_mem_order (") == MATCH_YES)
7750 : {
7751 31 : clause = clauses[5];
7752 31 : if (requires_clauses & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
7753 1 : goto duplicate_clause;
7754 30 : if (gfc_match (" seq_cst )") == MATCH_YES)
7755 : {
7756 : clause = "seq_cst";
7757 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST;
7758 : }
7759 18 : else if (gfc_match (" acq_rel )") == MATCH_YES)
7760 : {
7761 : clause = "acq_rel";
7762 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL;
7763 : }
7764 12 : else if (gfc_match (" acquire )") == MATCH_YES)
7765 : {
7766 : clause = "acquire";
7767 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE;
7768 : }
7769 9 : else if (gfc_match (" relaxed )") == MATCH_YES)
7770 : {
7771 : clause = "relaxed";
7772 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_RELAXED;
7773 : }
7774 5 : else if (gfc_match (" release )") == MATCH_YES)
7775 : {
7776 : clause = "release";
7777 : requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_RELEASE;
7778 : }
7779 : else
7780 : {
7781 2 : gfc_error ("Expected ACQ_REL, ACQUIRE, RELAXED, RELEASE or "
7782 : "SEQ_CST for ATOMIC_DEFAULT_MEM_ORDER clause at %C");
7783 2 : goto error;
7784 : }
7785 : }
7786 : else
7787 1 : goto error;
7788 :
7789 89 : if (!gfc_omp_requires_add_clause (requires_clause, clause, &old_loc, NULL))
7790 3 : goto error;
7791 86 : requires_clauses |= requires_clause;
7792 86 : }
7793 :
7794 75 : if (requires_clauses == 0)
7795 : {
7796 1 : if (!gfc_error_flag_test ())
7797 1 : gfc_error ("Clause expected at %C");
7798 1 : goto error;
7799 : }
7800 : return MATCH_YES;
7801 :
7802 5 : duplicate_clause:
7803 5 : gfc_error ("%qs clause at %L specified more than once", clause, &old_loc);
7804 12 : error:
7805 12 : if (!gfc_error_flag_test ())
7806 1 : gfc_error ("Expected UNIFIED_ADDRESS, UNIFIED_SHARED_MEMORY, SELF_MAPS, "
7807 : "DYNAMIC_ALLOCATORS, REVERSE_OFFLOAD, or "
7808 : "ATOMIC_DEFAULT_MEM_ORDER clause at %L", &old_loc);
7809 : return MATCH_ERROR;
7810 : }
7811 :
7812 :
7813 : match
7814 51 : gfc_match_omp_scan (void)
7815 : {
7816 51 : bool incl;
7817 51 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
7818 51 : gfc_gobble_whitespace ();
7819 51 : if ((incl = (gfc_match ("inclusive") == MATCH_YES))
7820 51 : || gfc_match ("exclusive") == MATCH_YES)
7821 : {
7822 70 : if (gfc_match_omp_variable_list (" (", &c->lists[incl ? OMP_LIST_SCAN_IN
7823 : : OMP_LIST_SCAN_EX],
7824 : false) != MATCH_YES)
7825 : {
7826 0 : gfc_free_omp_clauses (c);
7827 0 : return MATCH_ERROR;
7828 : }
7829 : }
7830 : else
7831 : {
7832 1 : gfc_error ("Expected INCLUSIVE or EXCLUSIVE clause at %C");
7833 1 : gfc_free_omp_clauses (c);
7834 1 : return MATCH_ERROR;
7835 : }
7836 50 : if (gfc_match_omp_eos () != MATCH_YES)
7837 : {
7838 1 : gfc_error ("Unexpected junk after !$OMP SCAN at %C");
7839 1 : gfc_free_omp_clauses (c);
7840 1 : return MATCH_ERROR;
7841 : }
7842 :
7843 49 : new_st.op = EXEC_OMP_SCAN;
7844 49 : new_st.ext.omp_clauses = c;
7845 49 : return MATCH_YES;
7846 : }
7847 :
7848 :
7849 : match
7850 58 : gfc_match_omp_scope (void)
7851 : {
7852 58 : return match_omp (EXEC_OMP_SCOPE, OMP_SCOPE_CLAUSES);
7853 : }
7854 :
7855 :
7856 : match
7857 82 : gfc_match_omp_sections (void)
7858 : {
7859 82 : return match_omp (EXEC_OMP_SECTIONS, OMP_SECTIONS_CLAUSES);
7860 : }
7861 :
7862 :
7863 : match
7864 782 : gfc_match_omp_simd (void)
7865 : {
7866 782 : return match_omp (EXEC_OMP_SIMD, OMP_SIMD_CLAUSES);
7867 : }
7868 :
7869 :
7870 : match
7871 570 : gfc_match_omp_single (void)
7872 : {
7873 570 : return match_omp (EXEC_OMP_SINGLE, OMP_SINGLE_CLAUSES);
7874 : }
7875 :
7876 :
7877 : match
7878 1985 : gfc_match_omp_target (void)
7879 : {
7880 1985 : return match_omp (EXEC_OMP_TARGET, OMP_TARGET_CLAUSES);
7881 : }
7882 :
7883 :
7884 : match
7885 1398 : gfc_match_omp_target_data (void)
7886 : {
7887 1398 : return match_omp (EXEC_OMP_TARGET_DATA, OMP_TARGET_DATA_CLAUSES);
7888 : }
7889 :
7890 :
7891 : match
7892 408 : gfc_match_omp_target_enter_data (void)
7893 : {
7894 408 : return match_omp (EXEC_OMP_TARGET_ENTER_DATA, OMP_TARGET_ENTER_DATA_CLAUSES);
7895 : }
7896 :
7897 :
7898 : match
7899 322 : gfc_match_omp_target_exit_data (void)
7900 : {
7901 322 : return match_omp (EXEC_OMP_TARGET_EXIT_DATA, OMP_TARGET_EXIT_DATA_CLAUSES);
7902 : }
7903 :
7904 :
7905 : match
7906 25 : gfc_match_omp_target_parallel (void)
7907 : {
7908 25 : return match_omp (EXEC_OMP_TARGET_PARALLEL,
7909 25 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES)
7910 25 : & ~(omp_mask (OMP_CLAUSE_COPYIN)));
7911 : }
7912 :
7913 :
7914 : match
7915 81 : gfc_match_omp_target_parallel_do (void)
7916 : {
7917 81 : return match_omp (EXEC_OMP_TARGET_PARALLEL_DO,
7918 81 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES
7919 81 : | OMP_DO_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN)));
7920 : }
7921 :
7922 :
7923 : match
7924 19 : gfc_match_omp_target_parallel_do_simd (void)
7925 : {
7926 19 : return match_omp (EXEC_OMP_TARGET_PARALLEL_DO_SIMD,
7927 19 : (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
7928 19 : | OMP_SIMD_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN)));
7929 : }
7930 :
7931 :
7932 : match
7933 34 : gfc_match_omp_target_simd (void)
7934 : {
7935 34 : return match_omp (EXEC_OMP_TARGET_SIMD,
7936 34 : OMP_TARGET_CLAUSES | OMP_SIMD_CLAUSES);
7937 : }
7938 :
7939 :
7940 : match
7941 72 : gfc_match_omp_target_teams (void)
7942 : {
7943 72 : return match_omp (EXEC_OMP_TARGET_TEAMS,
7944 72 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES);
7945 : }
7946 :
7947 :
7948 : match
7949 19 : gfc_match_omp_target_teams_distribute (void)
7950 : {
7951 19 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE,
7952 19 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
7953 19 : | OMP_DISTRIBUTE_CLAUSES);
7954 : }
7955 :
7956 :
7957 : match
7958 64 : gfc_match_omp_target_teams_distribute_parallel_do (void)
7959 : {
7960 64 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO,
7961 64 : (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
7962 64 : | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
7963 64 : | OMP_DO_CLAUSES)
7964 64 : & ~(omp_mask (OMP_CLAUSE_ORDERED))
7965 64 : & ~(omp_mask (OMP_CLAUSE_LINEAR)));
7966 : }
7967 :
7968 :
7969 : match
7970 35 : gfc_match_omp_target_teams_distribute_parallel_do_simd (void)
7971 : {
7972 35 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
7973 35 : (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
7974 35 : | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
7975 35 : | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
7976 35 : & ~(omp_mask (OMP_CLAUSE_ORDERED)));
7977 : }
7978 :
7979 :
7980 : match
7981 21 : gfc_match_omp_target_teams_distribute_simd (void)
7982 : {
7983 21 : return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD,
7984 21 : OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
7985 21 : | OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
7986 : }
7987 :
7988 :
7989 : match
7990 1704 : gfc_match_omp_target_update (void)
7991 : {
7992 1704 : return match_omp (EXEC_OMP_TARGET_UPDATE, OMP_TARGET_UPDATE_CLAUSES);
7993 : }
7994 :
7995 :
7996 : match
7997 1182 : gfc_match_omp_task (void)
7998 : {
7999 1182 : return match_omp (EXEC_OMP_TASK, OMP_TASK_CLAUSES);
8000 : }
8001 :
8002 :
8003 : match
8004 72 : gfc_match_omp_taskloop (void)
8005 : {
8006 72 : return match_omp (EXEC_OMP_TASKLOOP, OMP_TASKLOOP_CLAUSES);
8007 : }
8008 :
8009 :
8010 : match
8011 40 : gfc_match_omp_taskloop_simd (void)
8012 : {
8013 40 : return match_omp (EXEC_OMP_TASKLOOP_SIMD,
8014 40 : OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES);
8015 : }
8016 :
8017 :
8018 : match
8019 147 : gfc_match_omp_taskwait (void)
8020 : {
8021 147 : if (gfc_match_omp_eos () == MATCH_YES)
8022 : {
8023 133 : new_st.op = EXEC_OMP_TASKWAIT;
8024 133 : new_st.ext.omp_clauses = NULL;
8025 133 : return MATCH_YES;
8026 : }
8027 14 : return match_omp (EXEC_OMP_TASKWAIT,
8028 14 : omp_mask (OMP_CLAUSE_DEPEND) | OMP_CLAUSE_NOWAIT);
8029 : }
8030 :
8031 :
8032 : match
8033 10 : gfc_match_omp_taskyield (void)
8034 : {
8035 10 : if (gfc_match_omp_eos () != MATCH_YES)
8036 : {
8037 0 : gfc_error ("Unexpected junk after TASKYIELD clause at %C");
8038 0 : return MATCH_ERROR;
8039 : }
8040 10 : new_st.op = EXEC_OMP_TASKYIELD;
8041 10 : new_st.ext.omp_clauses = NULL;
8042 10 : return MATCH_YES;
8043 : }
8044 :
8045 :
8046 : match
8047 150 : gfc_match_omp_teams (void)
8048 : {
8049 150 : return match_omp (EXEC_OMP_TEAMS, OMP_TEAMS_CLAUSES);
8050 : }
8051 :
8052 :
8053 : match
8054 22 : gfc_match_omp_teams_distribute (void)
8055 : {
8056 22 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE,
8057 22 : OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES);
8058 : }
8059 :
8060 :
8061 : match
8062 39 : gfc_match_omp_teams_distribute_parallel_do (void)
8063 : {
8064 39 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO,
8065 39 : (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
8066 39 : | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
8067 39 : & ~(omp_mask (OMP_CLAUSE_ORDERED)
8068 39 : | OMP_CLAUSE_LINEAR | OMP_CLAUSE_NOWAIT));
8069 : }
8070 :
8071 :
8072 : match
8073 62 : gfc_match_omp_teams_distribute_parallel_do_simd (void)
8074 : {
8075 62 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
8076 62 : (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
8077 62 : | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
8078 62 : | OMP_SIMD_CLAUSES)
8079 62 : & ~(omp_mask (OMP_CLAUSE_ORDERED) | OMP_CLAUSE_NOWAIT));
8080 : }
8081 :
8082 :
8083 : match
8084 44 : gfc_match_omp_teams_distribute_simd (void)
8085 : {
8086 44 : return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_SIMD,
8087 44 : OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
8088 44 : | OMP_SIMD_CLAUSES);
8089 : }
8090 :
8091 : match
8092 203 : gfc_match_omp_tile (void)
8093 : {
8094 203 : return match_omp (EXEC_OMP_TILE, OMP_TILE_CLAUSES);
8095 : }
8096 :
8097 : match
8098 415 : gfc_match_omp_unroll (void)
8099 : {
8100 415 : return match_omp (EXEC_OMP_UNROLL, OMP_UNROLL_CLAUSES);
8101 : }
8102 :
8103 : match
8104 39 : gfc_match_omp_workshare (void)
8105 : {
8106 39 : return match_omp (EXEC_OMP_WORKSHARE, OMP_WORKSHARE_CLAUSES);
8107 : }
8108 :
8109 :
8110 : match
8111 49 : gfc_match_omp_masked (void)
8112 : {
8113 49 : return match_omp (EXEC_OMP_MASKED, OMP_MASKED_CLAUSES);
8114 : }
8115 :
8116 : match
8117 10 : gfc_match_omp_masked_taskloop (void)
8118 : {
8119 10 : return match_omp (EXEC_OMP_MASKED_TASKLOOP,
8120 10 : OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES);
8121 : }
8122 :
8123 : match
8124 16 : gfc_match_omp_masked_taskloop_simd (void)
8125 : {
8126 16 : return match_omp (EXEC_OMP_MASKED_TASKLOOP_SIMD,
8127 16 : (OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES
8128 16 : | OMP_SIMD_CLAUSES));
8129 : }
8130 :
8131 : match
8132 111 : gfc_match_omp_master (void)
8133 : {
8134 111 : gfc_warning (OPT_Wdeprecated_openmp,
8135 : "%<master%> construct at %C deprecated since OpenMP 5.1, "
8136 : "use %<masked%>");
8137 111 : if (gfc_match_omp_eos () != MATCH_YES)
8138 : {
8139 1 : gfc_error ("Unexpected junk after $OMP MASTER statement at %C");
8140 1 : return MATCH_ERROR;
8141 : }
8142 110 : new_st.op = EXEC_OMP_MASTER;
8143 110 : new_st.ext.omp_clauses = NULL;
8144 110 : return MATCH_YES;
8145 : }
8146 :
8147 : match
8148 16 : gfc_match_omp_master_taskloop (void)
8149 : {
8150 16 : gfc_warning (OPT_Wdeprecated_openmp,
8151 : "%<master%> construct at %C deprecated since OpenMP 5.1, "
8152 : "use %<masked%>");
8153 16 : return match_omp (EXEC_OMP_MASTER_TASKLOOP, OMP_TASKLOOP_CLAUSES);
8154 : }
8155 :
8156 : match
8157 21 : gfc_match_omp_master_taskloop_simd (void)
8158 : {
8159 21 : gfc_warning (OPT_Wdeprecated_openmp,
8160 : "%<master%> construct at %C deprecated since OpenMP 5.1, use "
8161 : "%<masked%>");
8162 21 : return match_omp (EXEC_OMP_MASTER_TASKLOOP_SIMD,
8163 21 : OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES);
8164 : }
8165 :
8166 : match
8167 235 : gfc_match_omp_ordered (void)
8168 : {
8169 235 : return match_omp (EXEC_OMP_ORDERED, OMP_ORDERED_CLAUSES);
8170 : }
8171 :
8172 : match
8173 24 : gfc_match_omp_nothing (void)
8174 : {
8175 24 : if (gfc_match_omp_eos () != MATCH_YES)
8176 : {
8177 1 : gfc_error ("Unexpected junk after $OMP NOTHING statement at %C");
8178 1 : return MATCH_ERROR;
8179 : }
8180 : /* Will use ST_NONE; therefore, no EXEC_OMP_ is needed. */
8181 : return MATCH_YES;
8182 : }
8183 :
8184 : match
8185 317 : gfc_match_omp_ordered_depend (void)
8186 : {
8187 317 : return match_omp (EXEC_OMP_ORDERED, omp_mask (OMP_CLAUSE_DOACROSS));
8188 : }
8189 :
8190 :
8191 : /* omp atomic [clause-list]
8192 : - atomic-clause: read | write | update
8193 : - capture
8194 : - memory-order-clause: seq_cst | acq_rel | release | acquire | relaxed
8195 : - hint(hint-expr)
8196 : - OpenMP 5.1: compare | fail (seq_cst | acquire | relaxed ) | weak
8197 : */
8198 :
8199 : match
8200 2171 : gfc_match_omp_atomic (void)
8201 : {
8202 2171 : gfc_omp_clauses *c;
8203 2171 : locus loc = gfc_current_locus;
8204 :
8205 2171 : if (gfc_match_omp_clauses (&c, OMP_ATOMIC_CLAUSES, true, true) != MATCH_YES)
8206 : return MATCH_ERROR;
8207 :
8208 2153 : if (c->atomic_op == GFC_OMP_ATOMIC_UNSET)
8209 1011 : c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
8210 :
8211 2153 : if (c->capture && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
8212 3 : gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
8213 : "READ or WRITE", &loc, "CAPTURE");
8214 2153 : if (c->compare && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
8215 3 : gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
8216 : "READ or WRITE", &loc, "COMPARE");
8217 2153 : if (c->fail != OMP_MEMORDER_UNSET && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
8218 2 : gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
8219 : "READ or WRITE", &loc, "FAIL");
8220 2153 : if (c->weak && !c->compare)
8221 : {
8222 5 : gfc_error ("!$OMP ATOMIC at %L with %s clause requires %s clause", &loc,
8223 : "WEAK", "COMPARE");
8224 5 : c->weak = false;
8225 : }
8226 :
8227 2153 : if (c->memorder == OMP_MEMORDER_UNSET)
8228 : {
8229 1969 : gfc_namespace *prog_unit = gfc_current_ns;
8230 2525 : while (prog_unit->parent)
8231 : prog_unit = prog_unit->parent;
8232 1969 : switch (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
8233 : {
8234 1936 : case 0:
8235 1936 : case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED:
8236 1936 : c->memorder = OMP_MEMORDER_RELAXED;
8237 1936 : break;
8238 7 : case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST:
8239 7 : c->memorder = OMP_MEMORDER_SEQ_CST;
8240 7 : break;
8241 16 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL:
8242 16 : if (c->capture)
8243 5 : c->memorder = OMP_MEMORDER_ACQ_REL;
8244 11 : else if (c->atomic_op == GFC_OMP_ATOMIC_READ)
8245 3 : c->memorder = OMP_MEMORDER_ACQUIRE;
8246 : else
8247 8 : c->memorder = OMP_MEMORDER_RELEASE;
8248 : break;
8249 5 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE:
8250 5 : if (c->atomic_op == GFC_OMP_ATOMIC_WRITE)
8251 : {
8252 1 : gfc_error ("!$OMP ATOMIC WRITE at %L incompatible with "
8253 : "ACQUIRES clause implicitly provided by a "
8254 : "REQUIRES directive", &loc);
8255 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
8256 : }
8257 : else
8258 4 : c->memorder = OMP_MEMORDER_ACQUIRE;
8259 : break;
8260 5 : case OMP_REQ_ATOMIC_MEM_ORDER_RELEASE:
8261 5 : if (c->atomic_op == GFC_OMP_ATOMIC_READ)
8262 : {
8263 1 : gfc_error ("!$OMP ATOMIC READ at %L incompatible with "
8264 : "RELEASE clause implicitly provided by a "
8265 : "REQUIRES directive", &loc);
8266 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
8267 : }
8268 : else
8269 4 : c->memorder = OMP_MEMORDER_RELEASE;
8270 : break;
8271 0 : default:
8272 0 : gcc_unreachable ();
8273 : }
8274 : }
8275 : else
8276 184 : switch (c->atomic_op)
8277 : {
8278 29 : case GFC_OMP_ATOMIC_READ:
8279 29 : if (c->memorder == OMP_MEMORDER_RELEASE)
8280 : {
8281 1 : gfc_error ("!$OMP ATOMIC READ at %L incompatible with "
8282 : "RELEASE clause", &loc);
8283 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
8284 : }
8285 28 : else if (c->memorder == OMP_MEMORDER_ACQ_REL)
8286 1 : c->memorder = OMP_MEMORDER_ACQUIRE;
8287 : break;
8288 35 : case GFC_OMP_ATOMIC_WRITE:
8289 35 : if (c->memorder == OMP_MEMORDER_ACQUIRE)
8290 : {
8291 1 : gfc_error ("!$OMP ATOMIC WRITE at %L incompatible with "
8292 : "ACQUIRE clause", &loc);
8293 1 : c->memorder = OMP_MEMORDER_SEQ_CST;
8294 : }
8295 34 : else if (c->memorder == OMP_MEMORDER_ACQ_REL)
8296 1 : c->memorder = OMP_MEMORDER_RELEASE;
8297 : break;
8298 : default:
8299 : break;
8300 : }
8301 2153 : gfc_error_check ();
8302 2153 : new_st.ext.omp_clauses = c;
8303 2153 : new_st.op = EXEC_OMP_ATOMIC;
8304 2153 : return MATCH_YES;
8305 : }
8306 :
8307 :
8308 : /* acc atomic [ read | write | update | capture] */
8309 :
8310 : match
8311 552 : gfc_match_oacc_atomic (void)
8312 : {
8313 552 : gfc_omp_clauses *c = gfc_get_omp_clauses ();
8314 552 : c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
8315 552 : c->memorder = OMP_MEMORDER_RELAXED;
8316 552 : gfc_gobble_whitespace ();
8317 552 : if (gfc_match ("update") == MATCH_YES)
8318 : ;
8319 373 : else if (gfc_match ("read") == MATCH_YES)
8320 17 : c->atomic_op = GFC_OMP_ATOMIC_READ;
8321 356 : else if (gfc_match ("write") == MATCH_YES)
8322 13 : c->atomic_op = GFC_OMP_ATOMIC_WRITE;
8323 343 : else if (gfc_match ("capture") == MATCH_YES)
8324 319 : c->capture = true;
8325 552 : gfc_gobble_whitespace ();
8326 552 : if (gfc_match_omp_eos () != MATCH_YES)
8327 : {
8328 9 : gfc_error ("Unexpected junk after !$ACC ATOMIC statement at %C");
8329 9 : gfc_free_omp_clauses (c);
8330 9 : return MATCH_ERROR;
8331 : }
8332 543 : new_st.ext.omp_clauses = c;
8333 543 : new_st.op = EXEC_OACC_ATOMIC;
8334 543 : return MATCH_YES;
8335 : }
8336 :
8337 :
8338 : match
8339 614 : gfc_match_omp_barrier (void)
8340 : {
8341 614 : if (gfc_match_omp_eos () != MATCH_YES)
8342 : {
8343 0 : gfc_error ("Unexpected junk after $OMP BARRIER statement at %C");
8344 0 : return MATCH_ERROR;
8345 : }
8346 614 : new_st.op = EXEC_OMP_BARRIER;
8347 614 : new_st.ext.omp_clauses = NULL;
8348 614 : return MATCH_YES;
8349 : }
8350 :
8351 :
8352 : match
8353 188 : gfc_match_omp_taskgroup (void)
8354 : {
8355 188 : return match_omp (EXEC_OMP_TASKGROUP, OMP_TASKGROUP_CLAUSES);
8356 : }
8357 :
8358 :
8359 : static enum gfc_omp_cancel_kind
8360 494 : gfc_match_omp_cancel_kind (void)
8361 : {
8362 494 : if (gfc_match_space () != MATCH_YES)
8363 : return OMP_CANCEL_UNKNOWN;
8364 492 : if (gfc_match ("parallel") == MATCH_YES)
8365 : return OMP_CANCEL_PARALLEL;
8366 352 : if (gfc_match ("sections") == MATCH_YES)
8367 : return OMP_CANCEL_SECTIONS;
8368 253 : if (gfc_match ("do") == MATCH_YES)
8369 : return OMP_CANCEL_DO;
8370 123 : if (gfc_match ("taskgroup") == MATCH_YES)
8371 : return OMP_CANCEL_TASKGROUP;
8372 : return OMP_CANCEL_UNKNOWN;
8373 : }
8374 :
8375 :
8376 : match
8377 321 : gfc_match_omp_cancel (void)
8378 : {
8379 321 : gfc_omp_clauses *c;
8380 321 : enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
8381 321 : if (kind == OMP_CANCEL_UNKNOWN)
8382 : return MATCH_ERROR;
8383 319 : if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_IF), false) != MATCH_YES)
8384 : return MATCH_ERROR;
8385 316 : c->cancel = kind;
8386 316 : new_st.op = EXEC_OMP_CANCEL;
8387 316 : new_st.ext.omp_clauses = c;
8388 316 : return MATCH_YES;
8389 : }
8390 :
8391 :
8392 : match
8393 173 : gfc_match_omp_cancellation_point (void)
8394 : {
8395 173 : gfc_omp_clauses *c;
8396 173 : enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
8397 173 : if (kind == OMP_CANCEL_UNKNOWN)
8398 : {
8399 2 : gfc_error ("Expected construct-type PARALLEL, SECTIONS, DO or TASKGROUP "
8400 : "in $OMP CANCELLATION POINT statement at %C");
8401 2 : return MATCH_ERROR;
8402 : }
8403 171 : if (gfc_match_omp_eos () != MATCH_YES)
8404 : {
8405 0 : gfc_error ("Unexpected junk after $OMP CANCELLATION POINT statement "
8406 : "at %C");
8407 0 : return MATCH_ERROR;
8408 : }
8409 171 : c = gfc_get_omp_clauses ();
8410 171 : c->cancel = kind;
8411 171 : new_st.op = EXEC_OMP_CANCELLATION_POINT;
8412 171 : new_st.ext.omp_clauses = c;
8413 171 : return MATCH_YES;
8414 : }
8415 :
8416 :
8417 : match
8418 2495 : gfc_match_omp_end_nowait (void)
8419 : {
8420 2495 : bool nowait = false;
8421 2495 : if (gfc_match ("% nowait") == MATCH_YES)
8422 258 : nowait = true;
8423 2495 : if (gfc_match_omp_eos () != MATCH_YES)
8424 : {
8425 4 : if (nowait)
8426 3 : gfc_error ("Unexpected junk after NOWAIT clause at %C");
8427 : else
8428 1 : gfc_error ("Unexpected junk at %C");
8429 4 : return MATCH_ERROR;
8430 : }
8431 2491 : new_st.op = EXEC_OMP_END_NOWAIT;
8432 2491 : new_st.ext.omp_bool = nowait;
8433 2491 : return MATCH_YES;
8434 : }
8435 :
8436 :
8437 : match
8438 566 : gfc_match_omp_end_single (void)
8439 : {
8440 566 : gfc_omp_clauses *c;
8441 566 : if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_COPYPRIVATE)
8442 : | OMP_CLAUSE_NOWAIT) != MATCH_YES)
8443 : return MATCH_ERROR;
8444 566 : new_st.op = EXEC_OMP_END_SINGLE;
8445 566 : new_st.ext.omp_clauses = c;
8446 566 : return MATCH_YES;
8447 : }
8448 :
8449 :
8450 : static bool
8451 37071 : oacc_is_loop (gfc_code *code)
8452 : {
8453 37071 : return code->op == EXEC_OACC_PARALLEL_LOOP
8454 : || code->op == EXEC_OACC_KERNELS_LOOP
8455 20016 : || code->op == EXEC_OACC_SERIAL_LOOP
8456 13457 : || code->op == EXEC_OACC_LOOP;
8457 : }
8458 :
8459 : static void
8460 5725 : resolve_scalar_int_expr (gfc_expr *expr, const char *clause)
8461 : {
8462 5725 : if (!gfc_resolve_expr (expr)
8463 5725 : || expr->ts.type != BT_INTEGER
8464 11379 : || expr->rank != 0)
8465 89 : gfc_error ("%s clause at %L requires a scalar INTEGER expression",
8466 : clause, &expr->where);
8467 5725 : }
8468 :
8469 : static void
8470 3940 : resolve_positive_int_expr (gfc_expr *expr, const char *clause)
8471 : {
8472 3940 : resolve_scalar_int_expr (expr, clause);
8473 3940 : if (expr->expr_type == EXPR_CONSTANT
8474 3519 : && expr->ts.type == BT_INTEGER
8475 3486 : && mpz_sgn (expr->value.integer) <= 0)
8476 54 : gfc_warning ((flag_openmp || flag_openmp_simd) ? OPT_Wopenmp : 0,
8477 : "INTEGER expression of %s clause at %L must be positive",
8478 : clause, &expr->where);
8479 3940 : }
8480 :
8481 : static void
8482 86 : resolve_nonnegative_int_expr (gfc_expr *expr, const char *clause)
8483 : {
8484 86 : resolve_scalar_int_expr (expr, clause);
8485 86 : if (expr->expr_type == EXPR_CONSTANT
8486 13 : && expr->ts.type == BT_INTEGER
8487 11 : && mpz_sgn (expr->value.integer) < 0)
8488 6 : gfc_warning ((flag_openmp || flag_openmp_simd) ? OPT_Wopenmp : 0,
8489 : "INTEGER expression of %s clause at %L must be non-negative",
8490 : clause, &expr->where);
8491 86 : }
8492 :
8493 : /* Emits error when symbol is pointer, cray pointer or cray pointee
8494 : of derived of polymorphic type. */
8495 :
8496 : static void
8497 98 : check_symbol_not_pointer (gfc_symbol *sym, locus loc, const char *name)
8498 : {
8499 98 : if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointer)
8500 0 : gfc_error ("Cray pointer object %qs of derived type in %s clause at %L",
8501 : sym->name, name, &loc);
8502 98 : if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointee)
8503 0 : gfc_error ("Cray pointee object %qs of derived type in %s clause at %L",
8504 : sym->name, name, &loc);
8505 :
8506 98 : if ((sym->ts.type == BT_ASSUMED && sym->attr.pointer)
8507 98 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
8508 0 : && CLASS_DATA (sym)->attr.pointer))
8509 0 : gfc_error ("POINTER object %qs of polymorphic type in %s clause at %L",
8510 : sym->name, name, &loc);
8511 98 : if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointer)
8512 98 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
8513 0 : && CLASS_DATA (sym)->attr.cray_pointer))
8514 0 : gfc_error ("Cray pointer object %qs of polymorphic type in %s clause at %L",
8515 : sym->name, name, &loc);
8516 98 : if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointee)
8517 98 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
8518 0 : && CLASS_DATA (sym)->attr.cray_pointee))
8519 0 : gfc_error ("Cray pointee object %qs of polymorphic type in %s clause at %L",
8520 : sym->name, name, &loc);
8521 98 : }
8522 :
8523 : /* Emits error when symbol represents assumed size/rank array. */
8524 :
8525 : static void
8526 14844 : check_array_not_assumed (gfc_symbol *sym, locus loc, const char *name)
8527 : {
8528 14844 : if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
8529 13 : gfc_error ("Assumed size array %qs in %s clause at %L",
8530 : sym->name, name, &loc);
8531 14844 : if (sym->as && sym->as->type == AS_ASSUMED_RANK)
8532 11 : gfc_error ("Assumed rank array %qs in %s clause at %L",
8533 : sym->name, name, &loc);
8534 14844 : }
8535 :
8536 : static void
8537 5850 : resolve_oacc_data_clauses (gfc_symbol *sym, locus loc, const char *name)
8538 : {
8539 0 : check_array_not_assumed (sym, loc, name);
8540 0 : }
8541 :
8542 : static void
8543 65 : resolve_oacc_deviceptr_clause (gfc_symbol *sym, locus loc, const char *name)
8544 : {
8545 65 : if (sym->attr.pointer
8546 64 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
8547 0 : && CLASS_DATA (sym)->attr.class_pointer))
8548 1 : gfc_error ("POINTER object %qs in %s clause at %L",
8549 : sym->name, name, &loc);
8550 65 : if (sym->attr.cray_pointer
8551 63 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
8552 0 : && CLASS_DATA (sym)->attr.cray_pointer))
8553 2 : gfc_error ("Cray pointer object %qs in %s clause at %L",
8554 : sym->name, name, &loc);
8555 65 : if (sym->attr.cray_pointee
8556 63 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
8557 0 : && CLASS_DATA (sym)->attr.cray_pointee))
8558 2 : gfc_error ("Cray pointee object %qs in %s clause at %L",
8559 : sym->name, name, &loc);
8560 65 : if (sym->attr.allocatable
8561 64 : || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
8562 0 : && CLASS_DATA (sym)->attr.allocatable))
8563 1 : gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
8564 : sym->name, name, &loc);
8565 65 : if (sym->attr.value)
8566 1 : gfc_error ("VALUE object %qs in %s clause at %L",
8567 : sym->name, name, &loc);
8568 65 : check_array_not_assumed (sym, loc, name);
8569 65 : }
8570 :
8571 :
8572 : struct resolve_omp_udr_callback_data
8573 : {
8574 : gfc_symbol *sym1, *sym2;
8575 : };
8576 :
8577 :
8578 : static int
8579 1413 : resolve_omp_udr_callback (gfc_expr **e, int *, void *data)
8580 : {
8581 1413 : struct resolve_omp_udr_callback_data *rcd
8582 : = (struct resolve_omp_udr_callback_data *) data;
8583 1413 : if ((*e)->expr_type == EXPR_VARIABLE
8584 801 : && ((*e)->symtree->n.sym == rcd->sym1
8585 255 : || (*e)->symtree->n.sym == rcd->sym2))
8586 : {
8587 801 : gfc_ref *ref = gfc_get_ref ();
8588 801 : ref->type = REF_ARRAY;
8589 801 : ref->u.ar.where = (*e)->where;
8590 801 : ref->u.ar.as = (*e)->symtree->n.sym->as;
8591 801 : ref->u.ar.type = AR_FULL;
8592 801 : ref->u.ar.dimen = 0;
8593 801 : ref->next = (*e)->ref;
8594 801 : (*e)->ref = ref;
8595 : }
8596 1413 : return 0;
8597 : }
8598 :
8599 :
8600 : static int
8601 2990 : resolve_omp_udr_callback2 (gfc_expr **e, int *, void *)
8602 : {
8603 2990 : if ((*e)->expr_type == EXPR_FUNCTION
8604 360 : && (*e)->value.function.isym == NULL)
8605 : {
8606 174 : gfc_symbol *sym = (*e)->symtree->n.sym;
8607 174 : if (!sym->attr.intrinsic
8608 174 : && sym->attr.if_source == IFSRC_UNKNOWN)
8609 4 : gfc_error ("Implicitly declared function %s used in "
8610 : "!$OMP DECLARE REDUCTION at %L", sym->name, &(*e)->where);
8611 : }
8612 2990 : return 0;
8613 : }
8614 :
8615 :
8616 : static gfc_code *
8617 797 : resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns,
8618 : gfc_symbol *sym1, gfc_symbol *sym2)
8619 : {
8620 797 : gfc_code *copy;
8621 797 : gfc_symbol sym1_copy, sym2_copy;
8622 :
8623 797 : if (ns->code->op == EXEC_ASSIGN)
8624 : {
8625 625 : copy = gfc_get_code (EXEC_ASSIGN);
8626 625 : copy->expr1 = gfc_copy_expr (ns->code->expr1);
8627 625 : copy->expr2 = gfc_copy_expr (ns->code->expr2);
8628 : }
8629 : else
8630 : {
8631 172 : copy = gfc_get_code (EXEC_CALL);
8632 172 : copy->symtree = ns->code->symtree;
8633 172 : copy->ext.actual = gfc_copy_actual_arglist (ns->code->ext.actual);
8634 : }
8635 797 : copy->loc = ns->code->loc;
8636 797 : sym1_copy = *sym1;
8637 797 : sym2_copy = *sym2;
8638 797 : *sym1 = *n->sym;
8639 797 : *sym2 = *n->sym;
8640 797 : sym1->name = sym1_copy.name;
8641 797 : sym2->name = sym2_copy.name;
8642 797 : ns->proc_name = ns->parent->proc_name;
8643 797 : if (n->sym->attr.dimension)
8644 : {
8645 348 : struct resolve_omp_udr_callback_data rcd;
8646 348 : rcd.sym1 = sym1;
8647 348 : rcd.sym2 = sym2;
8648 348 : gfc_code_walker (©, gfc_dummy_code_callback,
8649 : resolve_omp_udr_callback, &rcd);
8650 : }
8651 797 : gfc_resolve_code (copy, gfc_current_ns);
8652 797 : if (copy->op == EXEC_CALL && copy->resolved_isym == NULL)
8653 : {
8654 172 : gfc_symbol *sym = copy->resolved_sym;
8655 172 : if (sym
8656 170 : && !sym->attr.intrinsic
8657 170 : && sym->attr.if_source == IFSRC_UNKNOWN)
8658 4 : gfc_error ("Implicitly declared subroutine %s used in "
8659 : "!$OMP DECLARE REDUCTION at %L", sym->name,
8660 : ©->loc);
8661 : }
8662 797 : gfc_code_walker (©, gfc_dummy_code_callback,
8663 : resolve_omp_udr_callback2, NULL);
8664 797 : *sym1 = sym1_copy;
8665 797 : *sym2 = sym2_copy;
8666 797 : return copy;
8667 : }
8668 :
8669 : /* Assume that a constant expression in the range 1 (omp_default_mem_alloc)
8670 : to GOMP_OMP_PREDEF_ALLOC_MAX, or GOMP_OMPX_PREDEF_ALLOC_MIN to
8671 : GOMP_OMPX_PREDEF_ALLOC_MAX is fine. The original symbol name is already
8672 : lost during matching via gfc_match_expr. */
8673 : static bool
8674 130 : is_predefined_allocator (gfc_expr *expr)
8675 : {
8676 130 : return (gfc_resolve_expr (expr)
8677 129 : && expr->rank == 0
8678 124 : && expr->ts.type == BT_INTEGER
8679 119 : && expr->ts.kind == gfc_c_intptr_kind
8680 114 : && expr->expr_type == EXPR_CONSTANT
8681 239 : && ((mpz_sgn (expr->value.integer) > 0
8682 107 : && mpz_cmp_si (expr->value.integer,
8683 : GOMP_OMP_PREDEF_ALLOC_MAX) <= 0)
8684 4 : || (mpz_cmp_si (expr->value.integer,
8685 : GOMP_OMPX_PREDEF_ALLOC_MIN) >= 0
8686 1 : && mpz_cmp_si (expr->value.integer,
8687 130 : GOMP_OMPX_PREDEF_ALLOC_MAX) <= 0)));
8688 : }
8689 :
8690 : /* Resolve declarative ALLOCATE statement. Note: Common block vars only appear
8691 : as /block/ not individual, which is ensured during parsing. */
8692 :
8693 : void
8694 62 : gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list)
8695 : {
8696 278 : for (gfc_omp_namelist *n = list; n; n = n->next)
8697 : {
8698 216 : if (n->sym->attr.result || n->sym->result == n->sym)
8699 : {
8700 1 : gfc_error ("Unexpected function-result variable %qs at %L in "
8701 : "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
8702 31 : continue;
8703 : }
8704 215 : if (ns->omp_allocate->sym->attr.proc_pointer)
8705 : {
8706 0 : gfc_error ("Procedure pointer %qs not supported with !$OMP "
8707 : "ALLOCATE at %L", n->sym->name, &n->where);
8708 0 : continue;
8709 : }
8710 215 : if (n->sym->attr.flavor != FL_VARIABLE)
8711 : {
8712 3 : gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE "
8713 : "directive must be a variable", n->sym->name,
8714 : &n->where);
8715 3 : continue;
8716 : }
8717 212 : if (ns != n->sym->ns || n->sym->attr.use_assoc || n->sym->attr.imported)
8718 : {
8719 8 : gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE shall be"
8720 : " in the same scope as the variable declaration",
8721 : n->sym->name, &n->where);
8722 8 : continue;
8723 : }
8724 204 : if (n->sym->attr.dummy)
8725 : {
8726 3 : gfc_error ("Unexpected dummy argument %qs as argument at %L to "
8727 : "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
8728 3 : continue;
8729 : }
8730 201 : if (n->sym->attr.codimension)
8731 : {
8732 0 : gfc_error ("Unexpected coarray argument %qs as argument at %L to "
8733 : "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
8734 0 : continue;
8735 : }
8736 201 : if (n->sym->attr.omp_allocate)
8737 : {
8738 5 : if (n->sym->attr.in_common)
8739 : {
8740 1 : gfc_error ("Duplicated common block %</%s/%> in !$OMP ALLOCATE "
8741 1 : "at %L", n->sym->common_head->name, &n->where);
8742 3 : while (n->next && n->next->sym
8743 3 : && n->sym->common_head == n->next->sym->common_head)
8744 : n = n->next;
8745 : }
8746 : else
8747 4 : gfc_error ("Duplicated variable %qs in !$OMP ALLOCATE at %L",
8748 : n->sym->name, &n->where);
8749 5 : continue;
8750 : }
8751 : /* For 'equivalence(a,b)', a 'union_type {<type> a,b} equiv.0' is created
8752 : with a value expression for 'a' as 'equiv.0.a' (likewise for b); while
8753 : this can be handled, EQUIVALENCE is marked as obsolescent since Fortran
8754 : 2018 and also not widely used. However, it could be supported,
8755 : if needed. */
8756 196 : if (n->sym->attr.in_equivalence)
8757 : {
8758 2 : gfc_error ("Sorry, EQUIVALENCE object %qs not supported with !$OMP "
8759 : "ALLOCATE at %L", n->sym->name, &n->where);
8760 2 : continue;
8761 : }
8762 : /* Similar for Cray pointer/pointee - they could be implemented but as
8763 : common vendor extension but nowadays rarely used and requiring
8764 : -fcray-pointer, there is no need to support them. */
8765 194 : if (n->sym->attr.cray_pointer || n->sym->attr.cray_pointee)
8766 : {
8767 2 : gfc_error ("Sorry, Cray pointers and pointees such as %qs are not "
8768 : "supported with !$OMP ALLOCATE at %L",
8769 : n->sym->name, &n->where);
8770 2 : continue;
8771 : }
8772 192 : n->sym->attr.omp_allocate = 1;
8773 192 : if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok
8774 0 : && CLASS_DATA (n->sym)->attr.allocatable)
8775 192 : || (n->sym->ts.type != BT_CLASS && n->sym->attr.allocatable))
8776 1 : gfc_error ("Unexpected allocatable variable %qs at %L in declarative "
8777 : "!$OMP ALLOCATE directive", n->sym->name, &n->where);
8778 191 : else if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok
8779 0 : && CLASS_DATA (n->sym)->attr.class_pointer)
8780 191 : || (n->sym->ts.type != BT_CLASS && n->sym->attr.pointer))
8781 1 : gfc_error ("Unexpected pointer variable %qs at %L in declarative "
8782 : "!$OMP ALLOCATE directive", n->sym->name, &n->where);
8783 192 : HOST_WIDE_INT alignment = 0;
8784 198 : if (n->u.align
8785 192 : && (!gfc_resolve_expr (n->u.align)
8786 27 : || n->u.align->ts.type != BT_INTEGER
8787 26 : || n->u.align->rank != 0
8788 24 : || n->u.align->expr_type != EXPR_CONSTANT
8789 23 : || gfc_extract_hwi (n->u.align, &alignment)
8790 23 : || !pow2p_hwi (alignment)))
8791 : {
8792 6 : gfc_error ("ALIGN requires a scalar positive constant integer "
8793 : "alignment expression at %L that is a power of two",
8794 6 : &n->u.align->where);
8795 6 : while (n->sym->attr.in_common && n->next && n->next->sym
8796 6 : && n->sym->common_head == n->next->sym->common_head)
8797 : n = n->next;
8798 6 : continue;
8799 : }
8800 186 : if (n->sym->attr.in_common || n->sym->attr.save || n->sym->ns->save_all
8801 63 : || (n->sym->ns->proc_name
8802 63 : && (n->sym->ns->proc_name->attr.flavor == FL_PROGRAM
8803 : || n->sym->ns->proc_name->attr.flavor == FL_MODULE
8804 : || n->sym->ns->proc_name->attr.flavor == FL_BLOCK_DATA)))
8805 : {
8806 131 : bool com = n->sym->attr.in_common;
8807 131 : if (!n->u2.allocator)
8808 1 : gfc_error ("An ALLOCATOR clause is required as the list item "
8809 : "%<%s%s%s%> at %L has the SAVE attribute", com ? "/" : "",
8810 0 : com ? n->sym->common_head->name : n->sym->name,
8811 : com ? "/" : "", &n->where);
8812 130 : else if (!is_predefined_allocator (n->u2.allocator))
8813 24 : gfc_error ("Predefined allocator required in ALLOCATOR clause at %L"
8814 : " as the list item %<%s%s%s%> at %L has the SAVE attribute",
8815 24 : &n->u2.allocator->where, com ? "/" : "",
8816 24 : com ? n->sym->common_head->name : n->sym->name,
8817 : com ? "/" : "", &n->where);
8818 : /* Only local static variables might use omp_cgroup_mem_alloc (6),
8819 : omp_pteam_mem_alloc (7), or omp_thread_mem_alloc (8). */
8820 106 : else if ((!ns->proc_name
8821 98 : || ns->proc_name->attr.flavor == FL_PROGRAM
8822 : || ns->proc_name->attr.flavor == FL_BLOCK_DATA
8823 : || ns->proc_name->attr.flavor == FL_MODULE
8824 54 : || com)
8825 74 : && mpz_cmp_si (n->u2.allocator->value.integer,
8826 : 6 /* cgroup */) >= 0
8827 24 : && mpz_cmp_si (n->u2.allocator->value.integer,
8828 : 8 /* thread */) <= 0)
8829 : {
8830 24 : const char *alloc_name[] = {"omp_cgroup_mem_alloc",
8831 : "omp_pteam_mem_alloc",
8832 : "omp_thread_mem_alloc" };
8833 24 : gfc_error ("Predefined allocator %qs in ALLOCATOR clause at %L, "
8834 : "used for list item %<%s%s%s%> at %L, may only be used"
8835 : " for local static variables",
8836 24 : alloc_name[mpz_get_ui (n->u2.allocator->value.integer)
8837 24 : - 6 /* cgroup */], &n->u2.allocator->where,
8838 : com ? "/" : "",
8839 24 : com ? n->sym->common_head->name : n->sym->name,
8840 : com ? "/" : "", &n->where);
8841 : }
8842 67 : while (n->sym->attr.in_common && n->next && n->next->sym
8843 186 : && n->sym->common_head == n->next->sym->common_head)
8844 : n = n->next;
8845 : }
8846 55 : else if (n->u2.allocator
8847 55 : && (!gfc_resolve_expr (n->u2.allocator)
8848 20 : || n->u2.allocator->ts.type != BT_INTEGER
8849 19 : || n->u2.allocator->rank != 0
8850 18 : || n->u2.allocator->ts.kind != gfc_c_intptr_kind))
8851 3 : gfc_error ("Expected integer expression of the "
8852 : "%<omp_allocator_handle_kind%> kind at %L",
8853 3 : &n->u2.allocator->where);
8854 : }
8855 62 : }
8856 :
8857 : /* Resolve ASSUME's and ASSUMES' assumption clauses. Note that absent/contains
8858 : is handled during parse time in omp_verify_merge_absent_contains. */
8859 :
8860 : void
8861 29 : gfc_resolve_omp_assumptions (gfc_omp_assumptions *assume)
8862 : {
8863 46 : for (gfc_expr_list *el = assume->holds; el; el = el->next)
8864 17 : if (!gfc_resolve_expr (el->expr)
8865 17 : || el->expr->ts.type != BT_LOGICAL
8866 32 : || el->expr->rank != 0)
8867 4 : gfc_error ("HOLDS expression at %L must be a scalar logical expression",
8868 4 : &el->expr->where);
8869 29 : }
8870 :
8871 :
8872 : /* OpenMP directive resolving routines. */
8873 :
8874 : static void
8875 32198 : resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
8876 : gfc_namespace *ns, bool openacc = false)
8877 : {
8878 32198 : gfc_omp_namelist *n, *last;
8879 32198 : gfc_expr_list *el;
8880 32198 : enum gfc_omp_list_type list;
8881 32198 : int ifc;
8882 32198 : bool if_without_mod = false;
8883 32198 : gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
8884 32198 : static const char *clause_names[]
8885 : = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
8886 : "COPYIN", "UNIFORM", "AFFINITY", "ALIGNED", "LINEAR", "DEPEND", "MAP",
8887 : "TO", "FROM", "INCLUSIVE", "EXCLUSIVE",
8888 : "REDUCTION", "REDUCTION" /*inscan*/, "REDUCTION" /*task*/,
8889 : "IN_REDUCTION", "TASK_REDUCTION",
8890 : "DEVICE_RESIDENT", "LINK", "LOCAL", "USE_DEVICE",
8891 : "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR",
8892 : "NONTEMPORAL", "ALLOCATE", "HAS_DEVICE_ADDR", "ENTER",
8893 : "USES_ALLOCATORS", "INIT", "USE", "DESTROY", "INTEROP", "ADJUST_ARGS" };
8894 32198 : STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM);
8895 :
8896 32198 : if (omp_clauses == NULL)
8897 : return;
8898 :
8899 32198 : if (ns == NULL)
8900 31777 : ns = gfc_current_ns;
8901 :
8902 32198 : if (omp_clauses->orderedc && omp_clauses->orderedc < omp_clauses->collapse)
8903 0 : gfc_error ("ORDERED clause parameter is less than COLLAPSE at %L",
8904 : &code->loc);
8905 32198 : if (omp_clauses->order_concurrent && omp_clauses->ordered)
8906 4 : gfc_error ("ORDER clause must not be used together with ORDERED at %L",
8907 : &code->loc);
8908 32198 : if (omp_clauses->if_expr)
8909 : {
8910 1184 : gfc_expr *expr = omp_clauses->if_expr;
8911 1184 : if (!gfc_resolve_expr (expr)
8912 1184 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
8913 16 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8914 : &expr->where);
8915 : if_without_mod = true;
8916 : }
8917 354178 : for (ifc = 0; ifc < OMP_IF_LAST; ifc++)
8918 321980 : if (omp_clauses->if_exprs[ifc])
8919 : {
8920 137 : gfc_expr *expr = omp_clauses->if_exprs[ifc];
8921 137 : bool ok = true;
8922 137 : if (!gfc_resolve_expr (expr)
8923 137 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
8924 0 : gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
8925 : &expr->where);
8926 137 : else if (if_without_mod)
8927 : {
8928 1 : gfc_error ("IF clause without modifier at %L used together with "
8929 : "IF clauses with modifiers",
8930 1 : &omp_clauses->if_expr->where);
8931 1 : if_without_mod = false;
8932 : }
8933 : else
8934 136 : switch (code->op)
8935 : {
8936 13 : case EXEC_OMP_CANCEL:
8937 13 : ok = ifc == OMP_IF_CANCEL;
8938 13 : break;
8939 :
8940 16 : case EXEC_OMP_PARALLEL:
8941 16 : case EXEC_OMP_PARALLEL_DO:
8942 16 : case EXEC_OMP_PARALLEL_LOOP:
8943 16 : case EXEC_OMP_PARALLEL_MASKED:
8944 16 : case EXEC_OMP_PARALLEL_MASTER:
8945 16 : case EXEC_OMP_PARALLEL_SECTIONS:
8946 16 : case EXEC_OMP_PARALLEL_WORKSHARE:
8947 16 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
8948 16 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
8949 16 : ok = ifc == OMP_IF_PARALLEL;
8950 16 : break;
8951 :
8952 28 : case EXEC_OMP_PARALLEL_DO_SIMD:
8953 28 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
8954 28 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
8955 28 : ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_SIMD;
8956 28 : break;
8957 :
8958 8 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
8959 8 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
8960 8 : ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_TASKLOOP;
8961 8 : break;
8962 :
8963 12 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
8964 12 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
8965 12 : ok = (ifc == OMP_IF_PARALLEL
8966 12 : || ifc == OMP_IF_TASKLOOP
8967 : || ifc == OMP_IF_SIMD);
8968 : break;
8969 :
8970 0 : case EXEC_OMP_SIMD:
8971 0 : case EXEC_OMP_DO_SIMD:
8972 0 : case EXEC_OMP_DISTRIBUTE_SIMD:
8973 0 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
8974 0 : ok = ifc == OMP_IF_SIMD;
8975 0 : break;
8976 :
8977 1 : case EXEC_OMP_TASK:
8978 1 : ok = ifc == OMP_IF_TASK;
8979 1 : break;
8980 :
8981 5 : case EXEC_OMP_TASKLOOP:
8982 5 : case EXEC_OMP_MASKED_TASKLOOP:
8983 5 : case EXEC_OMP_MASTER_TASKLOOP:
8984 5 : ok = ifc == OMP_IF_TASKLOOP;
8985 5 : break;
8986 :
8987 20 : case EXEC_OMP_TASKLOOP_SIMD:
8988 20 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
8989 20 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
8990 20 : ok = ifc == OMP_IF_TASKLOOP || ifc == OMP_IF_SIMD;
8991 20 : break;
8992 :
8993 5 : case EXEC_OMP_TARGET:
8994 5 : case EXEC_OMP_TARGET_TEAMS:
8995 5 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
8996 5 : case EXEC_OMP_TARGET_TEAMS_LOOP:
8997 5 : ok = ifc == OMP_IF_TARGET;
8998 5 : break;
8999 :
9000 4 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
9001 4 : case EXEC_OMP_TARGET_SIMD:
9002 4 : ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_SIMD;
9003 4 : break;
9004 :
9005 1 : case EXEC_OMP_TARGET_DATA:
9006 1 : ok = ifc == OMP_IF_TARGET_DATA;
9007 1 : break;
9008 :
9009 1 : case EXEC_OMP_TARGET_UPDATE:
9010 1 : ok = ifc == OMP_IF_TARGET_UPDATE;
9011 1 : break;
9012 :
9013 1 : case EXEC_OMP_TARGET_ENTER_DATA:
9014 1 : ok = ifc == OMP_IF_TARGET_ENTER_DATA;
9015 1 : break;
9016 :
9017 1 : case EXEC_OMP_TARGET_EXIT_DATA:
9018 1 : ok = ifc == OMP_IF_TARGET_EXIT_DATA;
9019 1 : break;
9020 :
9021 10 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
9022 10 : case EXEC_OMP_TARGET_PARALLEL:
9023 10 : case EXEC_OMP_TARGET_PARALLEL_DO:
9024 10 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
9025 10 : ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_PARALLEL;
9026 10 : break;
9027 :
9028 10 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
9029 10 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
9030 10 : ok = (ifc == OMP_IF_TARGET
9031 10 : || ifc == OMP_IF_PARALLEL
9032 : || ifc == OMP_IF_SIMD);
9033 : break;
9034 :
9035 : default:
9036 : ok = false;
9037 : break;
9038 : }
9039 115 : if (!ok)
9040 : {
9041 2 : static const char *ifs[] = {
9042 : "CANCEL",
9043 : "PARALLEL",
9044 : "SIMD",
9045 : "TASK",
9046 : "TASKLOOP",
9047 : "TARGET",
9048 : "TARGET DATA",
9049 : "TARGET UPDATE",
9050 : "TARGET ENTER DATA",
9051 : "TARGET EXIT DATA"
9052 : };
9053 2 : gfc_error ("IF clause modifier %s at %L not appropriate for "
9054 : "the current OpenMP construct", ifs[ifc], &expr->where);
9055 : }
9056 : }
9057 :
9058 32198 : if (omp_clauses->self_expr)
9059 : {
9060 177 : gfc_expr *expr = omp_clauses->self_expr;
9061 177 : if (!gfc_resolve_expr (expr)
9062 177 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
9063 6 : gfc_error ("SELF clause at %L requires a scalar LOGICAL expression",
9064 : &expr->where);
9065 : }
9066 :
9067 32198 : if (omp_clauses->final_expr)
9068 : {
9069 64 : gfc_expr *expr = omp_clauses->final_expr;
9070 64 : if (!gfc_resolve_expr (expr)
9071 64 : || expr->ts.type != BT_LOGICAL || expr->rank != 0)
9072 0 : gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression",
9073 : &expr->where);
9074 : }
9075 32198 : if (omp_clauses->novariants)
9076 : {
9077 9 : gfc_expr *expr = omp_clauses->novariants;
9078 18 : if (!gfc_resolve_expr (expr) || expr->ts.type != BT_LOGICAL
9079 17 : || expr->rank != 0)
9080 1 : gfc_error (
9081 : "NOVARIANTS clause at %L requires a scalar LOGICAL expression",
9082 : &expr->where);
9083 32198 : if_without_mod = true;
9084 : }
9085 32198 : if (omp_clauses->nocontext)
9086 : {
9087 12 : gfc_expr *expr = omp_clauses->nocontext;
9088 24 : if (!gfc_resolve_expr (expr) || expr->ts.type != BT_LOGICAL
9089 23 : || expr->rank != 0)
9090 1 : gfc_error (
9091 : "NOCONTEXT clause at %L requires a scalar LOGICAL expression",
9092 : &expr->where);
9093 32198 : if_without_mod = true;
9094 : }
9095 32198 : if (omp_clauses->num_threads)
9096 962 : resolve_positive_int_expr (omp_clauses->num_threads, "NUM_THREADS");
9097 32198 : if (omp_clauses->dyn_groupprivate)
9098 10 : resolve_nonnegative_int_expr (omp_clauses->dyn_groupprivate,
9099 : "DYN_GROUPPRIVATE");
9100 32198 : if (omp_clauses->chunk_size)
9101 : {
9102 510 : gfc_expr *expr = omp_clauses->chunk_size;
9103 510 : if (!gfc_resolve_expr (expr)
9104 510 : || expr->ts.type != BT_INTEGER || expr->rank != 0)
9105 0 : gfc_error ("SCHEDULE clause's chunk_size at %L requires "
9106 : "a scalar INTEGER expression", &expr->where);
9107 510 : else if (expr->expr_type == EXPR_CONSTANT
9108 : && expr->ts.type == BT_INTEGER
9109 485 : && mpz_sgn (expr->value.integer) <= 0)
9110 2 : gfc_warning (OPT_Wopenmp, "INTEGER expression of SCHEDULE clause's "
9111 : "chunk_size at %L must be positive", &expr->where);
9112 : }
9113 32198 : if (omp_clauses->sched_kind != OMP_SCHED_NONE
9114 891 : && omp_clauses->sched_nonmonotonic)
9115 : {
9116 34 : if (omp_clauses->sched_monotonic)
9117 2 : gfc_error ("Both MONOTONIC and NONMONOTONIC schedule modifiers "
9118 : "specified at %L", &code->loc);
9119 32 : else if (omp_clauses->ordered)
9120 4 : gfc_error ("NONMONOTONIC schedule modifier specified with ORDERED "
9121 : "clause at %L", &code->loc);
9122 : }
9123 :
9124 32198 : if (omp_clauses->depobj
9125 32198 : && (!gfc_resolve_expr (omp_clauses->depobj)
9126 115 : || omp_clauses->depobj->ts.type != BT_INTEGER
9127 114 : || omp_clauses->depobj->ts.kind != 2 * gfc_index_integer_kind
9128 113 : || omp_clauses->depobj->rank != 0))
9129 4 : gfc_error ("DEPOBJ in DEPOBJ construct at %L shall be a scalar integer "
9130 4 : "of OMP_DEPEND_KIND kind", &omp_clauses->depobj->where);
9131 :
9132 : /* Check that no symbol appears on multiple clauses, except that
9133 : a symbol can appear on both firstprivate and lastprivate. */
9134 1287920 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
9135 1255722 : list = gfc_omp_list_type (list + 1))
9136 1300720 : for (n = omp_clauses->lists[list]; n; n = n->next)
9137 : {
9138 44998 : if (!n->sym) /* omp_all_memory. */
9139 47 : continue;
9140 44951 : n->sym->mark = 0;
9141 44951 : n->sym->comp_mark = 0;
9142 44951 : n->sym->data_mark = 0;
9143 44951 : n->sym->dev_mark = 0;
9144 44951 : n->sym->gen_mark = 0;
9145 44951 : n->sym->reduc_mark = 0;
9146 44951 : if (n->sym->attr.flavor == FL_VARIABLE
9147 274 : || n->sym->attr.proc_pointer
9148 233 : || (!code && (!n->sym->attr.dummy || n->sym->ns != ns)))
9149 : {
9150 44718 : if (!code && (!n->sym->attr.dummy || n->sym->ns != ns))
9151 0 : gfc_error ("Variable %qs is not a dummy argument at %L",
9152 : n->sym->name, &n->where);
9153 44718 : continue;
9154 : }
9155 233 : if (n->sym->attr.flavor == FL_PROCEDURE
9156 153 : && n->sym->result == n->sym
9157 138 : && n->sym->attr.function)
9158 : {
9159 138 : if (ns->proc_name == n->sym
9160 44 : || (ns->parent && ns->parent->proc_name == n->sym))
9161 101 : continue;
9162 37 : if (ns->proc_name->attr.entry_master)
9163 : {
9164 32 : gfc_entry_list *el = ns->entries;
9165 51 : for (; el; el = el->next)
9166 51 : if (el->sym == n->sym)
9167 : break;
9168 32 : if (el)
9169 32 : continue;
9170 : }
9171 5 : if (ns->parent
9172 3 : && ns->parent->proc_name->attr.entry_master)
9173 : {
9174 2 : gfc_entry_list *el = ns->parent->entries;
9175 3 : for (; el; el = el->next)
9176 3 : if (el->sym == n->sym)
9177 : break;
9178 2 : if (el)
9179 2 : continue;
9180 : }
9181 : }
9182 98 : if (list == OMP_LIST_MAP
9183 18 : && n->sym->attr.flavor == FL_PARAMETER)
9184 : {
9185 : /* OpenACC since 3.4 permits for Fortran named constants, but
9186 : permits removing then as optimization is not needed and such
9187 : ignore them. Likewise below for FIRSTPRIVATE. */
9188 12 : if (openacc)
9189 10 : gfc_warning (OPT_Wsurprising, "Clause for object %qs at %L is "
9190 : "ignored as parameters need not be copied",
9191 : n->sym->name, &n->where);
9192 : else
9193 2 : gfc_error ("Object %qs is not a variable at %L; parameters"
9194 : " cannot be and need not be mapped", n->sym->name,
9195 : &n->where);
9196 : }
9197 86 : else if (openacc && n->sym->attr.flavor == FL_PARAMETER)
9198 9 : gfc_warning (OPT_Wsurprising, "Clause for object %qs at %L is ignored"
9199 : " as it is a parameter", n->sym->name, &n->where);
9200 77 : else if (list != OMP_LIST_USES_ALLOCATORS)
9201 30 : gfc_error ("Object %qs is not a variable at %L", n->sym->name,
9202 : &n->where);
9203 : }
9204 32198 : if (omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
9205 : {
9206 69 : locus *loc = &omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where;
9207 69 : if (code->op != EXEC_OMP_DO
9208 : && code->op != EXEC_OMP_SIMD
9209 : && code->op != EXEC_OMP_DO_SIMD
9210 : && code->op != EXEC_OMP_PARALLEL_DO
9211 : && code->op != EXEC_OMP_PARALLEL_DO_SIMD)
9212 23 : gfc_error ("%<inscan%> REDUCTION clause on construct other than DO, "
9213 : "SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD at %L",
9214 : loc);
9215 69 : if (omp_clauses->ordered)
9216 2 : gfc_error ("ORDERED clause specified together with %<inscan%> "
9217 : "REDUCTION clause at %L", loc);
9218 69 : if (omp_clauses->sched_kind != OMP_SCHED_NONE)
9219 3 : gfc_error ("SCHEDULE clause specified together with %<inscan%> "
9220 : "REDUCTION clause at %L", loc);
9221 : }
9222 :
9223 1287920 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
9224 1255722 : list = gfc_omp_list_type (list + 1))
9225 1255722 : if (list != OMP_LIST_FIRSTPRIVATE
9226 1255722 : && list != OMP_LIST_LASTPRIVATE
9227 1255722 : && list != OMP_LIST_ALIGNED
9228 1159128 : && list != OMP_LIST_DEPEND
9229 1159128 : && list != OMP_LIST_FROM
9230 1094732 : && list != OMP_LIST_TO
9231 1094732 : && list != OMP_LIST_INTEROP
9232 1030336 : && (list != OMP_LIST_REDUCTION || !openacc)
9233 1017711 : && list != OMP_LIST_ALLOCATE)
9234 1019685 : for (n = omp_clauses->lists[list]; n; n = n->next)
9235 : {
9236 34172 : bool component_ref_p = false;
9237 :
9238 : /* Allow multiple components of the same (e.g. derived-type)
9239 : variable here. Duplicate components are detected elsewhere. */
9240 34172 : if (n->expr && n->expr->expr_type == EXPR_VARIABLE)
9241 15390 : for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
9242 9385 : if (ref->type == REF_COMPONENT)
9243 3134 : component_ref_p = true;
9244 34172 : if ((list == OMP_LIST_IS_DEVICE_PTR
9245 34172 : || list == OMP_LIST_HAS_DEVICE_ADDR)
9246 313 : && !component_ref_p)
9247 : {
9248 313 : if (n->sym->gen_mark
9249 311 : || n->sym->dev_mark
9250 310 : || n->sym->reduc_mark
9251 310 : || n->sym->mark)
9252 5 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9253 : n->sym->name, &n->where);
9254 : else
9255 308 : n->sym->dev_mark = 1;
9256 : }
9257 33859 : else if ((list == OMP_LIST_USE_DEVICE_PTR
9258 33859 : || list == OMP_LIST_USE_DEVICE_ADDR
9259 33859 : || list == OMP_LIST_PRIVATE
9260 : || list == OMP_LIST_SHARED)
9261 12851 : && !component_ref_p)
9262 : {
9263 12851 : if (n->sym->gen_mark || n->sym->dev_mark || n->sym->reduc_mark)
9264 13 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9265 : n->sym->name, &n->where);
9266 : else
9267 : {
9268 12838 : n->sym->gen_mark = 1;
9269 : /* Set both generic and device bits if we have
9270 : use_device_*(x) or shared(x). This allows us to diagnose
9271 : "map(x) private(x)" below. */
9272 12838 : if (list != OMP_LIST_PRIVATE)
9273 3456 : n->sym->dev_mark = 1;
9274 : }
9275 : }
9276 21008 : else if ((list == OMP_LIST_REDUCTION
9277 21008 : || list == OMP_LIST_REDUCTION_TASK
9278 18551 : || list == OMP_LIST_REDUCTION_INSCAN
9279 18551 : || list == OMP_LIST_IN_REDUCTION
9280 18338 : || list == OMP_LIST_TASK_REDUCTION)
9281 2670 : && !component_ref_p)
9282 : {
9283 : /* Attempts to mix reduction types are diagnosed below. */
9284 2670 : if (n->sym->gen_mark || n->sym->dev_mark)
9285 2 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9286 : n->sym->name, &n->where);
9287 2670 : n->sym->reduc_mark = 1;
9288 : }
9289 18338 : else if ((!component_ref_p && n->sym->comp_mark)
9290 2451 : || (component_ref_p && n->sym->mark))
9291 : {
9292 28 : if (openacc)
9293 3 : gfc_error ("Symbol %qs has mixed component and non-component "
9294 3 : "accesses at %L", n->sym->name, &n->where);
9295 : }
9296 18310 : else if (n->sym->mark)
9297 89 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9298 : n->sym->name, &n->where);
9299 : else
9300 : {
9301 18221 : if (component_ref_p)
9302 2424 : n->sym->comp_mark = 1;
9303 : else
9304 15797 : n->sym->mark = 1;
9305 : }
9306 : }
9307 :
9308 32198 : if (code
9309 31980 : && code->op == EXEC_OMP_INTEROP
9310 63 : && omp_clauses->lists[OMP_LIST_DEPEND])
9311 : {
9312 12 : if (!omp_clauses->lists[OMP_LIST_INIT]
9313 5 : && !omp_clauses->lists[OMP_LIST_USE]
9314 1 : && !omp_clauses->lists[OMP_LIST_DESTROY])
9315 : {
9316 1 : gfc_error ("DEPEND clause at %L requires action clause with "
9317 : "%<targetsync%> interop-type",
9318 : &omp_clauses->lists[OMP_LIST_DEPEND]->where);
9319 : }
9320 22 : for (n = omp_clauses->lists[OMP_LIST_INIT]; n; n = n->next)
9321 12 : if (!n->u.init.targetsync)
9322 : {
9323 2 : gfc_error ("DEPEND clause at %L requires %<targetsync%> "
9324 : "interop-type, lacking it for %qs at %L",
9325 2 : &omp_clauses->lists[OMP_LIST_DEPEND]->where,
9326 2 : n->sym->name, &n->where);
9327 2 : break;
9328 : }
9329 : }
9330 31980 : if (code && (code->op == EXEC_OMP_INTEROP || code->op == EXEC_OMP_DISPATCH))
9331 1085 : for (list = OMP_LIST_INIT; list <= OMP_LIST_INTEROP;
9332 868 : list = gfc_omp_list_type (list + 1))
9333 1123 : for (n = omp_clauses->lists[list]; n; n = n->next)
9334 : {
9335 255 : if (n->sym->ts.type != BT_INTEGER
9336 252 : || n->sym->ts.kind != gfc_index_integer_kind
9337 248 : || n->sym->attr.dimension
9338 243 : || n->sym->attr.flavor != FL_VARIABLE)
9339 16 : gfc_error ("%qs at %L in %qs clause must be a scalar integer "
9340 : "variable of %<omp_interop_kind%> kind", n->sym->name,
9341 : &n->where, clause_names[list]);
9342 255 : if (list != OMP_LIST_USE && list != OMP_LIST_INTEROP
9343 109 : && n->sym->attr.intent == INTENT_IN)
9344 2 : gfc_error ("%qs at %L in %qs clause must be definable",
9345 : n->sym->name, &n->where, clause_names[list]);
9346 : }
9347 :
9348 : /* Detect specifically the case where we have "map(x) private(x)" and raise
9349 : an error. If we have "...simd" combined directives though, the "private"
9350 : applies to the simd part, so this is permitted though. */
9351 41588 : for (n = omp_clauses->lists[OMP_LIST_PRIVATE]; n; n = n->next)
9352 9390 : if (n->sym->mark
9353 6 : && n->sym->gen_mark
9354 6 : && !n->sym->dev_mark
9355 6 : && !n->sym->reduc_mark
9356 5 : && code->op != EXEC_OMP_TARGET_SIMD
9357 : && code->op != EXEC_OMP_TARGET_PARALLEL_DO_SIMD
9358 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
9359 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD)
9360 1 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9361 : n->sym->name, &n->where);
9362 :
9363 : gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1);
9364 96594 : for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE;
9365 64396 : list = gfc_omp_list_type (list + 1))
9366 68557 : for (n = omp_clauses->lists[list]; n; n = n->next)
9367 4161 : if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
9368 : {
9369 9 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9370 : n->sym->name, &n->where);
9371 9 : n->sym->data_mark = n->sym->gen_mark = n->sym->dev_mark = 0;
9372 : }
9373 4152 : else if (n->sym->mark
9374 18 : && code->op != EXEC_OMP_TARGET_TEAMS
9375 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
9376 : && code->op != EXEC_OMP_TARGET_TEAMS_LOOP
9377 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
9378 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
9379 : && code->op != EXEC_OMP_TARGET_PARALLEL
9380 : && code->op != EXEC_OMP_TARGET_PARALLEL_DO
9381 : && code->op != EXEC_OMP_TARGET_PARALLEL_LOOP
9382 : && code->op != EXEC_OMP_TARGET_PARALLEL_DO_SIMD
9383 : && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD)
9384 7 : gfc_error ("Symbol %qs present on both data and map clauses "
9385 : "at %L", n->sym->name, &n->where);
9386 :
9387 34053 : for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next)
9388 : {
9389 1855 : if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
9390 7 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9391 : n->sym->name, &n->where);
9392 : else
9393 1848 : n->sym->data_mark = 1;
9394 : }
9395 34504 : for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
9396 2306 : n->sym->data_mark = 0;
9397 :
9398 34504 : for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
9399 : {
9400 2306 : if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
9401 0 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9402 : n->sym->name, &n->where);
9403 : else
9404 2306 : n->sym->data_mark = 1;
9405 : }
9406 :
9407 32348 : for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
9408 150 : n->sym->mark = 0;
9409 :
9410 32348 : for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
9411 : {
9412 150 : if (n->sym->mark)
9413 0 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9414 : n->sym->name, &n->where);
9415 : else
9416 150 : n->sym->mark = 1;
9417 : }
9418 :
9419 32198 : if (omp_clauses->lists[OMP_LIST_ALLOCATE])
9420 : {
9421 791 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9422 : {
9423 513 : if (n->u2.allocator
9424 513 : && (!gfc_resolve_expr (n->u2.allocator)
9425 288 : || n->u2.allocator->ts.type != BT_INTEGER
9426 286 : || n->u2.allocator->rank != 0
9427 285 : || n->u2.allocator->ts.kind != gfc_c_intptr_kind))
9428 : {
9429 8 : gfc_error ("Expected integer expression of the "
9430 : "%<omp_allocator_handle_kind%> kind at %L",
9431 8 : &n->u2.allocator->where);
9432 28 : break;
9433 : }
9434 505 : if (!n->u.align)
9435 397 : continue;
9436 108 : HOST_WIDE_INT alignment = 0;
9437 108 : if (!gfc_resolve_expr (n->u.align)
9438 108 : || n->u.align->ts.type != BT_INTEGER
9439 105 : || n->u.align->rank != 0
9440 102 : || n->u.align->expr_type != EXPR_CONSTANT
9441 99 : || gfc_extract_hwi (n->u.align, &alignment)
9442 99 : || alignment <= 0
9443 207 : || !pow2p_hwi (alignment))
9444 : {
9445 12 : gfc_error ("ALIGN requires a scalar positive constant integer "
9446 : "alignment expression at %L that is a power of two",
9447 12 : &n->u.align->where);
9448 12 : break;
9449 : }
9450 : }
9451 :
9452 : /* Check for 2 things here.
9453 : 1. There is no duplication of variable in allocate clause.
9454 : 2. Variable in allocate clause are also present in some
9455 : privatization clase (non-composite case). */
9456 811 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9457 513 : if (n->sym)
9458 487 : n->sym->mark = 0;
9459 :
9460 : gfc_omp_namelist *prev = NULL;
9461 811 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; )
9462 : {
9463 513 : if (n->sym == NULL)
9464 : {
9465 26 : n = n->next;
9466 26 : continue;
9467 : }
9468 487 : if (n->sym->mark == 1)
9469 : {
9470 3 : gfc_warning (OPT_Wopenmp, "%qs appears more than once in "
9471 : "%<allocate%> at %L" , n->sym->name, &n->where);
9472 : /* We have already seen this variable so it is a duplicate.
9473 : Remove it. */
9474 3 : if (prev != NULL && prev->next == n)
9475 : {
9476 3 : prev->next = n->next;
9477 3 : n->next = NULL;
9478 3 : gfc_free_omp_namelist (n, OMP_LIST_ALLOCATE);
9479 3 : n = prev->next;
9480 : }
9481 3 : continue;
9482 : }
9483 484 : n->sym->mark = 1;
9484 484 : prev = n;
9485 484 : n = n->next;
9486 : }
9487 :
9488 : /* Non-composite constructs. */
9489 298 : if (code && code->op < EXEC_OMP_DO_SIMD)
9490 : {
9491 4760 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
9492 4641 : list = gfc_omp_list_type (list + 1))
9493 4641 : switch (list)
9494 : {
9495 1071 : case OMP_LIST_PRIVATE:
9496 1071 : case OMP_LIST_FIRSTPRIVATE:
9497 1071 : case OMP_LIST_LASTPRIVATE:
9498 1071 : case OMP_LIST_REDUCTION:
9499 1071 : case OMP_LIST_REDUCTION_INSCAN:
9500 1071 : case OMP_LIST_REDUCTION_TASK:
9501 1071 : case OMP_LIST_IN_REDUCTION:
9502 1071 : case OMP_LIST_TASK_REDUCTION:
9503 1071 : case OMP_LIST_LINEAR:
9504 1370 : for (n = omp_clauses->lists[list]; n; n = n->next)
9505 299 : n->sym->mark = 0;
9506 : break;
9507 : default:
9508 : break;
9509 : }
9510 :
9511 410 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9512 291 : if (n->sym->mark == 1)
9513 4 : gfc_error ("%qs specified in %<allocate%> clause at %L but not "
9514 : "in an explicit privatization clause",
9515 : n->sym->name, &n->where);
9516 : }
9517 : if (code
9518 298 : && (code->op == EXEC_OMP_ALLOCATORS || code->op == EXEC_OMP_ALLOCATE)
9519 73 : && code->block
9520 72 : && code->block->next
9521 71 : && code->block->next->op == EXEC_ALLOCATE)
9522 : {
9523 68 : if (code->op == EXEC_OMP_ALLOCATE)
9524 49 : gfc_warning (OPT_Wdeprecated_openmp,
9525 : "The use of one or more %<allocate%> directives with "
9526 : "an associated %<allocate%> statement at %L is "
9527 : "deprecated since OpenMP 5.2, use an %<allocators%> "
9528 : "directive", &code->loc);
9529 68 : gfc_alloc *a;
9530 68 : gfc_omp_namelist *n_null = NULL;
9531 68 : bool missing_allocator = false;
9532 68 : gfc_symbol *missing_allocator_sym = NULL;
9533 161 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9534 : {
9535 93 : if (n->u2.allocator == NULL)
9536 : {
9537 77 : if (!missing_allocator_sym)
9538 59 : missing_allocator_sym = n->sym;
9539 : missing_allocator = true;
9540 : }
9541 93 : if (n->sym == NULL)
9542 : {
9543 26 : n_null = n;
9544 26 : continue;
9545 : }
9546 67 : if (n->sym->attr.codimension)
9547 2 : gfc_error ("Unexpected coarray %qs in %<allocate%> at %L",
9548 : n->sym->name, &n->where);
9549 103 : for (a = code->block->next->ext.alloc.list; a; a = a->next)
9550 101 : if (a->expr->expr_type == EXPR_VARIABLE
9551 101 : && a->expr->symtree->n.sym == n->sym)
9552 : {
9553 65 : gfc_ref *ref;
9554 82 : for (ref = a->expr->ref; ref; ref = ref->next)
9555 17 : if (ref->type == REF_COMPONENT)
9556 : break;
9557 : if (ref == NULL)
9558 : break;
9559 : }
9560 67 : if (a == NULL)
9561 2 : gfc_error ("%qs specified in %<allocate%> at %L but not "
9562 : "in the associated ALLOCATE statement",
9563 2 : n->sym->name, &n->where);
9564 : }
9565 : /* If there is an ALLOCATE directive without list argument, a
9566 : namelist with its allocator/align clauses and n->sym = NULL is
9567 : created during parsing; here, we add all not otherwise specified
9568 : items from the Fortran allocate to that list.
9569 : For an ALLOCATORS directive, not listed items use the normal
9570 : Fortran way.
9571 : The behavior of an ALLOCATE directive that does not list all
9572 : arguments but there is no directive without list argument is not
9573 : well specified. Thus, we reject such code below. In OpenMP 5.2
9574 : the executable ALLOCATE directive is deprecated and in 6.0
9575 : deleted such that no spec clarification is to be expected. */
9576 125 : for (a = code->block->next->ext.alloc.list; a; a = a->next)
9577 89 : if (a->expr->expr_type == EXPR_VARIABLE)
9578 : {
9579 154 : for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
9580 122 : if (a->expr->symtree->n.sym == n->sym)
9581 : {
9582 57 : gfc_ref *ref;
9583 72 : for (ref = a->expr->ref; ref; ref = ref->next)
9584 15 : if (ref->type == REF_COMPONENT)
9585 : break;
9586 : if (ref == NULL)
9587 : break;
9588 : }
9589 89 : if (n == NULL && n_null == NULL)
9590 : {
9591 : /* OK for ALLOCATORS but for ALLOCATE: Unspecified whether
9592 : that should use the default allocator of OpenMP or the
9593 : Fortran allocator. Thus, just reject it. */
9594 7 : if (code->op == EXEC_OMP_ALLOCATE)
9595 1 : gfc_error ("%qs listed in %<allocate%> statement at %L "
9596 : "but it is neither explicitly in listed in "
9597 : "the %<!$OMP ALLOCATE%> directive nor exists"
9598 : " a directive without argument list",
9599 1 : a->expr->symtree->n.sym->name,
9600 : &a->expr->where);
9601 : break;
9602 : }
9603 82 : if (n == NULL)
9604 : {
9605 25 : if (a->expr->symtree->n.sym->attr.codimension)
9606 1 : gfc_error ("Unexpected coarray %qs in %<allocate%> at "
9607 : "%L, implicitly listed in %<!$OMP ALLOCATE%>"
9608 : " at %L", a->expr->symtree->n.sym->name,
9609 : &a->expr->where, &n_null->where);
9610 : break;
9611 : }
9612 : }
9613 68 : gfc_namespace *prog_unit = ns;
9614 87 : while (prog_unit->parent)
9615 : prog_unit = prog_unit->parent;
9616 : gfc_namespace *fn_ns = ns;
9617 72 : while (fn_ns)
9618 : {
9619 70 : if (ns->proc_name
9620 70 : && (ns->proc_name->attr.subroutine
9621 6 : || ns->proc_name->attr.function))
9622 : break;
9623 4 : fn_ns = fn_ns->parent;
9624 : }
9625 68 : if (missing_allocator
9626 58 : && !(prog_unit->omp_requires & OMP_REQ_DYNAMIC_ALLOCATORS)
9627 58 : && ((fn_ns && fn_ns->proc_name->attr.omp_declare_target)
9628 55 : || omp_clauses->contained_in_target_construct))
9629 : {
9630 6 : if (code->op == EXEC_OMP_ALLOCATORS)
9631 2 : gfc_error ("ALLOCATORS directive at %L inside a target region "
9632 : "must specify an ALLOCATOR modifier for %qs",
9633 : &code->loc, missing_allocator_sym->name);
9634 4 : else if (missing_allocator_sym)
9635 2 : gfc_error ("ALLOCATE directive at %L inside a target region "
9636 : "must specify an ALLOCATOR clause for %qs",
9637 : &code->loc, missing_allocator_sym->name);
9638 : else
9639 2 : gfc_error ("ALLOCATE directive at %L inside a target region "
9640 : "must specify an ALLOCATOR clause", &code->loc);
9641 : }
9642 :
9643 : }
9644 : }
9645 :
9646 : /* OpenACC reductions. */
9647 32198 : if (openacc)
9648 : {
9649 14761 : for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next)
9650 2136 : n->sym->mark = 0;
9651 :
9652 14761 : for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next)
9653 : {
9654 2136 : if (n->sym->mark)
9655 0 : gfc_error ("Symbol %qs present on multiple clauses at %L",
9656 : n->sym->name, &n->where);
9657 : else
9658 2136 : n->sym->mark = 1;
9659 :
9660 : /* OpenACC does not support reductions on arrays. */
9661 2136 : if (n->sym->as)
9662 71 : gfc_error ("Array %qs is not permitted in reduction at %L",
9663 : n->sym->name, &n->where);
9664 : }
9665 : }
9666 :
9667 32952 : for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
9668 754 : n->sym->mark = 0;
9669 33229 : for (n = omp_clauses->lists[OMP_LIST_FROM]; n; n = n->next)
9670 1031 : if (n->expr == NULL)
9671 1015 : n->sym->mark = 1;
9672 32952 : for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
9673 : {
9674 754 : if (n->expr == NULL && n->sym->mark)
9675 0 : gfc_error ("Symbol %qs present on both FROM and TO clauses at %L",
9676 : n->sym->name, &n->where);
9677 : else
9678 754 : n->sym->mark = 1;
9679 : }
9680 :
9681 : bool has_inscan = false, has_notinscan = false;
9682 1287920 : for (enum gfc_omp_list_type list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
9683 1255722 : list = gfc_omp_list_type (list + 1))
9684 1255722 : if ((n = omp_clauses->lists[list]) != NULL)
9685 : {
9686 28895 : const char *name = clause_names[list];
9687 :
9688 28895 : switch (list)
9689 : {
9690 : case OMP_LIST_COPYIN:
9691 267 : for (; n != NULL; n = n->next)
9692 : {
9693 170 : if (!n->sym->attr.threadprivate)
9694 0 : gfc_error ("Non-THREADPRIVATE object %qs in COPYIN clause"
9695 : " at %L", n->sym->name, &n->where);
9696 : }
9697 : break;
9698 83 : case OMP_LIST_COPYPRIVATE:
9699 83 : if (omp_clauses->nowait)
9700 6 : gfc_error ("NOWAIT clause must not be used with COPYPRIVATE "
9701 : "clause at %L", &n->where);
9702 376 : for (; n != NULL; n = n->next)
9703 : {
9704 293 : if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
9705 0 : gfc_error ("Assumed size array %qs in COPYPRIVATE clause "
9706 : "at %L", n->sym->name, &n->where);
9707 293 : if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
9708 1 : gfc_error ("INTENT(IN) POINTER %qs in COPYPRIVATE clause "
9709 : "at %L", n->sym->name, &n->where);
9710 : }
9711 : break;
9712 : case OMP_LIST_SHARED:
9713 2604 : for (; n != NULL; n = n->next)
9714 : {
9715 1642 : if (n->sym->attr.threadprivate)
9716 0 : gfc_error ("THREADPRIVATE object %qs in SHARED clause at "
9717 : "%L", n->sym->name, &n->where);
9718 1642 : if (n->sym->attr.cray_pointee)
9719 1 : gfc_error ("Cray pointee %qs in SHARED clause at %L",
9720 : n->sym->name, &n->where);
9721 1642 : if (n->sym->attr.associate_var)
9722 8 : gfc_error ("Associate name %qs in SHARED clause at %L",
9723 8 : n->sym->attr.select_type_temporary
9724 4 : ? n->sym->assoc->target->symtree->n.sym->name
9725 : : n->sym->name, &n->where);
9726 1642 : if (omp_clauses->detach
9727 1 : && n->sym == omp_clauses->detach->symtree->n.sym)
9728 1 : gfc_error ("DETACH event handle %qs in SHARED clause at %L",
9729 : n->sym->name, &n->where);
9730 : }
9731 : break;
9732 : case OMP_LIST_ALIGNED:
9733 256 : for (; n != NULL; n = n->next)
9734 : {
9735 150 : if (!n->sym->attr.pointer
9736 45 : && !n->sym->attr.allocatable
9737 30 : && !n->sym->attr.cray_pointer
9738 18 : && (n->sym->ts.type != BT_DERIVED
9739 18 : || (n->sym->ts.u.derived->from_intmod
9740 : != INTMOD_ISO_C_BINDING)
9741 18 : || (n->sym->ts.u.derived->intmod_sym_id
9742 : != ISOCBINDING_PTR)))
9743 0 : gfc_error ("%qs in ALIGNED clause must be POINTER, "
9744 : "ALLOCATABLE, Cray pointer or C_PTR at %L",
9745 : n->sym->name, &n->where);
9746 150 : else if (n->expr)
9747 : {
9748 147 : if (!gfc_resolve_expr (n->expr)
9749 147 : || n->expr->ts.type != BT_INTEGER
9750 146 : || n->expr->rank != 0
9751 146 : || n->expr->expr_type != EXPR_CONSTANT
9752 292 : || mpz_sgn (n->expr->value.integer) <= 0)
9753 4 : gfc_error ("%qs in ALIGNED clause at %L requires a scalar"
9754 : " positive constant integer alignment "
9755 4 : "expression", n->sym->name, &n->where);
9756 : }
9757 : }
9758 : break;
9759 : case OMP_LIST_AFFINITY:
9760 : case OMP_LIST_DEPEND:
9761 : case OMP_LIST_MAP:
9762 : case OMP_LIST_TO:
9763 : case OMP_LIST_FROM:
9764 : case OMP_LIST_CACHE:
9765 32098 : for (; n != NULL; n = n->next)
9766 : {
9767 20197 : if ((list == OMP_LIST_DEPEND || list == OMP_LIST_AFFINITY)
9768 1998 : && n->u2.ns && !n->u2.ns->resolved)
9769 : {
9770 56 : n->u2.ns->resolved = 1;
9771 56 : for (gfc_symbol *sym = n->u2.ns->omp_affinity_iterators;
9772 116 : sym; sym = sym->tlink)
9773 : {
9774 60 : gfc_constructor *c;
9775 60 : c = gfc_constructor_first (sym->value->value.constructor);
9776 60 : if (!gfc_resolve_expr (c->expr)
9777 60 : || c->expr->ts.type != BT_INTEGER
9778 118 : || c->expr->rank != 0)
9779 2 : gfc_error ("Scalar integer expression for range begin"
9780 2 : " expected at %L", &c->expr->where);
9781 60 : c = gfc_constructor_next (c);
9782 60 : if (!gfc_resolve_expr (c->expr)
9783 60 : || c->expr->ts.type != BT_INTEGER
9784 118 : || c->expr->rank != 0)
9785 2 : gfc_error ("Scalar integer expression for range end "
9786 2 : "expected at %L", &c->expr->where);
9787 60 : c = gfc_constructor_next (c);
9788 60 : if (c && (!gfc_resolve_expr (c->expr)
9789 16 : || c->expr->ts.type != BT_INTEGER
9790 14 : || c->expr->rank != 0))
9791 2 : gfc_error ("Scalar integer expression for range step "
9792 2 : "expected at %L", &c->expr->where);
9793 58 : else if (c
9794 14 : && c->expr->expr_type == EXPR_CONSTANT
9795 12 : && mpz_cmp_si (c->expr->value.integer, 0) == 0)
9796 2 : gfc_error ("Nonzero range step expected at %L",
9797 : &c->expr->where);
9798 : }
9799 : }
9800 :
9801 1998 : if (list == OMP_LIST_DEPEND)
9802 : {
9803 3196 : if (n->u.depend_doacross_op == OMP_DEPEND_SINK_FIRST
9804 : || n->u.depend_doacross_op == OMP_DOACROSS_SINK_FIRST
9805 1963 : || n->u.depend_doacross_op == OMP_DOACROSS_SINK)
9806 : {
9807 1233 : if (omp_clauses->doacross_source)
9808 : {
9809 0 : gfc_error ("Dependence-type SINK used together with"
9810 : " SOURCE on the same construct at %L",
9811 : &n->where);
9812 0 : omp_clauses->doacross_source = false;
9813 : }
9814 1233 : else if (n->expr)
9815 : {
9816 571 : if (!gfc_resolve_expr (n->expr)
9817 571 : || n->expr->ts.type != BT_INTEGER
9818 1142 : || n->expr->rank != 0)
9819 0 : gfc_error ("SINK addend not a constant integer "
9820 : "at %L", &n->where);
9821 : }
9822 1233 : if (n->sym == NULL
9823 4 : && (n->expr == NULL
9824 3 : || mpz_cmp_si (n->expr->value.integer, -1) != 0))
9825 2 : gfc_error ("omp_cur_iteration at %L requires %<-1%> "
9826 : "as logical offset", &n->where);
9827 1233 : continue;
9828 : }
9829 730 : else if (n->u.depend_doacross_op == OMP_DEPEND_DEPOBJ
9830 38 : && !n->expr
9831 22 : && (n->sym->ts.type != BT_INTEGER
9832 22 : || n->sym->ts.kind
9833 22 : != 2 * gfc_index_integer_kind
9834 22 : || n->sym->attr.dimension))
9835 0 : gfc_error ("Locator %qs at %L in DEPEND clause of depobj "
9836 : "type shall be a scalar integer of "
9837 : "OMP_DEPEND_KIND kind", n->sym->name,
9838 : &n->where);
9839 730 : else if (n->u.depend_doacross_op == OMP_DEPEND_DEPOBJ
9840 38 : && n->expr
9841 746 : && (!gfc_resolve_expr (n->expr)
9842 16 : || n->expr->ts.type != BT_INTEGER
9843 16 : || n->expr->ts.kind
9844 16 : != 2 * gfc_index_integer_kind
9845 16 : || n->expr->rank != 0))
9846 0 : gfc_error ("Locator at %L in DEPEND clause of depobj "
9847 : "type shall be a scalar integer of "
9848 0 : "OMP_DEPEND_KIND kind", &n->expr->where);
9849 : }
9850 18964 : gfc_ref *lastref = NULL, *lastslice = NULL;
9851 18964 : bool resolved = false;
9852 18964 : if (n->expr)
9853 : {
9854 6257 : lastref = n->expr->ref;
9855 6257 : resolved = gfc_resolve_expr (n->expr);
9856 :
9857 : /* Look through component refs to find last array
9858 : reference. */
9859 6257 : if (resolved)
9860 : {
9861 15894 : for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
9862 9655 : if (ref->type == REF_COMPONENT
9863 : || ref->type == REF_SUBSTRING
9864 9655 : || ref->type == REF_INQUIRY)
9865 : lastref = ref;
9866 6473 : else if (ref->type == REF_ARRAY)
9867 : {
9868 13636 : for (int i = 0; i < ref->u.ar.dimen; i++)
9869 7163 : if (ref->u.ar.dimen_type[i] == DIMEN_RANGE)
9870 6009 : lastslice = ref;
9871 :
9872 : lastref = ref;
9873 : }
9874 :
9875 : /* The "!$acc cache" directive allows rectangular
9876 : subarrays to be specified, with some restrictions
9877 : on the form of bounds (not implemented).
9878 : Only raise an error here if we're really sure the
9879 : array isn't contiguous. An expression such as
9880 : arr(-n:n,-n:n) could be contiguous even if it looks
9881 : like it may not be. */
9882 6239 : if (code->op != EXEC_OACC_UPDATE
9883 5457 : && list != OMP_LIST_CACHE
9884 5457 : && list != OMP_LIST_DEPEND
9885 5135 : && !gfc_is_simply_contiguous (n->expr, false, true)
9886 1407 : && gfc_is_not_contiguous (n->expr)
9887 6252 : && !(lastslice
9888 13 : && (lastslice->next
9889 3 : || lastslice->type != REF_ARRAY)))
9890 3 : gfc_error ("Array is not contiguous at %L",
9891 : &n->where);
9892 : }
9893 : }
9894 18964 : if (list == OMP_LIST_MAP
9895 16313 : && (n->sym->attr.omp_groupprivate
9896 16312 : || n->sym->attr.omp_declare_target_local))
9897 2 : gfc_error ("%qs argument to MAP clause at %L must not be a "
9898 : "device-local variable, including GROUPPRIVATE",
9899 : n->sym->name, &n->where);
9900 18964 : if (openacc
9901 18964 : && list == OMP_LIST_MAP
9902 9571 : && (n->u.map.op == OMP_MAP_ATTACH
9903 9501 : || n->u.map.op == OMP_MAP_DETACH))
9904 : {
9905 117 : symbol_attribute attr;
9906 117 : if (n->expr)
9907 99 : attr = gfc_expr_attr (n->expr);
9908 : else
9909 18 : attr = n->sym->attr;
9910 117 : if (!attr.pointer && !attr.allocatable)
9911 7 : gfc_error ("%qs clause argument must be ALLOCATABLE or "
9912 : "a POINTER at %L",
9913 7 : (n->u.map.op == OMP_MAP_ATTACH) ? "attach"
9914 : : "detach", &n->where);
9915 : }
9916 18964 : if (lastref
9917 12719 : || (n->expr
9918 12 : && (!resolved || n->expr->expr_type != EXPR_VARIABLE)))
9919 : {
9920 6257 : if (!lastslice
9921 6257 : && lastref
9922 898 : && lastref->type == REF_SUBSTRING)
9923 11 : gfc_error ("Unexpected substring reference in %s clause "
9924 : "at %L", name, &n->where);
9925 6246 : else if (!lastslice
9926 : && lastref
9927 887 : && lastref->type == REF_INQUIRY)
9928 : {
9929 12 : gcc_assert (lastref->u.i == INQUIRY_RE
9930 : || lastref->u.i == INQUIRY_IM);
9931 12 : gfc_error ("Unexpected complex-parts designator "
9932 : "reference in %s clause at %L",
9933 : name, &n->where);
9934 : }
9935 6234 : else if (!resolved
9936 6216 : || n->expr->expr_type != EXPR_VARIABLE
9937 6204 : || (lastslice
9938 5347 : && (lastslice->next
9939 5331 : || lastslice->type != REF_ARRAY)))
9940 46 : gfc_error ("%qs in %s clause at %L is not a proper "
9941 46 : "array section", n->sym->name, name,
9942 : &n->where);
9943 : else if (lastslice)
9944 : {
9945 : int i;
9946 : gfc_array_ref *ar = &lastslice->u.ar;
9947 11337 : for (i = 0; i < ar->dimen; i++)
9948 6007 : if (ar->stride[i] && code->op != EXEC_OACC_UPDATE)
9949 : {
9950 1 : gfc_error ("Stride should not be specified for "
9951 : "array section in %s clause at %L",
9952 : name, &n->where);
9953 1 : break;
9954 : }
9955 6006 : else if (ar->dimen_type[i] != DIMEN_ELEMENT
9956 6006 : && ar->dimen_type[i] != DIMEN_RANGE)
9957 : {
9958 0 : gfc_error ("%qs in %s clause at %L is not a "
9959 : "proper array section",
9960 0 : n->sym->name, name, &n->where);
9961 0 : break;
9962 : }
9963 6006 : else if ((list == OMP_LIST_DEPEND
9964 : || list == OMP_LIST_AFFINITY)
9965 161 : && ar->start[i]
9966 133 : && ar->start[i]->expr_type == EXPR_CONSTANT
9967 97 : && ar->end[i]
9968 72 : && ar->end[i]->expr_type == EXPR_CONSTANT
9969 72 : && mpz_cmp (ar->start[i]->value.integer,
9970 72 : ar->end[i]->value.integer) > 0)
9971 : {
9972 0 : gfc_error ("%qs in %s clause at %L is a "
9973 : "zero size array section",
9974 0 : n->sym->name,
9975 : list == OMP_LIST_DEPEND
9976 : ? "DEPEND" : "AFFINITY", &n->where);
9977 0 : break;
9978 : }
9979 : }
9980 : }
9981 12707 : else if (openacc)
9982 : {
9983 5915 : if (list == OMP_LIST_MAP
9984 5900 : && n->u.map.op == OMP_MAP_FORCE_DEVICEPTR)
9985 65 : resolve_oacc_deviceptr_clause (n->sym, n->where, name);
9986 : else
9987 5850 : resolve_oacc_data_clauses (n->sym, n->where, name);
9988 : }
9989 6792 : else if (list != OMP_LIST_DEPEND
9990 6299 : && n->sym->as
9991 3013 : && n->sym->as->type == AS_ASSUMED_SIZE)
9992 5 : gfc_error ("Assumed size array %qs in %s clause at %L",
9993 : n->sym->name, name, &n->where);
9994 18964 : if (list == OMP_LIST_MAP && !openacc)
9995 6742 : switch (code->op)
9996 : {
9997 5618 : case EXEC_OMP_TARGET:
9998 5618 : case EXEC_OMP_TARGET_PARALLEL:
9999 5618 : case EXEC_OMP_TARGET_PARALLEL_DO:
10000 5618 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
10001 5618 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
10002 5618 : case EXEC_OMP_TARGET_SIMD:
10003 5618 : case EXEC_OMP_TARGET_TEAMS:
10004 5618 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
10005 5618 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
10006 5618 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10007 5618 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
10008 5618 : case EXEC_OMP_TARGET_TEAMS_LOOP:
10009 5618 : case EXEC_OMP_TARGET_DATA:
10010 5618 : switch (n->u.map.op)
10011 : {
10012 : case OMP_MAP_TO:
10013 : case OMP_MAP_ALWAYS_TO:
10014 : case OMP_MAP_PRESENT_TO:
10015 : case OMP_MAP_ALWAYS_PRESENT_TO:
10016 : case OMP_MAP_FROM:
10017 : case OMP_MAP_ALWAYS_FROM:
10018 : case OMP_MAP_PRESENT_FROM:
10019 : case OMP_MAP_ALWAYS_PRESENT_FROM:
10020 : case OMP_MAP_TOFROM:
10021 : case OMP_MAP_ALWAYS_TOFROM:
10022 : case OMP_MAP_PRESENT_TOFROM:
10023 : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
10024 : case OMP_MAP_ALLOC:
10025 : case OMP_MAP_PRESENT_ALLOC:
10026 : break;
10027 2 : default:
10028 2 : gfc_error ("TARGET%s with map-type other than TO, "
10029 : "FROM, TOFROM, or ALLOC on MAP clause "
10030 : "at %L",
10031 : code->op == EXEC_OMP_TARGET_DATA
10032 : ? " DATA" : "", &n->where);
10033 2 : break;
10034 : }
10035 : break;
10036 625 : case EXEC_OMP_TARGET_ENTER_DATA:
10037 625 : switch (n->u.map.op)
10038 : {
10039 : case OMP_MAP_TO:
10040 : case OMP_MAP_ALWAYS_TO:
10041 : case OMP_MAP_PRESENT_TO:
10042 : case OMP_MAP_ALWAYS_PRESENT_TO:
10043 : case OMP_MAP_ALLOC:
10044 : case OMP_MAP_PRESENT_ALLOC:
10045 : break;
10046 176 : case OMP_MAP_TOFROM:
10047 176 : n->u.map.op = OMP_MAP_TO;
10048 176 : break;
10049 3 : case OMP_MAP_ALWAYS_TOFROM:
10050 3 : n->u.map.op = OMP_MAP_ALWAYS_TO;
10051 3 : break;
10052 2 : case OMP_MAP_PRESENT_TOFROM:
10053 2 : n->u.map.op = OMP_MAP_PRESENT_TO;
10054 2 : break;
10055 2 : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
10056 2 : n->u.map.op = OMP_MAP_ALWAYS_PRESENT_TO;
10057 2 : break;
10058 2 : default:
10059 2 : gfc_error ("TARGET ENTER DATA with map-type other "
10060 : "than TO, TOFROM or ALLOC on MAP clause "
10061 : "at %L", &n->where);
10062 2 : break;
10063 : }
10064 : break;
10065 499 : case EXEC_OMP_TARGET_EXIT_DATA:
10066 499 : switch (n->u.map.op)
10067 : {
10068 : case OMP_MAP_FROM:
10069 : case OMP_MAP_ALWAYS_FROM:
10070 : case OMP_MAP_PRESENT_FROM:
10071 : case OMP_MAP_ALWAYS_PRESENT_FROM:
10072 : case OMP_MAP_RELEASE:
10073 : case OMP_MAP_DELETE:
10074 : break;
10075 132 : case OMP_MAP_TOFROM:
10076 132 : n->u.map.op = OMP_MAP_FROM;
10077 132 : break;
10078 1 : case OMP_MAP_ALWAYS_TOFROM:
10079 1 : n->u.map.op = OMP_MAP_ALWAYS_FROM;
10080 1 : break;
10081 0 : case OMP_MAP_PRESENT_TOFROM:
10082 0 : n->u.map.op = OMP_MAP_PRESENT_FROM;
10083 0 : break;
10084 0 : case OMP_MAP_ALWAYS_PRESENT_TOFROM:
10085 0 : n->u.map.op = OMP_MAP_ALWAYS_PRESENT_FROM;
10086 0 : break;
10087 2 : default:
10088 2 : gfc_error ("TARGET EXIT DATA with map-type other "
10089 : "than FROM, TOFROM, RELEASE, or DELETE on "
10090 : "MAP clause at %L", &n->where);
10091 2 : break;
10092 : }
10093 : break;
10094 : default:
10095 : break;
10096 : }
10097 : }
10098 :
10099 11901 : if (list != OMP_LIST_DEPEND)
10100 29288 : for (n = omp_clauses->lists[list]; n != NULL; n = n->next)
10101 : {
10102 18234 : n->sym->attr.referenced = 1;
10103 18234 : if (n->sym->attr.threadprivate)
10104 1 : gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
10105 : n->sym->name, name, &n->where);
10106 18234 : if (n->sym->attr.cray_pointee)
10107 14 : gfc_error ("Cray pointee %qs in %s clause at %L",
10108 : n->sym->name, name, &n->where);
10109 : }
10110 : break;
10111 : case OMP_LIST_IS_DEVICE_PTR:
10112 : last = NULL;
10113 377 : for (n = omp_clauses->lists[list]; n != NULL; )
10114 : {
10115 257 : if ((n->sym->ts.type != BT_DERIVED
10116 71 : || !n->sym->ts.u.derived->ts.is_iso_c
10117 71 : || (n->sym->ts.u.derived->intmod_sym_id
10118 : != ISOCBINDING_PTR))
10119 187 : && code->op == EXEC_OMP_DISPATCH)
10120 : /* Non-TARGET (i.e. DISPATCH) requires a C_PTR. */
10121 3 : gfc_error ("List item %qs in %s clause at %L must be of "
10122 : "TYPE(C_PTR)", n->sym->name, name, &n->where);
10123 254 : else if (n->sym->ts.type != BT_DERIVED
10124 70 : || !n->sym->ts.u.derived->ts.is_iso_c
10125 70 : || (n->sym->ts.u.derived->intmod_sym_id
10126 : != ISOCBINDING_PTR))
10127 : {
10128 : /* For TARGET, non-C_PTR are deprecated and handled as
10129 : has_device_addr. */
10130 184 : gfc_warning (OPT_Wdeprecated_openmp,
10131 : "Non-C_PTR type argument at %L is deprecated, "
10132 : "use HAS_DEVICE_ADDR", &n->where);
10133 184 : gfc_omp_namelist *n2 = n;
10134 184 : n = n->next;
10135 184 : if (last)
10136 0 : last->next = n;
10137 : else
10138 184 : omp_clauses->lists[list] = n;
10139 184 : n2->next = omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR];
10140 184 : omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR] = n2;
10141 184 : continue;
10142 184 : }
10143 73 : last = n;
10144 73 : n = n->next;
10145 : }
10146 : break;
10147 : case OMP_LIST_HAS_DEVICE_ADDR:
10148 : case OMP_LIST_USE_DEVICE_ADDR:
10149 : break;
10150 : case OMP_LIST_USE_DEVICE_PTR:
10151 : /* Non-C_PTR are deprecated and handled as use_device_ADDR. */
10152 : last = NULL;
10153 475 : for (n = omp_clauses->lists[list]; n != NULL; )
10154 : {
10155 312 : gfc_omp_namelist *n2 = n;
10156 312 : if (n->sym->ts.type != BT_DERIVED
10157 18 : || !n->sym->ts.u.derived->ts.is_iso_c)
10158 : {
10159 294 : gfc_warning (OPT_Wdeprecated_openmp,
10160 : "Non-C_PTR type argument at %L is "
10161 : "deprecated, use USE_DEVICE_ADDR", &n->where);
10162 294 : n = n->next;
10163 294 : if (last)
10164 0 : last->next = n;
10165 : else
10166 294 : omp_clauses->lists[list] = n;
10167 294 : n2->next = omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR];
10168 294 : omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] = n2;
10169 294 : continue;
10170 : }
10171 18 : last = n;
10172 18 : n = n->next;
10173 : }
10174 : break;
10175 48 : case OMP_LIST_USES_ALLOCATORS:
10176 48 : {
10177 48 : if (n != NULL
10178 48 : && n->u.memspace_sym
10179 14 : && (n->u.memspace_sym->attr.flavor != FL_PARAMETER
10180 13 : || n->u.memspace_sym->ts.type != BT_INTEGER
10181 13 : || n->u.memspace_sym->ts.kind != gfc_c_intptr_kind
10182 13 : || n->u.memspace_sym->attr.dimension
10183 13 : || (!startswith (n->u.memspace_sym->name, "omp_")
10184 0 : && !startswith (n->u.memspace_sym->name, "ompx_"))
10185 13 : || !endswith (n->u.memspace_sym->name, "_mem_space")))
10186 2 : gfc_error ("Memspace %qs at %L in USES_ALLOCATORS must be "
10187 : "a predefined memory space",
10188 : n->u.memspace_sym->name, &n->where);
10189 144 : for (; n != NULL; n = n->next)
10190 : {
10191 102 : if (n->sym->ts.type != BT_INTEGER
10192 102 : || n->sym->ts.kind != gfc_c_intptr_kind
10193 101 : || n->sym->attr.dimension)
10194 2 : gfc_error ("Allocator %qs at %L in USES_ALLOCATORS must "
10195 : "be a scalar integer of kind "
10196 : "%<omp_allocator_handle_kind%>", n->sym->name,
10197 : &n->where);
10198 100 : else if (n->sym->attr.flavor != FL_VARIABLE
10199 47 : && strcmp (n->sym->name, "omp_null_allocator") != 0
10200 144 : && ((!startswith (n->sym->name, "omp_")
10201 1 : && !startswith (n->sym->name, "ompx_"))
10202 43 : || !endswith (n->sym->name, "_mem_alloc")))
10203 2 : gfc_error ("Allocator %qs at %L in USES_ALLOCATORS must "
10204 : "either a variable or a predefined allocator",
10205 : n->sym->name, &n->where);
10206 98 : else if ((n->u.memspace_sym || n->u2.traits_sym)
10207 47 : && n->sym->attr.flavor != FL_VARIABLE)
10208 3 : gfc_error ("A memory space or traits array may not be "
10209 : "specified for predefined allocator %qs at %L",
10210 : n->sym->name, &n->where);
10211 102 : if (n->u2.traits_sym
10212 41 : && (n->u2.traits_sym->attr.flavor != FL_PARAMETER
10213 39 : || !n->u2.traits_sym->attr.dimension
10214 37 : || n->u2.traits_sym->as->rank != 1
10215 37 : || n->u2.traits_sym->ts.type != BT_DERIVED
10216 35 : || strcmp (n->u2.traits_sym->ts.u.derived->name,
10217 : "omp_alloctrait") != 0))
10218 : {
10219 6 : gfc_error ("Traits array %qs in USES_ALLOCATORS %L must "
10220 : "be a one-dimensional named constant array of "
10221 : "type %<omp_alloctrait%>",
10222 : n->u2.traits_sym->name, &n->where);
10223 6 : break;
10224 : }
10225 : }
10226 : break;
10227 : }
10228 : default:
10229 34670 : for (; n != NULL; n = n->next)
10230 : {
10231 20309 : if (n->sym == NULL)
10232 : {
10233 26 : gcc_assert (code->op == EXEC_OMP_ALLOCATORS
10234 : || code->op == EXEC_OMP_ALLOCATE);
10235 26 : continue;
10236 : }
10237 20283 : bool bad = false;
10238 20283 : bool is_reduction = (list == OMP_LIST_REDUCTION
10239 : || list == OMP_LIST_REDUCTION_INSCAN
10240 : || list == OMP_LIST_REDUCTION_TASK
10241 : || list == OMP_LIST_IN_REDUCTION
10242 20283 : || list == OMP_LIST_TASK_REDUCTION);
10243 20283 : if (list == OMP_LIST_REDUCTION_INSCAN)
10244 : has_inscan = true;
10245 20211 : else if (is_reduction)
10246 4734 : has_notinscan = true;
10247 20283 : if (has_inscan && has_notinscan && is_reduction)
10248 : {
10249 3 : gfc_error ("%<inscan%> and non-%<inscan%> %<reduction%> "
10250 : "clauses on the same construct at %L",
10251 : &n->where);
10252 3 : break;
10253 : }
10254 20280 : if (n->sym->attr.threadprivate)
10255 1 : gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
10256 : n->sym->name, name, &n->where);
10257 20280 : if (n->sym->attr.cray_pointee)
10258 14 : gfc_error ("Cray pointee %qs in %s clause at %L",
10259 : n->sym->name, name, &n->where);
10260 20280 : if (n->sym->attr.associate_var)
10261 22 : gfc_error ("Associate name %qs in %s clause at %L",
10262 22 : n->sym->attr.select_type_temporary
10263 4 : ? n->sym->assoc->target->symtree->n.sym->name
10264 : : n->sym->name, name, &n->where);
10265 20280 : if (list != OMP_LIST_PRIVATE && is_reduction)
10266 : {
10267 4803 : if (n->sym->attr.proc_pointer)
10268 1 : gfc_error ("Procedure pointer %qs in %s clause at %L",
10269 : n->sym->name, name, &n->where);
10270 4803 : if (n->sym->attr.pointer)
10271 3 : gfc_error ("POINTER object %qs in %s clause at %L",
10272 : n->sym->name, name, &n->where);
10273 4803 : if (n->sym->attr.cray_pointer)
10274 5 : gfc_error ("Cray pointer %qs in %s clause at %L",
10275 : n->sym->name, name, &n->where);
10276 : }
10277 20280 : if (code
10278 20280 : && (oacc_is_loop (code)
10279 : || code->op == EXEC_OACC_PARALLEL
10280 : || code->op == EXEC_OACC_SERIAL))
10281 8741 : check_array_not_assumed (n->sym, n->where, name);
10282 11539 : else if (list != OMP_LIST_UNIFORM
10283 11422 : && n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
10284 2 : gfc_error ("Assumed size array %qs in %s clause at %L",
10285 : n->sym->name, name, &n->where);
10286 20280 : if (n->sym->attr.in_namelist && !is_reduction)
10287 0 : gfc_error ("Variable %qs in %s clause is used in "
10288 : "NAMELIST statement at %L",
10289 : n->sym->name, name, &n->where);
10290 20280 : if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
10291 3 : switch (list)
10292 : {
10293 3 : case OMP_LIST_PRIVATE:
10294 3 : case OMP_LIST_LASTPRIVATE:
10295 3 : case OMP_LIST_LINEAR:
10296 : /* case OMP_LIST_REDUCTION: */
10297 3 : gfc_error ("INTENT(IN) POINTER %qs in %s clause at %L",
10298 : n->sym->name, name, &n->where);
10299 3 : break;
10300 : default:
10301 : break;
10302 : }
10303 20280 : if (omp_clauses->detach
10304 3 : && (list == OMP_LIST_PRIVATE
10305 : || list == OMP_LIST_FIRSTPRIVATE
10306 : || list == OMP_LIST_LASTPRIVATE)
10307 3 : && n->sym == omp_clauses->detach->symtree->n.sym)
10308 1 : gfc_error ("DETACH event handle %qs in %s clause at %L",
10309 : n->sym->name, name, &n->where);
10310 :
10311 20280 : if (!openacc
10312 20280 : && (list == OMP_LIST_PRIVATE
10313 20280 : || list == OMP_LIST_FIRSTPRIVATE)
10314 4640 : && ((n->sym->ts.type == BT_DERIVED
10315 158 : && n->sym->ts.u.derived->attr.alloc_comp)
10316 4530 : || n->sym->ts.type == BT_CLASS))
10317 170 : switch (code->op)
10318 : {
10319 8 : case EXEC_OMP_TARGET:
10320 8 : case EXEC_OMP_TARGET_PARALLEL:
10321 8 : case EXEC_OMP_TARGET_PARALLEL_DO:
10322 8 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
10323 8 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
10324 8 : case EXEC_OMP_TARGET_SIMD:
10325 8 : case EXEC_OMP_TARGET_TEAMS:
10326 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
10327 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
10328 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10329 8 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
10330 8 : case EXEC_OMP_TARGET_TEAMS_LOOP:
10331 8 : if (n->sym->ts.type == BT_DERIVED
10332 2 : && n->sym->ts.u.derived->attr.alloc_comp)
10333 3 : gfc_error ("Sorry, list item %qs at %L with allocatable"
10334 : " components is not yet supported in %s "
10335 : "clause", n->sym->name, &n->where,
10336 : list == OMP_LIST_PRIVATE ? "PRIVATE"
10337 : : "FIRSTPRIVATE");
10338 : else
10339 9 : gfc_error ("Polymorphic list item %qs at %L in %s "
10340 : "clause has unspecified behavior and "
10341 : "unsupported", n->sym->name, &n->where,
10342 : list == OMP_LIST_PRIVATE ? "PRIVATE"
10343 : : "FIRSTPRIVATE");
10344 : break;
10345 : default:
10346 : break;
10347 : }
10348 :
10349 20280 : switch (list)
10350 : {
10351 104 : case OMP_LIST_REDUCTION_TASK:
10352 104 : if (code
10353 104 : && (code->op == EXEC_OMP_LOOP
10354 : || code->op == EXEC_OMP_TASKLOOP
10355 : || code->op == EXEC_OMP_TASKLOOP_SIMD
10356 : || code->op == EXEC_OMP_MASKED_TASKLOOP
10357 : || code->op == EXEC_OMP_MASKED_TASKLOOP_SIMD
10358 : || code->op == EXEC_OMP_MASTER_TASKLOOP
10359 : || code->op == EXEC_OMP_MASTER_TASKLOOP_SIMD
10360 : || code->op == EXEC_OMP_PARALLEL_LOOP
10361 : || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP
10362 : || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
10363 : || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP
10364 : || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
10365 : || code->op == EXEC_OMP_TARGET_PARALLEL_LOOP
10366 : || code->op == EXEC_OMP_TARGET_TEAMS_LOOP
10367 : || code->op == EXEC_OMP_TEAMS
10368 : || code->op == EXEC_OMP_TEAMS_DISTRIBUTE
10369 : || code->op == EXEC_OMP_TEAMS_LOOP))
10370 : {
10371 17 : gfc_error ("Only DEFAULT permitted as reduction-"
10372 : "modifier in REDUCTION clause at %L",
10373 : &n->where);
10374 17 : break;
10375 : }
10376 4786 : gcc_fallthrough ();
10377 4786 : case OMP_LIST_REDUCTION:
10378 4786 : case OMP_LIST_IN_REDUCTION:
10379 4786 : case OMP_LIST_TASK_REDUCTION:
10380 4786 : case OMP_LIST_REDUCTION_INSCAN:
10381 4786 : switch (n->u.reduction_op)
10382 : {
10383 2652 : case OMP_REDUCTION_PLUS:
10384 2652 : case OMP_REDUCTION_TIMES:
10385 2652 : case OMP_REDUCTION_MINUS:
10386 2652 : if (!gfc_numeric_ts (&n->sym->ts))
10387 : bad = true;
10388 : break;
10389 1112 : case OMP_REDUCTION_AND:
10390 1112 : case OMP_REDUCTION_OR:
10391 1112 : case OMP_REDUCTION_EQV:
10392 1112 : case OMP_REDUCTION_NEQV:
10393 1112 : if (n->sym->ts.type != BT_LOGICAL)
10394 : bad = true;
10395 : break;
10396 480 : case OMP_REDUCTION_MAX:
10397 480 : case OMP_REDUCTION_MIN:
10398 480 : if (n->sym->ts.type != BT_INTEGER
10399 212 : && n->sym->ts.type != BT_REAL)
10400 : bad = true;
10401 : break;
10402 192 : case OMP_REDUCTION_IAND:
10403 192 : case OMP_REDUCTION_IOR:
10404 192 : case OMP_REDUCTION_IEOR:
10405 192 : if (n->sym->ts.type != BT_INTEGER)
10406 : bad = true;
10407 : break;
10408 : case OMP_REDUCTION_USER:
10409 : bad = true;
10410 : break;
10411 : default:
10412 : break;
10413 : }
10414 : if (!bad)
10415 4215 : n->u2.udr = NULL;
10416 : else
10417 : {
10418 571 : const char *udr_name = NULL;
10419 571 : if (n->u2.udr)
10420 : {
10421 467 : udr_name = n->u2.udr->udr->name;
10422 467 : n->u2.udr->udr
10423 934 : = gfc_find_omp_udr (NULL, udr_name,
10424 467 : &n->sym->ts);
10425 467 : if (n->u2.udr->udr == NULL)
10426 : {
10427 0 : free (n->u2.udr);
10428 0 : n->u2.udr = NULL;
10429 : }
10430 : }
10431 571 : if (n->u2.udr == NULL)
10432 : {
10433 104 : if (udr_name == NULL)
10434 104 : switch (n->u.reduction_op)
10435 : {
10436 50 : case OMP_REDUCTION_PLUS:
10437 50 : case OMP_REDUCTION_TIMES:
10438 50 : case OMP_REDUCTION_MINUS:
10439 50 : case OMP_REDUCTION_AND:
10440 50 : case OMP_REDUCTION_OR:
10441 50 : case OMP_REDUCTION_EQV:
10442 50 : case OMP_REDUCTION_NEQV:
10443 50 : udr_name = gfc_op2string ((gfc_intrinsic_op)
10444 : n->u.reduction_op);
10445 50 : break;
10446 : case OMP_REDUCTION_MAX:
10447 : udr_name = "max";
10448 : break;
10449 9 : case OMP_REDUCTION_MIN:
10450 9 : udr_name = "min";
10451 9 : break;
10452 12 : case OMP_REDUCTION_IAND:
10453 12 : udr_name = "iand";
10454 12 : break;
10455 12 : case OMP_REDUCTION_IOR:
10456 12 : udr_name = "ior";
10457 12 : break;
10458 9 : case OMP_REDUCTION_IEOR:
10459 9 : udr_name = "ieor";
10460 9 : break;
10461 0 : default:
10462 0 : gcc_unreachable ();
10463 : }
10464 104 : gfc_error ("!$OMP DECLARE REDUCTION %s not found "
10465 : "for type %s at %L", udr_name,
10466 104 : gfc_typename (&n->sym->ts), &n->where);
10467 : }
10468 : else
10469 : {
10470 467 : gfc_omp_udr *udr = n->u2.udr->udr;
10471 467 : n->u.reduction_op = OMP_REDUCTION_USER;
10472 467 : n->u2.udr->combiner
10473 934 : = resolve_omp_udr_clause (n, udr->combiner_ns,
10474 467 : udr->omp_out,
10475 467 : udr->omp_in);
10476 467 : if (udr->initializer_ns)
10477 330 : n->u2.udr->initializer
10478 330 : = resolve_omp_udr_clause (n,
10479 : udr->initializer_ns,
10480 330 : udr->omp_priv,
10481 330 : udr->omp_orig);
10482 : }
10483 : }
10484 : break;
10485 874 : case OMP_LIST_LINEAR:
10486 874 : if (code)
10487 : {
10488 727 : bool is_worksharing_for = false;
10489 727 : switch (code->op)
10490 : {
10491 54 : case EXEC_OMP_DO:
10492 54 : case EXEC_OMP_PARALLEL_DO:
10493 54 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
10494 54 : case EXEC_OMP_TARGET_PARALLEL_DO:
10495 54 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
10496 54 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
10497 54 : is_worksharing_for = true;
10498 54 : break;
10499 : default:
10500 : break;
10501 : }
10502 :
10503 54 : if (is_worksharing_for
10504 54 : && (n->sym->attr.dimension
10505 53 : || n->sym->attr.allocatable))
10506 : {
10507 1 : if (n->sym->attr.allocatable)
10508 0 : gfc_error ("Sorry, ALLOCATABLE object %qs in "
10509 : "LINEAR clause on worksharing-loop "
10510 : "construct at %L is not yet supported",
10511 : n->sym->name, &n->where);
10512 : else
10513 1 : gfc_error ("Sorry, array %qs in LINEAR clause "
10514 : "on worksharing-loop construct at %L "
10515 : "is not yet supported",
10516 : n->sym->name, &n->where);
10517 : break;
10518 : }
10519 : }
10520 :
10521 726 : if (code
10522 726 : && n->u.linear.op != OMP_LINEAR_DEFAULT
10523 23 : && n->u.linear.op != linear_op)
10524 : {
10525 23 : if (n->u.linear.old_modifier)
10526 : {
10527 9 : gfc_error ("LINEAR clause modifier used on DO or "
10528 : "SIMD construct at %L", &n->where);
10529 9 : linear_op = n->u.linear.op;
10530 : }
10531 14 : else if (n->u.linear.op != OMP_LINEAR_VAL)
10532 : {
10533 6 : gfc_error ("LINEAR clause modifier other than VAL "
10534 : "used on DO or SIMD construct at %L",
10535 : &n->where);
10536 6 : linear_op = n->u.linear.op;
10537 : }
10538 : }
10539 850 : else if (n->u.linear.op != OMP_LINEAR_REF
10540 800 : && n->sym->ts.type != BT_INTEGER)
10541 1 : gfc_error ("LINEAR variable %qs must be INTEGER "
10542 : "at %L", n->sym->name, &n->where);
10543 849 : else if ((n->u.linear.op == OMP_LINEAR_REF
10544 799 : || n->u.linear.op == OMP_LINEAR_UVAL)
10545 61 : && n->sym->attr.value)
10546 0 : gfc_error ("LINEAR dummy argument %qs with VALUE "
10547 : "attribute with %s modifier at %L",
10548 : n->sym->name,
10549 : n->u.linear.op == OMP_LINEAR_REF
10550 : ? "REF" : "UVAL", &n->where);
10551 849 : else if (n->expr)
10552 : {
10553 830 : gfc_expr *expr = n->expr;
10554 830 : if (!gfc_resolve_expr (expr)
10555 830 : || expr->ts.type != BT_INTEGER
10556 1660 : || expr->rank != 0)
10557 0 : gfc_error ("%qs in LINEAR clause at %L requires "
10558 : "a scalar integer linear-step expression",
10559 0 : n->sym->name, &n->where);
10560 830 : else if (!code && expr->expr_type != EXPR_CONSTANT)
10561 : {
10562 11 : if (expr->expr_type == EXPR_VARIABLE
10563 7 : && expr->symtree->n.sym->attr.dummy
10564 6 : && expr->symtree->n.sym->ns == ns)
10565 : {
10566 6 : gfc_omp_namelist *n2;
10567 6 : for (n2 = omp_clauses->lists[OMP_LIST_UNIFORM];
10568 6 : n2; n2 = n2->next)
10569 6 : if (n2->sym == expr->symtree->n.sym)
10570 : break;
10571 6 : if (n2)
10572 : break;
10573 : }
10574 5 : gfc_error ("%qs in LINEAR clause at %L requires "
10575 : "a constant integer linear-step "
10576 : "expression or dummy argument "
10577 : "specified in UNIFORM clause",
10578 5 : n->sym->name, &n->where);
10579 : }
10580 : }
10581 : break;
10582 : /* Workaround for PR middle-end/26316, nothing really needs
10583 : to be done here for OMP_LIST_PRIVATE. */
10584 9390 : case OMP_LIST_PRIVATE:
10585 9390 : gcc_assert (code && code->op != EXEC_NOP);
10586 : break;
10587 98 : case OMP_LIST_USE_DEVICE:
10588 98 : if (n->sym->attr.allocatable
10589 98 : || (n->sym->ts.type == BT_CLASS && CLASS_DATA (n->sym)
10590 0 : && CLASS_DATA (n->sym)->attr.allocatable))
10591 0 : gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
10592 : n->sym->name, name, &n->where);
10593 98 : if (n->sym->ts.type == BT_CLASS
10594 0 : && CLASS_DATA (n->sym)
10595 0 : && CLASS_DATA (n->sym)->attr.class_pointer)
10596 0 : gfc_error ("POINTER object %qs of polymorphic type in "
10597 : "%s clause at %L", n->sym->name, name,
10598 : &n->where);
10599 98 : if (n->sym->attr.cray_pointer)
10600 2 : gfc_error ("Cray pointer object %qs in %s clause at %L",
10601 : n->sym->name, name, &n->where);
10602 96 : else if (n->sym->attr.cray_pointee)
10603 2 : gfc_error ("Cray pointee object %qs in %s clause at %L",
10604 : n->sym->name, name, &n->where);
10605 94 : else if (n->sym->attr.flavor == FL_VARIABLE
10606 93 : && !n->sym->as
10607 54 : && !n->sym->attr.pointer)
10608 13 : gfc_error ("%s clause variable %qs at %L is neither "
10609 : "a POINTER nor an array", name,
10610 : n->sym->name, &n->where);
10611 : /* FALLTHRU */
10612 98 : case OMP_LIST_DEVICE_RESIDENT:
10613 98 : check_symbol_not_pointer (n->sym, n->where, name);
10614 98 : check_array_not_assumed (n->sym, n->where, name);
10615 98 : break;
10616 : default:
10617 : break;
10618 : }
10619 : }
10620 : break;
10621 : }
10622 : }
10623 : /* OpenMP 5.1: use_device_ptr acts like use_device_addr, except for
10624 : type(c_ptr). */
10625 32198 : if (omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR])
10626 : {
10627 9 : gfc_omp_namelist *n_prev, *n_next, *n_addr;
10628 9 : n_addr = omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR];
10629 28 : for (; n_addr && n_addr->next; n_addr = n_addr->next)
10630 : ;
10631 : n_prev = NULL;
10632 : n = omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR];
10633 27 : while (n)
10634 : {
10635 18 : n_next = n->next;
10636 18 : if (n->sym->ts.type != BT_DERIVED
10637 18 : || n->sym->ts.u.derived->ts.f90_type != BT_VOID)
10638 : {
10639 0 : n->next = NULL;
10640 0 : if (n_addr)
10641 0 : n_addr->next = n;
10642 : else
10643 0 : omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] = n;
10644 0 : n_addr = n;
10645 0 : if (n_prev)
10646 0 : n_prev->next = n_next;
10647 : else
10648 0 : omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] = n_next;
10649 : }
10650 : else
10651 : n_prev = n;
10652 : n = n_next;
10653 : }
10654 : }
10655 32198 : if (omp_clauses->safelen_expr)
10656 93 : resolve_positive_int_expr (omp_clauses->safelen_expr, "SAFELEN");
10657 32198 : if (omp_clauses->simdlen_expr)
10658 123 : resolve_positive_int_expr (omp_clauses->simdlen_expr, "SIMDLEN");
10659 32198 : if (omp_clauses->num_teams_lower)
10660 21 : resolve_positive_int_expr (omp_clauses->num_teams_lower, "NUM_TEAMS");
10661 32198 : if (omp_clauses->num_teams_upper)
10662 127 : resolve_positive_int_expr (omp_clauses->num_teams_upper, "NUM_TEAMS");
10663 32198 : if (omp_clauses->num_teams_lower
10664 21 : && omp_clauses->num_teams_lower->expr_type == EXPR_CONSTANT
10665 7 : && omp_clauses->num_teams_upper->expr_type == EXPR_CONSTANT
10666 7 : && mpz_cmp (omp_clauses->num_teams_lower->value.integer,
10667 7 : omp_clauses->num_teams_upper->value.integer) > 0)
10668 2 : gfc_warning (OPT_Wopenmp, "NUM_TEAMS lower bound at %L larger than upper "
10669 : "bound at %L", &omp_clauses->num_teams_lower->where,
10670 : &omp_clauses->num_teams_upper->where);
10671 32198 : if (omp_clauses->device)
10672 331 : resolve_scalar_int_expr (omp_clauses->device, "DEVICE");
10673 32198 : if (omp_clauses->filter)
10674 42 : resolve_nonnegative_int_expr (omp_clauses->filter, "FILTER");
10675 32198 : if (omp_clauses->hint)
10676 : {
10677 42 : resolve_scalar_int_expr (omp_clauses->hint, "HINT");
10678 42 : if (omp_clauses->hint->ts.type != BT_INTEGER
10679 40 : || omp_clauses->hint->expr_type != EXPR_CONSTANT
10680 38 : || mpz_sgn (omp_clauses->hint->value.integer) < 0)
10681 5 : gfc_error ("Value of HINT clause at %L shall be a valid "
10682 : "constant hint expression", &omp_clauses->hint->where);
10683 : }
10684 32198 : if (omp_clauses->priority)
10685 34 : resolve_nonnegative_int_expr (omp_clauses->priority, "PRIORITY");
10686 32198 : if (omp_clauses->dist_chunk_size)
10687 : {
10688 83 : gfc_expr *expr = omp_clauses->dist_chunk_size;
10689 83 : if (!gfc_resolve_expr (expr)
10690 83 : || expr->ts.type != BT_INTEGER || expr->rank != 0)
10691 0 : gfc_error ("DIST_SCHEDULE clause's chunk_size at %L requires "
10692 : "a scalar INTEGER expression", &expr->where);
10693 : }
10694 32198 : if (omp_clauses->thread_limit)
10695 72 : resolve_positive_int_expr (omp_clauses->thread_limit, "THREAD_LIMIT");
10696 32198 : if (omp_clauses->grainsize)
10697 34 : resolve_positive_int_expr (omp_clauses->grainsize, "GRAINSIZE");
10698 32198 : if (omp_clauses->num_tasks)
10699 26 : resolve_positive_int_expr (omp_clauses->num_tasks, "NUM_TASKS");
10700 32198 : if (omp_clauses->grainsize && omp_clauses->num_tasks)
10701 1 : gfc_error ("%<GRAINSIZE%> clause at %L must not be used together with "
10702 : "%<NUM_TASKS%> clause", &omp_clauses->grainsize->where);
10703 32198 : if (omp_clauses->lists[OMP_LIST_REDUCTION] && omp_clauses->nogroup)
10704 1 : gfc_error ("%<REDUCTION%> clause at %L must not be used together with "
10705 : "%<NOGROUP%> clause",
10706 : &omp_clauses->lists[OMP_LIST_REDUCTION]->where);
10707 32198 : if (omp_clauses->full && omp_clauses->partial)
10708 0 : gfc_error ("%<FULL%> clause at %C must not be used together with "
10709 : "%<PARTIAL%> clause");
10710 32198 : if (omp_clauses->async)
10711 610 : if (omp_clauses->async_expr)
10712 610 : resolve_scalar_int_expr (omp_clauses->async_expr, "ASYNC");
10713 32198 : if (omp_clauses->num_gangs_expr)
10714 682 : resolve_positive_int_expr (omp_clauses->num_gangs_expr, "NUM_GANGS");
10715 32198 : if (omp_clauses->num_workers_expr)
10716 599 : resolve_positive_int_expr (omp_clauses->num_workers_expr, "NUM_WORKERS");
10717 32198 : if (omp_clauses->vector_length_expr)
10718 569 : resolve_positive_int_expr (omp_clauses->vector_length_expr,
10719 : "VECTOR_LENGTH");
10720 32198 : if (omp_clauses->gang_num_expr)
10721 114 : resolve_positive_int_expr (omp_clauses->gang_num_expr, "GANG");
10722 32198 : if (omp_clauses->gang_static_expr)
10723 94 : resolve_positive_int_expr (omp_clauses->gang_static_expr, "GANG");
10724 32198 : if (omp_clauses->worker_expr)
10725 101 : resolve_positive_int_expr (omp_clauses->worker_expr, "WORKER");
10726 32198 : if (omp_clauses->vector_expr)
10727 132 : resolve_positive_int_expr (omp_clauses->vector_expr, "VECTOR");
10728 32537 : for (el = omp_clauses->wait_list; el; el = el->next)
10729 339 : resolve_scalar_int_expr (el->expr, "WAIT");
10730 32198 : if (omp_clauses->collapse && omp_clauses->tile_list)
10731 4 : gfc_error ("Incompatible use of TILE and COLLAPSE at %L", &code->loc);
10732 32198 : if (omp_clauses->message)
10733 : {
10734 45 : gfc_expr *expr = omp_clauses->message;
10735 45 : if (!gfc_resolve_expr (expr)
10736 45 : || expr->ts.kind != gfc_default_character_kind
10737 87 : || expr->ts.type != BT_CHARACTER || expr->rank != 0)
10738 4 : gfc_error ("MESSAGE clause at %L requires a scalar default-kind "
10739 : "CHARACTER expression", &expr->where);
10740 : }
10741 32198 : if (!openacc
10742 32198 : && code
10743 19355 : && omp_clauses->lists[OMP_LIST_MAP] == NULL
10744 15884 : && omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] == NULL
10745 15881 : && omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] == NULL)
10746 : {
10747 15858 : const char *p = NULL;
10748 15858 : switch (code->op)
10749 : {
10750 1 : case EXEC_OMP_TARGET_ENTER_DATA: p = "TARGET ENTER DATA"; break;
10751 1 : case EXEC_OMP_TARGET_EXIT_DATA: p = "TARGET EXIT DATA"; break;
10752 : default: break;
10753 : }
10754 15858 : if (code->op == EXEC_OMP_TARGET_DATA)
10755 1 : gfc_error ("TARGET DATA must contain at least one MAP, USE_DEVICE_PTR, "
10756 : "or USE_DEVICE_ADDR clause at %L", &code->loc);
10757 15857 : else if (p)
10758 2 : gfc_error ("%s must contain at least one MAP clause at %L",
10759 : p, &code->loc);
10760 : }
10761 32198 : if (omp_clauses->sizes_list)
10762 : {
10763 : gfc_expr_list *el;
10764 572 : for (el = omp_clauses->sizes_list; el; el = el->next)
10765 : {
10766 377 : resolve_scalar_int_expr (el->expr, "SIZES");
10767 377 : if (el->expr->expr_type != EXPR_CONSTANT)
10768 1 : gfc_error ("SIZES requires constant expression at %L",
10769 : &el->expr->where);
10770 376 : else if (el->expr->expr_type == EXPR_CONSTANT
10771 376 : && el->expr->ts.type == BT_INTEGER
10772 376 : && mpz_sgn (el->expr->value.integer) <= 0)
10773 2 : gfc_error ("INTEGER expression of %s clause at %L must be "
10774 : "positive", "SIZES", &el->expr->where);
10775 : }
10776 : }
10777 :
10778 32198 : if (!openacc && omp_clauses->detach)
10779 : {
10780 125 : if (!gfc_resolve_expr (omp_clauses->detach)
10781 125 : || omp_clauses->detach->ts.type != BT_INTEGER
10782 124 : || omp_clauses->detach->ts.kind != gfc_c_intptr_kind
10783 248 : || omp_clauses->detach->rank != 0)
10784 3 : gfc_error ("%qs at %L should be a scalar of type "
10785 : "integer(kind=omp_event_handle_kind)",
10786 3 : omp_clauses->detach->symtree->n.sym->name,
10787 3 : &omp_clauses->detach->where);
10788 122 : else if (omp_clauses->detach->symtree->n.sym->attr.dimension > 0)
10789 1 : gfc_error ("The event handle at %L must not be an array element",
10790 : &omp_clauses->detach->where);
10791 121 : else if (omp_clauses->detach->symtree->n.sym->ts.type == BT_DERIVED
10792 120 : || omp_clauses->detach->symtree->n.sym->ts.type == BT_CLASS)
10793 1 : gfc_error ("The event handle at %L must not be part of "
10794 : "a derived type or class", &omp_clauses->detach->where);
10795 :
10796 125 : if (omp_clauses->mergeable)
10797 2 : gfc_error ("%<DETACH%> clause at %L must not be used together with "
10798 2 : "%<MERGEABLE%> clause", &omp_clauses->detach->where);
10799 : }
10800 :
10801 12625 : if (openacc
10802 12625 : && code->op == EXEC_OACC_HOST_DATA
10803 60 : && omp_clauses->lists[OMP_LIST_USE_DEVICE] == NULL)
10804 1 : gfc_error ("%<host_data%> construct at %L requires %<use_device%> clause",
10805 : &code->loc);
10806 :
10807 32198 : if (omp_clauses->assume)
10808 16 : gfc_resolve_omp_assumptions (omp_clauses->assume);
10809 : }
10810 :
10811 :
10812 : /* Return true if SYM is ever referenced in EXPR except in the SE node. */
10813 :
10814 : static bool
10815 4991 : expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
10816 : {
10817 6617 : gfc_actual_arglist *arg;
10818 6617 : if (e == NULL || e == se)
10819 : return false;
10820 5366 : switch (e->expr_type)
10821 : {
10822 3120 : case EXPR_CONSTANT:
10823 3120 : case EXPR_NULL:
10824 3120 : case EXPR_VARIABLE:
10825 3120 : case EXPR_STRUCTURE:
10826 3120 : case EXPR_ARRAY:
10827 3120 : if (e->symtree != NULL
10828 1152 : && e->symtree->n.sym == s)
10829 : return true;
10830 : return false;
10831 0 : case EXPR_SUBSTRING:
10832 0 : if (e->ref != NULL
10833 0 : && (expr_references_sym (e->ref->u.ss.start, s, se)
10834 0 : || expr_references_sym (e->ref->u.ss.end, s, se)))
10835 0 : return true;
10836 : return false;
10837 1735 : case EXPR_OP:
10838 1735 : if (expr_references_sym (e->value.op.op2, s, se))
10839 : return true;
10840 1626 : return expr_references_sym (e->value.op.op1, s, se);
10841 511 : case EXPR_FUNCTION:
10842 896 : for (arg = e->value.function.actual; arg; arg = arg->next)
10843 586 : if (expr_references_sym (arg->expr, s, se))
10844 : return true;
10845 : return false;
10846 0 : default:
10847 0 : gcc_unreachable ();
10848 : }
10849 : }
10850 :
10851 :
10852 : /* If EXPR is a conversion function that widens the type
10853 : if WIDENING is true or narrows the type if NARROW is true,
10854 : return the inner expression, otherwise return NULL. */
10855 :
10856 : static gfc_expr *
10857 5911 : is_conversion (gfc_expr *expr, bool narrowing, bool widening)
10858 : {
10859 5911 : gfc_typespec *ts1, *ts2;
10860 :
10861 5911 : if (expr->expr_type != EXPR_FUNCTION
10862 917 : || expr->value.function.isym == NULL
10863 894 : || expr->value.function.esym != NULL
10864 894 : || expr->value.function.isym->id != GFC_ISYM_CONVERSION
10865 388 : || (!narrowing && !widening))
10866 : return NULL;
10867 :
10868 388 : if (narrowing && widening)
10869 267 : return expr->value.function.actual->expr;
10870 :
10871 121 : if (widening)
10872 : {
10873 121 : ts1 = &expr->ts;
10874 121 : ts2 = &expr->value.function.actual->expr->ts;
10875 : }
10876 : else
10877 : {
10878 0 : ts1 = &expr->value.function.actual->expr->ts;
10879 0 : ts2 = &expr->ts;
10880 : }
10881 :
10882 121 : if (ts1->type > ts2->type
10883 49 : || (ts1->type == ts2->type && ts1->kind > ts2->kind))
10884 121 : return expr->value.function.actual->expr;
10885 :
10886 : return NULL;
10887 : }
10888 :
10889 : static bool
10890 6855 : is_scalar_intrinsic_expr (gfc_expr *expr, bool must_be_var, bool conv_ok)
10891 : {
10892 6855 : if (must_be_var
10893 4020 : && (expr->expr_type != EXPR_VARIABLE || !expr->symtree))
10894 : {
10895 37 : if (!conv_ok)
10896 : return false;
10897 37 : gfc_expr *conv = is_conversion (expr, true, true);
10898 37 : if (!conv)
10899 : return false;
10900 36 : if (conv->expr_type != EXPR_VARIABLE || !conv->symtree)
10901 : return false;
10902 : }
10903 6852 : return (expr->rank == 0
10904 6848 : && !gfc_is_coindexed (expr)
10905 13700 : && (expr->ts.type == BT_INTEGER
10906 : || expr->ts.type == BT_REAL
10907 : || expr->ts.type == BT_COMPLEX
10908 : || expr->ts.type == BT_LOGICAL));
10909 : }
10910 :
10911 : static void
10912 2697 : resolve_omp_atomic (gfc_code *code)
10913 : {
10914 2697 : gfc_code *atomic_code = code->block;
10915 2697 : gfc_symbol *var;
10916 2697 : gfc_expr *stmt_expr2, *capt_expr2;
10917 2697 : gfc_omp_atomic_op aop
10918 2697 : = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op
10919 : & GFC_OMP_ATOMIC_MASK);
10920 2697 : gfc_code *stmt = NULL, *capture_stmt = NULL, *tailing_stmt = NULL;
10921 2697 : gfc_expr *comp_cond = NULL;
10922 2697 : locus *loc = NULL;
10923 :
10924 2697 : code = code->block->next;
10925 : /* resolve_blocks asserts this is initially EXEC_ASSIGN or EXEC_IF
10926 : If it changed to EXEC_NOP, assume an error has been emitted already. */
10927 2697 : if (code->op == EXEC_NOP)
10928 : return;
10929 :
10930 2696 : if (atomic_code->ext.omp_clauses->compare
10931 156 : && atomic_code->ext.omp_clauses->capture)
10932 : {
10933 : /* Must be either "if (x == e) then; x = d; else; v = x; end if"
10934 : or "v = expr" followed/preceded by
10935 : "if (x == e) then; x = d; end if" or "if (x == e) x = d". */
10936 103 : gfc_code *next = code;
10937 103 : if (code->op == EXEC_ASSIGN)
10938 : {
10939 19 : capture_stmt = code;
10940 19 : next = code->next;
10941 : }
10942 103 : if (next->op == EXEC_IF
10943 103 : && next->block
10944 103 : && next->block->op == EXEC_IF
10945 103 : && next->block->next
10946 102 : && next->block->next->op == EXEC_ASSIGN)
10947 : {
10948 102 : comp_cond = next->block->expr1;
10949 102 : stmt = next->block->next;
10950 102 : if (stmt->next)
10951 : {
10952 0 : loc = &stmt->loc;
10953 0 : goto unexpected;
10954 : }
10955 : }
10956 1 : else if (capture_stmt)
10957 : {
10958 0 : gfc_error ("Expected IF at %L in atomic compare capture",
10959 : &next->loc);
10960 0 : return;
10961 : }
10962 103 : if (stmt && !capture_stmt && next->block->block)
10963 : {
10964 64 : if (next->block->block->expr1)
10965 : {
10966 0 : gfc_error ("Expected ELSE at %L in atomic compare capture",
10967 : &next->block->block->expr1->where);
10968 0 : return;
10969 : }
10970 64 : if (!code->block->block->next
10971 64 : || code->block->block->next->op != EXEC_ASSIGN)
10972 : {
10973 0 : loc = (code->block->block->next ? &code->block->block->next->loc
10974 : : &code->block->block->loc);
10975 0 : goto unexpected;
10976 : }
10977 64 : capture_stmt = code->block->block->next;
10978 64 : if (capture_stmt->next)
10979 : {
10980 0 : loc = &capture_stmt->next->loc;
10981 0 : goto unexpected;
10982 : }
10983 : }
10984 103 : if (stmt && !capture_stmt && next->next->op == EXEC_ASSIGN)
10985 : capture_stmt = next->next;
10986 84 : else if (!capture_stmt)
10987 : {
10988 1 : loc = &code->loc;
10989 1 : goto unexpected;
10990 : }
10991 : }
10992 2593 : else if (atomic_code->ext.omp_clauses->compare)
10993 : {
10994 : /* Must be: "if (x == e) then; x = d; end if" or "if (x == e) x = d". */
10995 53 : if (code->op == EXEC_IF
10996 53 : && code->block
10997 53 : && code->block->op == EXEC_IF
10998 53 : && code->block->next
10999 51 : && code->block->next->op == EXEC_ASSIGN)
11000 : {
11001 51 : comp_cond = code->block->expr1;
11002 51 : stmt = code->block->next;
11003 51 : if (stmt->next || code->block->block)
11004 : {
11005 0 : loc = stmt->next ? &stmt->next->loc : &code->block->block->loc;
11006 0 : goto unexpected;
11007 : }
11008 : }
11009 : else
11010 : {
11011 2 : loc = &code->loc;
11012 2 : goto unexpected;
11013 : }
11014 : }
11015 2540 : else if (atomic_code->ext.omp_clauses->capture)
11016 : {
11017 : /* Must be: "v = x" followed/preceded by "x = ...". */
11018 489 : if (code->op != EXEC_ASSIGN)
11019 0 : goto unexpected;
11020 489 : if (code->next->op != EXEC_ASSIGN)
11021 : {
11022 0 : loc = &code->next->loc;
11023 0 : goto unexpected;
11024 : }
11025 489 : gfc_expr *expr2, *expr2_next;
11026 489 : expr2 = is_conversion (code->expr2, true, true);
11027 489 : if (expr2 == NULL)
11028 447 : expr2 = code->expr2;
11029 489 : expr2_next = is_conversion (code->next->expr2, true, true);
11030 489 : if (expr2_next == NULL)
11031 478 : expr2_next = code->next->expr2;
11032 489 : if (code->expr1->expr_type == EXPR_VARIABLE
11033 489 : && code->next->expr1->expr_type == EXPR_VARIABLE
11034 489 : && expr2->expr_type == EXPR_VARIABLE
11035 243 : && expr2_next->expr_type == EXPR_VARIABLE)
11036 : {
11037 1 : if (code->expr1->symtree->n.sym == expr2_next->symtree->n.sym)
11038 : {
11039 : stmt = code;
11040 : capture_stmt = code->next;
11041 : }
11042 : else
11043 : {
11044 489 : capture_stmt = code;
11045 489 : stmt = code->next;
11046 : }
11047 : }
11048 488 : else if (expr2->expr_type == EXPR_VARIABLE)
11049 : {
11050 : capture_stmt = code;
11051 : stmt = code->next;
11052 : }
11053 : else
11054 : {
11055 247 : stmt = code;
11056 247 : capture_stmt = code->next;
11057 : }
11058 : /* Shall be NULL but can happen for invalid code. */
11059 489 : tailing_stmt = code->next->next;
11060 : }
11061 : else
11062 : {
11063 : /* x = ... */
11064 2051 : stmt = code;
11065 2051 : if (!atomic_code->ext.omp_clauses->compare && stmt->op != EXEC_ASSIGN)
11066 1 : goto unexpected;
11067 : /* Shall be NULL but can happen for invalid code. */
11068 2050 : tailing_stmt = code->next;
11069 : }
11070 :
11071 2692 : if (comp_cond)
11072 : {
11073 153 : if (comp_cond->expr_type != EXPR_OP
11074 153 : || (comp_cond->value.op.op != INTRINSIC_EQ
11075 : && comp_cond->value.op.op != INTRINSIC_EQ_OS
11076 : && comp_cond->value.op.op != INTRINSIC_EQV))
11077 : {
11078 0 : gfc_error ("Expected %<==%>, %<.EQ.%> or %<.EQV.%> atomic comparison "
11079 : "expression at %L", &comp_cond->where);
11080 0 : return;
11081 : }
11082 153 : if (!is_scalar_intrinsic_expr (comp_cond->value.op.op1, true, true))
11083 : {
11084 1 : gfc_error ("Expected scalar intrinsic variable at %L in atomic "
11085 1 : "comparison", &comp_cond->value.op.op1->where);
11086 1 : return;
11087 : }
11088 152 : if (!gfc_resolve_expr (comp_cond->value.op.op2))
11089 : return;
11090 152 : if (!is_scalar_intrinsic_expr (comp_cond->value.op.op2, false, false))
11091 : {
11092 0 : gfc_error ("Expected scalar intrinsic expression at %L in atomic "
11093 0 : "comparison", &comp_cond->value.op.op1->where);
11094 0 : return;
11095 : }
11096 : }
11097 :
11098 2691 : if (!is_scalar_intrinsic_expr (stmt->expr1, true, false))
11099 : {
11100 4 : gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
11101 4 : "intrinsic type at %L", &stmt->expr1->where);
11102 4 : return;
11103 : }
11104 :
11105 2687 : if (!gfc_resolve_expr (stmt->expr2))
11106 : return;
11107 2683 : if (!is_scalar_intrinsic_expr (stmt->expr2, false, false))
11108 : {
11109 0 : gfc_error ("!$OMP ATOMIC statement must assign an expression of "
11110 0 : "intrinsic type at %L", &stmt->expr2->where);
11111 0 : return;
11112 : }
11113 :
11114 2683 : if (gfc_expr_attr (stmt->expr1).allocatable)
11115 : {
11116 0 : gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L",
11117 0 : &stmt->expr1->where);
11118 0 : return;
11119 : }
11120 :
11121 : /* Should be diagnosed above already. */
11122 2683 : gcc_assert (tailing_stmt == NULL);
11123 :
11124 2683 : var = stmt->expr1->symtree->n.sym;
11125 2683 : stmt_expr2 = is_conversion (stmt->expr2, true, true);
11126 2683 : if (stmt_expr2 == NULL)
11127 2527 : stmt_expr2 = stmt->expr2;
11128 :
11129 2683 : switch (aop)
11130 : {
11131 503 : case GFC_OMP_ATOMIC_READ:
11132 503 : if (stmt_expr2->expr_type != EXPR_VARIABLE)
11133 0 : gfc_error ("!$OMP ATOMIC READ statement must read from a scalar "
11134 : "variable of intrinsic type at %L", &stmt_expr2->where);
11135 : return;
11136 421 : case GFC_OMP_ATOMIC_WRITE:
11137 421 : if (expr_references_sym (stmt_expr2, var, NULL))
11138 0 : gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr "
11139 : "must be scalar and cannot reference var at %L",
11140 : &stmt_expr2->where);
11141 : return;
11142 1759 : default:
11143 1759 : break;
11144 : }
11145 :
11146 1759 : if (atomic_code->ext.omp_clauses->capture)
11147 : {
11148 588 : if (!is_scalar_intrinsic_expr (capture_stmt->expr1, true, false))
11149 : {
11150 0 : gfc_error ("!$OMP ATOMIC capture-statement must set a scalar "
11151 : "variable of intrinsic type at %L",
11152 0 : &capture_stmt->expr1->where);
11153 0 : return;
11154 : }
11155 :
11156 588 : if (!is_scalar_intrinsic_expr (capture_stmt->expr2, true, true))
11157 : {
11158 2 : gfc_error ("!$OMP ATOMIC capture-statement requires a scalar variable"
11159 2 : " of intrinsic type at %L", &capture_stmt->expr2->where);
11160 2 : return;
11161 : }
11162 586 : capt_expr2 = is_conversion (capture_stmt->expr2, true, true);
11163 586 : if (capt_expr2 == NULL)
11164 564 : capt_expr2 = capture_stmt->expr2;
11165 :
11166 586 : if (capt_expr2->symtree->n.sym != var)
11167 : {
11168 1 : gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
11169 : "different variable than update statement writes "
11170 : "into at %L", &capture_stmt->expr2->where);
11171 1 : return;
11172 : }
11173 : }
11174 :
11175 1756 : if (atomic_code->ext.omp_clauses->compare)
11176 : {
11177 149 : gfc_expr *var_expr;
11178 149 : if (comp_cond->value.op.op1->expr_type == EXPR_VARIABLE)
11179 : var_expr = comp_cond->value.op.op1;
11180 : else
11181 12 : var_expr = comp_cond->value.op.op1->value.function.actual->expr;
11182 149 : if (var_expr->symtree->n.sym != var)
11183 : {
11184 2 : gfc_error ("For !$OMP ATOMIC COMPARE, the first operand in comparison"
11185 : " at %L must be the variable %qs that the update statement"
11186 : " writes into at %L", &var_expr->where, var->name,
11187 2 : &stmt->expr1->where);
11188 2 : return;
11189 : }
11190 147 : if (stmt_expr2->rank != 0 || expr_references_sym (stmt_expr2, var, NULL))
11191 : {
11192 1 : gfc_error ("expr in !$OMP ATOMIC COMPARE assignment var = expr "
11193 : "must be scalar and cannot reference var at %L",
11194 : &stmt_expr2->where);
11195 1 : return;
11196 : }
11197 : }
11198 1607 : else if (atomic_code->ext.omp_clauses->capture
11199 1607 : && !expr_references_sym (stmt_expr2, var, NULL))
11200 22 : atomic_code->ext.omp_clauses->atomic_op
11201 22 : = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op
11202 : | GFC_OMP_ATOMIC_SWAP);
11203 1585 : else if (stmt_expr2->expr_type == EXPR_OP)
11204 : {
11205 1229 : gfc_expr *v = NULL, *e, *c;
11206 1229 : gfc_intrinsic_op op = stmt_expr2->value.op.op;
11207 1229 : gfc_intrinsic_op alt_op = INTRINSIC_NONE;
11208 :
11209 1229 : if (atomic_code->ext.omp_clauses->fail != OMP_MEMORDER_UNSET)
11210 3 : gfc_error ("!$OMP ATOMIC UPDATE at %L with FAIL clause requires either"
11211 : " the COMPARE clause or using the intrinsic MIN/MAX "
11212 : "procedure", &atomic_code->loc);
11213 1229 : switch (op)
11214 : {
11215 742 : case INTRINSIC_PLUS:
11216 742 : alt_op = INTRINSIC_MINUS;
11217 742 : break;
11218 94 : case INTRINSIC_TIMES:
11219 94 : alt_op = INTRINSIC_DIVIDE;
11220 94 : break;
11221 120 : case INTRINSIC_MINUS:
11222 120 : alt_op = INTRINSIC_PLUS;
11223 120 : break;
11224 94 : case INTRINSIC_DIVIDE:
11225 94 : alt_op = INTRINSIC_TIMES;
11226 94 : break;
11227 : case INTRINSIC_AND:
11228 : case INTRINSIC_OR:
11229 : break;
11230 43 : case INTRINSIC_EQV:
11231 43 : alt_op = INTRINSIC_NEQV;
11232 43 : break;
11233 43 : case INTRINSIC_NEQV:
11234 43 : alt_op = INTRINSIC_EQV;
11235 43 : break;
11236 1 : default:
11237 1 : gfc_error ("!$OMP ATOMIC assignment operator must be binary "
11238 : "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
11239 : &stmt_expr2->where);
11240 1 : return;
11241 : }
11242 :
11243 : /* Check for var = var op expr resp. var = expr op var where
11244 : expr doesn't reference var and var op expr is mathematically
11245 : equivalent to var op (expr) resp. expr op var equivalent to
11246 : (expr) op var. We rely here on the fact that the matcher
11247 : for x op1 y op2 z where op1 and op2 have equal precedence
11248 : returns (x op1 y) op2 z. */
11249 1228 : e = stmt_expr2->value.op.op2;
11250 1228 : if (e->expr_type == EXPR_VARIABLE
11251 288 : && e->symtree != NULL
11252 288 : && e->symtree->n.sym == var)
11253 : v = e;
11254 999 : else if ((c = is_conversion (e, false, true)) != NULL
11255 48 : && c->expr_type == EXPR_VARIABLE
11256 48 : && c->symtree != NULL
11257 1047 : && c->symtree->n.sym == var)
11258 : v = c;
11259 : else
11260 : {
11261 951 : gfc_expr **p = NULL, **q;
11262 1049 : for (q = &stmt_expr2->value.op.op1; (e = *q) != NULL; )
11263 1049 : if (e->expr_type == EXPR_VARIABLE
11264 948 : && e->symtree != NULL
11265 948 : && e->symtree->n.sym == var)
11266 : {
11267 : v = e;
11268 : break;
11269 : }
11270 101 : else if ((c = is_conversion (e, false, true)) != NULL)
11271 60 : q = &e->value.function.actual->expr;
11272 41 : else if (e->expr_type != EXPR_OP
11273 41 : || (e->value.op.op != op
11274 15 : && e->value.op.op != alt_op)
11275 38 : || e->rank != 0)
11276 : break;
11277 : else
11278 : {
11279 38 : p = q;
11280 38 : q = &e->value.op.op1;
11281 : }
11282 :
11283 951 : if (v == NULL)
11284 : {
11285 3 : gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
11286 : "or var = expr op var at %L", &stmt_expr2->where);
11287 3 : return;
11288 : }
11289 :
11290 948 : if (p != NULL)
11291 : {
11292 38 : e = *p;
11293 38 : switch (e->value.op.op)
11294 : {
11295 8 : case INTRINSIC_MINUS:
11296 8 : case INTRINSIC_DIVIDE:
11297 8 : case INTRINSIC_EQV:
11298 8 : case INTRINSIC_NEQV:
11299 8 : gfc_error ("!$OMP ATOMIC var = var op expr not "
11300 : "mathematically equivalent to var = var op "
11301 : "(expr) at %L", &stmt_expr2->where);
11302 8 : break;
11303 : default:
11304 : break;
11305 : }
11306 :
11307 : /* Canonicalize into var = var op (expr). */
11308 38 : *p = e->value.op.op2;
11309 38 : e->value.op.op2 = stmt_expr2;
11310 38 : e->ts = stmt_expr2->ts;
11311 38 : if (stmt->expr2 == stmt_expr2)
11312 26 : stmt->expr2 = stmt_expr2 = e;
11313 : else
11314 12 : stmt->expr2->value.function.actual->expr = stmt_expr2 = e;
11315 :
11316 38 : if (!gfc_compare_types (&stmt_expr2->value.op.op1->ts,
11317 : &stmt_expr2->ts))
11318 : {
11319 24 : for (p = &stmt_expr2->value.op.op1; *p != v;
11320 12 : p = &(*p)->value.function.actual->expr)
11321 : ;
11322 12 : *p = NULL;
11323 12 : gfc_free_expr (stmt_expr2->value.op.op1);
11324 12 : stmt_expr2->value.op.op1 = v;
11325 12 : gfc_convert_type (v, &stmt_expr2->ts, 2);
11326 : }
11327 : }
11328 : }
11329 :
11330 1225 : if (e->rank != 0 || expr_references_sym (stmt->expr2, var, v))
11331 : {
11332 1 : gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
11333 : "must be scalar and cannot reference var at %L",
11334 : &stmt_expr2->where);
11335 1 : return;
11336 : }
11337 : }
11338 356 : else if (stmt_expr2->expr_type == EXPR_FUNCTION
11339 355 : && stmt_expr2->value.function.isym != NULL
11340 355 : && stmt_expr2->value.function.esym == NULL
11341 355 : && stmt_expr2->value.function.actual != NULL
11342 355 : && stmt_expr2->value.function.actual->next != NULL)
11343 : {
11344 355 : gfc_actual_arglist *arg, *var_arg;
11345 :
11346 355 : switch (stmt_expr2->value.function.isym->id)
11347 : {
11348 : case GFC_ISYM_MIN:
11349 : case GFC_ISYM_MAX:
11350 : break;
11351 147 : case GFC_ISYM_IAND:
11352 147 : case GFC_ISYM_IOR:
11353 147 : case GFC_ISYM_IEOR:
11354 147 : if (stmt_expr2->value.function.actual->next->next != NULL)
11355 : {
11356 0 : gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
11357 : "or IEOR must have two arguments at %L",
11358 : &stmt_expr2->where);
11359 0 : return;
11360 : }
11361 : break;
11362 1 : default:
11363 1 : gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
11364 : "MIN, MAX, IAND, IOR or IEOR at %L",
11365 : &stmt_expr2->where);
11366 1 : return;
11367 : }
11368 :
11369 : var_arg = NULL;
11370 1088 : for (arg = stmt_expr2->value.function.actual; arg; arg = arg->next)
11371 : {
11372 741 : gfc_expr *e = NULL;
11373 741 : if (arg == stmt_expr2->value.function.actual
11374 387 : || (var_arg == NULL && arg->next == NULL))
11375 : {
11376 527 : e = is_conversion (arg->expr, false, true);
11377 527 : if (!e)
11378 514 : e = arg->expr;
11379 527 : if (e->expr_type == EXPR_VARIABLE
11380 453 : && e->symtree != NULL
11381 453 : && e->symtree->n.sym == var)
11382 741 : var_arg = arg;
11383 : }
11384 741 : if ((!var_arg || !e) && expr_references_sym (arg->expr, var, NULL))
11385 : {
11386 7 : gfc_error ("!$OMP ATOMIC intrinsic arguments except one must "
11387 : "not reference %qs at %L",
11388 : var->name, &arg->expr->where);
11389 7 : return;
11390 : }
11391 734 : if (arg->expr->rank != 0)
11392 : {
11393 0 : gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
11394 : "at %L", &arg->expr->where);
11395 0 : return;
11396 : }
11397 : }
11398 :
11399 347 : if (var_arg == NULL)
11400 : {
11401 1 : gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
11402 : "be %qs at %L", var->name, &stmt_expr2->where);
11403 1 : return;
11404 : }
11405 :
11406 346 : if (var_arg != stmt_expr2->value.function.actual)
11407 : {
11408 : /* Canonicalize, so that var comes first. */
11409 172 : gcc_assert (var_arg->next == NULL);
11410 : for (arg = stmt_expr2->value.function.actual;
11411 185 : arg->next != var_arg; arg = arg->next)
11412 : ;
11413 172 : var_arg->next = stmt_expr2->value.function.actual;
11414 172 : stmt_expr2->value.function.actual = var_arg;
11415 172 : arg->next = NULL;
11416 : }
11417 : }
11418 : else
11419 1 : gfc_error ("!$OMP ATOMIC assignment must have an operator or "
11420 : "intrinsic on right hand side at %L", &stmt_expr2->where);
11421 : return;
11422 :
11423 4 : unexpected:
11424 4 : gfc_error ("unexpected !$OMP ATOMIC expression at %L",
11425 : loc ? loc : &code->loc);
11426 4 : return;
11427 : }
11428 :
11429 :
11430 : static struct fortran_omp_context
11431 : {
11432 : gfc_code *code;
11433 : hash_set<gfc_symbol *> *sharing_clauses;
11434 : hash_set<gfc_symbol *> *private_iterators;
11435 : struct fortran_omp_context *previous;
11436 : bool is_openmp;
11437 : } *omp_current_ctx;
11438 : static gfc_code *omp_current_do_code;
11439 : static int omp_current_do_collapse;
11440 :
11441 : /* Forward declaration for mutually recursive functions. */
11442 : static gfc_code *
11443 : find_nested_loop_in_block (gfc_code *block);
11444 :
11445 : /* Return the first nested DO loop in CHAIN, or NULL if there
11446 : isn't one. Does no error checking on intervening code. */
11447 :
11448 : static gfc_code *
11449 27482 : find_nested_loop_in_chain (gfc_code *chain)
11450 : {
11451 27482 : gfc_code *code;
11452 :
11453 27482 : if (!chain)
11454 : return NULL;
11455 :
11456 31643 : for (code = chain; code; code = code->next)
11457 31222 : switch (code->op)
11458 : {
11459 : case EXEC_DO:
11460 : case EXEC_OMP_TILE:
11461 : case EXEC_OMP_UNROLL:
11462 : return code;
11463 621 : case EXEC_BLOCK:
11464 621 : if (gfc_code *c = find_nested_loop_in_block (code))
11465 : return c;
11466 : break;
11467 : default:
11468 : break;
11469 : }
11470 : return NULL;
11471 : }
11472 :
11473 : /* Return the first nested DO loop in BLOCK, or NULL if there
11474 : isn't one. Does no error checking on intervening code. */
11475 : static gfc_code *
11476 939 : find_nested_loop_in_block (gfc_code *block)
11477 : {
11478 939 : gfc_namespace *ns;
11479 939 : gcc_assert (block->op == EXEC_BLOCK);
11480 939 : ns = block->ext.block.ns;
11481 939 : gcc_assert (ns);
11482 939 : return find_nested_loop_in_chain (ns->code);
11483 : }
11484 :
11485 : void
11486 5420 : gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
11487 : {
11488 5420 : if (code->block->next && code->block->next->op == EXEC_DO)
11489 : {
11490 5067 : int i;
11491 :
11492 5067 : omp_current_do_code = code->block->next;
11493 5067 : if (code->ext.omp_clauses->orderedc)
11494 142 : omp_current_do_collapse = code->ext.omp_clauses->orderedc;
11495 4925 : else if (code->ext.omp_clauses->collapse)
11496 1121 : omp_current_do_collapse = code->ext.omp_clauses->collapse;
11497 3804 : else if (code->ext.omp_clauses->sizes_list)
11498 175 : omp_current_do_collapse
11499 175 : = gfc_expr_list_len (code->ext.omp_clauses->sizes_list);
11500 : else
11501 3629 : omp_current_do_collapse = 1;
11502 5067 : if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
11503 : {
11504 : /* Checking that there is a matching EXEC_OMP_SCAN in the
11505 : innermost body cannot be deferred to resolve_omp_do because
11506 : we process directives nested in the loop before we get
11507 : there. */
11508 60 : locus *loc
11509 : = &code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where;
11510 60 : gfc_code *c;
11511 :
11512 80 : for (i = 1, c = omp_current_do_code;
11513 80 : i < omp_current_do_collapse; i++)
11514 : {
11515 22 : c = find_nested_loop_in_chain (c->block->next);
11516 22 : if (!c || c->op != EXEC_DO || c->block == NULL)
11517 : break;
11518 : }
11519 :
11520 : /* Skip this if we don't have enough nested loops. That
11521 : problem will be diagnosed elsewhere. */
11522 60 : if (c && c->op == EXEC_DO)
11523 : {
11524 58 : gfc_code *block = c->block ? c->block->next : NULL;
11525 58 : if (block && block->op != EXEC_OMP_SCAN)
11526 54 : while (block && block->next
11527 54 : && block->next->op != EXEC_OMP_SCAN)
11528 : block = block->next;
11529 43 : if (!block
11530 46 : || (block->op != EXEC_OMP_SCAN
11531 43 : && (!block->next || block->next->op != EXEC_OMP_SCAN)))
11532 19 : gfc_error ("With INSCAN at %L, expected loop body with "
11533 : "!$OMP SCAN between two "
11534 : "structured block sequences", loc);
11535 : else
11536 : {
11537 39 : if (block->op == EXEC_OMP_SCAN)
11538 3 : gfc_warning (OPT_Wopenmp,
11539 : "!$OMP SCAN at %L with zero executable "
11540 : "statements in preceding structured block "
11541 : "sequence", &block->loc);
11542 39 : if ((block->op == EXEC_OMP_SCAN && !block->next)
11543 38 : || (block->next && block->next->op == EXEC_OMP_SCAN
11544 36 : && !block->next->next))
11545 3 : gfc_warning (OPT_Wopenmp,
11546 : "!$OMP SCAN at %L with zero executable "
11547 : "statements in succeeding structured block "
11548 : "sequence", block->op == EXEC_OMP_SCAN
11549 1 : ? &block->loc : &block->next->loc);
11550 : }
11551 58 : if (block && block->op != EXEC_OMP_SCAN)
11552 43 : block = block->next;
11553 46 : if (block && block->op == EXEC_OMP_SCAN)
11554 : /* Mark 'omp scan' as checked; flag will be unset later. */
11555 39 : block->ext.omp_clauses->if_present = true;
11556 : }
11557 : }
11558 : }
11559 5420 : gfc_resolve_blocks (code->block, ns);
11560 5420 : omp_current_do_collapse = 0;
11561 5420 : omp_current_do_code = NULL;
11562 5420 : }
11563 :
11564 :
11565 : void
11566 6031 : gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
11567 : {
11568 6031 : struct fortran_omp_context ctx;
11569 6031 : gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
11570 6031 : gfc_omp_namelist *n;
11571 :
11572 6031 : ctx.code = code;
11573 6031 : ctx.sharing_clauses = new hash_set<gfc_symbol *>;
11574 6031 : ctx.private_iterators = new hash_set<gfc_symbol *>;
11575 6031 : ctx.previous = omp_current_ctx;
11576 6031 : ctx.is_openmp = true;
11577 6031 : omp_current_ctx = &ctx;
11578 :
11579 241240 : for (enum gfc_omp_list_type list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
11580 235209 : list = gfc_omp_list_type (list + 1))
11581 235209 : switch (list)
11582 : {
11583 60310 : case OMP_LIST_SHARED:
11584 60310 : case OMP_LIST_PRIVATE:
11585 60310 : case OMP_LIST_FIRSTPRIVATE:
11586 60310 : case OMP_LIST_LASTPRIVATE:
11587 60310 : case OMP_LIST_REDUCTION:
11588 60310 : case OMP_LIST_REDUCTION_INSCAN:
11589 60310 : case OMP_LIST_REDUCTION_TASK:
11590 60310 : case OMP_LIST_IN_REDUCTION:
11591 60310 : case OMP_LIST_TASK_REDUCTION:
11592 60310 : case OMP_LIST_LINEAR:
11593 69267 : for (n = omp_clauses->lists[list]; n; n = n->next)
11594 8957 : ctx.sharing_clauses->add (n->sym);
11595 : break;
11596 : default:
11597 : break;
11598 : }
11599 :
11600 6031 : switch (code->op)
11601 : {
11602 2357 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
11603 2357 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
11604 2357 : case EXEC_OMP_MASKED_TASKLOOP:
11605 2357 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
11606 2357 : case EXEC_OMP_MASTER_TASKLOOP:
11607 2357 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
11608 2357 : case EXEC_OMP_PARALLEL_DO:
11609 2357 : case EXEC_OMP_PARALLEL_DO_SIMD:
11610 2357 : case EXEC_OMP_PARALLEL_LOOP:
11611 2357 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
11612 2357 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
11613 2357 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
11614 2357 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
11615 2357 : case EXEC_OMP_TARGET_PARALLEL_DO:
11616 2357 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
11617 2357 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
11618 2357 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
11619 2357 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
11620 2357 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
11621 2357 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
11622 2357 : case EXEC_OMP_TARGET_TEAMS_LOOP:
11623 2357 : case EXEC_OMP_TASKLOOP:
11624 2357 : case EXEC_OMP_TASKLOOP_SIMD:
11625 2357 : case EXEC_OMP_TEAMS_DISTRIBUTE:
11626 2357 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
11627 2357 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
11628 2357 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
11629 2357 : case EXEC_OMP_TEAMS_LOOP:
11630 2357 : gfc_resolve_omp_do_blocks (code, ns);
11631 2357 : break;
11632 3674 : default:
11633 3674 : gfc_resolve_blocks (code->block, ns);
11634 : }
11635 :
11636 6031 : omp_current_ctx = ctx.previous;
11637 12062 : delete ctx.sharing_clauses;
11638 12062 : delete ctx.private_iterators;
11639 6031 : }
11640 :
11641 :
11642 : /* Save and clear openmp.cc private state. */
11643 :
11644 : void
11645 286164 : gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *state)
11646 : {
11647 286164 : state->ptrs[0] = omp_current_ctx;
11648 286164 : state->ptrs[1] = omp_current_do_code;
11649 286164 : state->ints[0] = omp_current_do_collapse;
11650 286164 : omp_current_ctx = NULL;
11651 286164 : omp_current_do_code = NULL;
11652 286164 : omp_current_do_collapse = 0;
11653 286164 : }
11654 :
11655 :
11656 : /* Restore openmp.cc private state from the saved state. */
11657 :
11658 : void
11659 286163 : gfc_omp_restore_state (struct gfc_omp_saved_state *state)
11660 : {
11661 286163 : omp_current_ctx = (struct fortran_omp_context *) state->ptrs[0];
11662 286163 : omp_current_do_code = (gfc_code *) state->ptrs[1];
11663 286163 : omp_current_do_collapse = state->ints[0];
11664 286163 : }
11665 :
11666 :
11667 : /* Note a DO iterator variable. This is special in !$omp parallel
11668 : construct, where they are predetermined private. */
11669 :
11670 : void
11671 32821 : gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym, bool add_clause)
11672 : {
11673 32821 : if (omp_current_ctx == NULL)
11674 : return;
11675 :
11676 13094 : int i = omp_current_do_collapse;
11677 13094 : gfc_code *c = omp_current_do_code;
11678 :
11679 13094 : if (sym->attr.threadprivate)
11680 : return;
11681 :
11682 : /* !$omp do and !$omp parallel do iteration variable is predetermined
11683 : private just in the !$omp do resp. !$omp parallel do construct,
11684 : with no implications for the outer parallel constructs. */
11685 :
11686 17929 : while (i-- >= 1 && c)
11687 : {
11688 9490 : if (code == c)
11689 : return;
11690 4835 : c = find_nested_loop_in_chain (c->block->next);
11691 4835 : if (c && (c->op == EXEC_OMP_TILE || c->op == EXEC_OMP_UNROLL))
11692 : return;
11693 : }
11694 :
11695 : /* An openacc context may represent a data clause. Abort if so. */
11696 8439 : if (!omp_current_ctx->is_openmp && !oacc_is_loop (omp_current_ctx->code))
11697 : return;
11698 :
11699 7461 : if (omp_current_ctx->sharing_clauses->contains (sym))
11700 : return;
11701 :
11702 6459 : if (! omp_current_ctx->private_iterators->add (sym) && add_clause)
11703 : {
11704 6272 : gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses;
11705 6272 : gfc_omp_namelist *p;
11706 :
11707 6272 : p = gfc_get_omp_namelist ();
11708 6272 : p->sym = sym;
11709 6272 : p->where = omp_current_ctx->code->loc;
11710 6272 : p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
11711 6272 : omp_clauses->lists[OMP_LIST_PRIVATE] = p;
11712 : }
11713 : }
11714 :
11715 : static void
11716 698 : handle_local_var (gfc_symbol *sym)
11717 : {
11718 698 : if (sym->attr.flavor != FL_VARIABLE
11719 178 : || sym->as != NULL
11720 137 : || (sym->ts.type != BT_INTEGER && sym->ts.type != BT_REAL))
11721 : return;
11722 71 : gfc_resolve_do_iterator (sym->ns->code, sym, false);
11723 : }
11724 :
11725 : void
11726 332159 : gfc_resolve_omp_local_vars (gfc_namespace *ns)
11727 : {
11728 332159 : if (omp_current_ctx)
11729 452 : gfc_traverse_ns (ns, handle_local_var);
11730 332159 : }
11731 :
11732 :
11733 : /* Error checking on intervening code uses a code walker. */
11734 :
11735 : struct icode_error_state
11736 : {
11737 : const char *name;
11738 : bool errorp;
11739 : gfc_code *nested;
11740 : gfc_code *next;
11741 : };
11742 :
11743 : static int
11744 944 : icode_code_error_callback (gfc_code **codep,
11745 : int *walk_subtrees ATTRIBUTE_UNUSED, void *opaque)
11746 : {
11747 944 : gfc_code *code = *codep;
11748 944 : icode_error_state *state = (icode_error_state *)opaque;
11749 :
11750 : /* gfc_code_walker walks down CODE's next chain as well as
11751 : walking things that are actually nested in CODE. We need to
11752 : special-case traversal of outer blocks, so stop immediately if we
11753 : are heading down such a next chain. */
11754 944 : if (code == state->next)
11755 : return 1;
11756 :
11757 647 : switch (code->op)
11758 : {
11759 1 : case EXEC_DO:
11760 1 : case EXEC_DO_WHILE:
11761 1 : case EXEC_DO_CONCURRENT:
11762 1 : gfc_error ("%s cannot contain loop in intervening code at %L",
11763 : state->name, &code->loc);
11764 1 : state->errorp = true;
11765 1 : break;
11766 0 : case EXEC_CYCLE:
11767 0 : case EXEC_EXIT:
11768 : /* Errors have already been diagnosed in match_exit_cycle. */
11769 0 : state->errorp = true;
11770 0 : break;
11771 : case EXEC_OMP_ASSUME:
11772 : case EXEC_OMP_METADIRECTIVE:
11773 : /* Per OpenMP 6.0, some non-executable directives are allowed in
11774 : intervening code. */
11775 : break;
11776 477 : case EXEC_CALL:
11777 : /* Per OpenMP 5.2, the "omp_" prefix is reserved, so we don't have to
11778 : consider the possibility that some locally-bound definition
11779 : overrides the runtime routine. */
11780 477 : if (code->resolved_sym
11781 477 : && omp_runtime_api_procname (code->resolved_sym->name))
11782 : {
11783 1 : gfc_error ("%s cannot contain OpenMP API call in intervening code "
11784 : "at %L",
11785 : state->name, &code->loc);
11786 1 : state->errorp = true;
11787 : }
11788 : break;
11789 168 : default:
11790 168 : if (code->op >= EXEC_OMP_FIRST_OPENMP_EXEC
11791 168 : && code->op <= EXEC_OMP_LAST_OPENMP_EXEC)
11792 : {
11793 2 : gfc_error ("%s cannot contain OpenMP directive in intervening code "
11794 : "at %L",
11795 : state->name, &code->loc);
11796 2 : state->errorp = true;
11797 : }
11798 : }
11799 : return 0;
11800 : }
11801 :
11802 : static int
11803 1081 : icode_expr_error_callback (gfc_expr **expr,
11804 : int *walk_subtrees ATTRIBUTE_UNUSED, void *opaque)
11805 : {
11806 1081 : icode_error_state *state = (icode_error_state *)opaque;
11807 :
11808 1081 : switch ((*expr)->expr_type)
11809 : {
11810 : /* As for EXPR_CALL with "omp_"-prefixed symbols. */
11811 2 : case EXPR_FUNCTION:
11812 2 : {
11813 2 : gfc_symbol *sym = (*expr)->value.function.esym;
11814 2 : if (sym && omp_runtime_api_procname (sym->name))
11815 : {
11816 1 : gfc_error ("%s cannot contain OpenMP API call in intervening code "
11817 : "at %L",
11818 1 : state->name, &((*expr)->where));
11819 1 : state->errorp = true;
11820 : }
11821 : }
11822 :
11823 : break;
11824 : default:
11825 : break;
11826 : }
11827 :
11828 : /* FIXME: The description of canonical loop form in the OpenMP standard
11829 : also says "array expressions" are not permitted in intervening code.
11830 : That term is not defined in either the OpenMP spec or the Fortran
11831 : standard, although the latter uses it informally to refer to any
11832 : expression that is not scalar-valued. It is also apparently not the
11833 : thing GCC internally calls EXPR_ARRAY. It seems the intent of the
11834 : OpenMP restriction is to disallow elemental operations/intrinsics
11835 : (including things that are not expressions, like assignment
11836 : statements) that generate implicit loops over array operands
11837 : (even if the result is a scalar), but even if the spec said
11838 : that there is no list of all the cases that would be forbidden.
11839 : This is OpenMP issue 3326. */
11840 :
11841 1081 : return 0;
11842 : }
11843 :
11844 : static void
11845 267 : diagnose_intervening_code_errors_1 (gfc_code *chain,
11846 : struct icode_error_state *state)
11847 : {
11848 267 : gfc_code *code;
11849 1080 : for (code = chain; code; code = code->next)
11850 : {
11851 813 : if (code == state->nested)
11852 : /* Do not walk the nested loop or its body, we are only
11853 : interested in intervening code. */
11854 : ;
11855 636 : else if (code->op == EXEC_BLOCK
11856 636 : && find_nested_loop_in_block (code) == state->nested)
11857 : /* This block contains the nested loop, recurse on its
11858 : statements. */
11859 : {
11860 90 : gfc_namespace* ns = code->ext.block.ns;
11861 90 : diagnose_intervening_code_errors_1 (ns->code, state);
11862 : }
11863 : else
11864 : /* Treat the whole statement as a unit. */
11865 : {
11866 546 : gfc_code *temp = state->next;
11867 546 : state->next = code->next;
11868 546 : gfc_code_walker (&code, icode_code_error_callback,
11869 : icode_expr_error_callback, state);
11870 546 : state->next = temp;
11871 : }
11872 : }
11873 267 : }
11874 :
11875 : /* Diagnose intervening code errors in BLOCK with nested loop NESTED.
11876 : NAME is the user-friendly name of the OMP directive, used for error
11877 : messages. Returns true if any error was found. */
11878 : static bool
11879 177 : diagnose_intervening_code_errors (gfc_code *chain, const char *name,
11880 : gfc_code *nested)
11881 : {
11882 177 : struct icode_error_state state;
11883 177 : state.name = name;
11884 177 : state.errorp = false;
11885 177 : state.nested = nested;
11886 177 : state.next = NULL;
11887 0 : diagnose_intervening_code_errors_1 (chain, &state);
11888 177 : return state.errorp;
11889 : }
11890 :
11891 : /* Helper function for restructure_intervening_code: wrap CHAIN in
11892 : a marker to indicate that it is a structured block sequence. That
11893 : information will be used later on (in omp-low.cc) for error checking. */
11894 : static gfc_code *
11895 461 : make_structured_block (gfc_code *chain)
11896 : {
11897 461 : gcc_assert (chain);
11898 461 : gfc_namespace *ns = gfc_build_block_ns (gfc_current_ns);
11899 461 : gfc_code *result = gfc_get_code (EXEC_BLOCK);
11900 461 : result->op = EXEC_BLOCK;
11901 461 : result->ext.block.ns = ns;
11902 461 : result->ext.block.assoc = NULL;
11903 461 : result->loc = chain->loc;
11904 461 : ns->omp_structured_block = 1;
11905 461 : ns->code = chain;
11906 461 : return result;
11907 : }
11908 :
11909 : /* Push intervening code surrounding a loop, including nested scopes,
11910 : into the body of the loop. CHAINP is the pointer to the head of
11911 : the next-chain to scan, OUTER_LOOP is the EXEC_DO for the next outer
11912 : loop level, and COLLAPSE is the number of nested loops we need to
11913 : process.
11914 : Note that CHAINP may point at outer_loop->block->next when we
11915 : are scanning the body of a loop, but if there is an intervening block
11916 : CHAINP points into the block's chain rather than its enclosing outer
11917 : loop. This is why OUTER_LOOP is passed separately. */
11918 : static gfc_code *
11919 7170 : restructure_intervening_code (gfc_code **chainp, gfc_code *outer_loop,
11920 : int count)
11921 : {
11922 7170 : gfc_code *code;
11923 7170 : gfc_code *head = *chainp;
11924 7170 : gfc_code *tail = NULL;
11925 7170 : gfc_code *innermost_loop = NULL;
11926 :
11927 7434 : for (code = *chainp; code; code = code->next, chainp = &(*chainp)->next)
11928 : {
11929 7434 : if (code->op == EXEC_DO)
11930 : {
11931 : /* Cut CODE free from its chain, leaving the ends dangling. */
11932 7086 : *chainp = NULL;
11933 7086 : tail = code->next;
11934 7086 : code->next = NULL;
11935 :
11936 7086 : if (count == 1)
11937 : innermost_loop = code;
11938 : else
11939 2090 : innermost_loop
11940 2090 : = restructure_intervening_code (&code->block->next,
11941 : code, count - 1);
11942 : break;
11943 : }
11944 348 : else if (code->op == EXEC_BLOCK
11945 348 : && find_nested_loop_in_block (code))
11946 : {
11947 84 : gfc_namespace *ns = code->ext.block.ns;
11948 :
11949 : /* Cut CODE free from its chain, leaving the ends dangling. */
11950 84 : *chainp = NULL;
11951 84 : tail = code->next;
11952 84 : code->next = NULL;
11953 :
11954 84 : innermost_loop
11955 84 : = restructure_intervening_code (&ns->code, outer_loop,
11956 : count);
11957 :
11958 : /* At this point we have already pulled out the nested loop and
11959 : pointed outer_loop at it, and moved the intervening code that
11960 : was previously in the block into the body of innermost_loop.
11961 : Now we want to move the BLOCK itself so it wraps the entire
11962 : current body of innermost_loop. */
11963 84 : ns->code = innermost_loop->block->next;
11964 84 : innermost_loop->block->next = code;
11965 84 : break;
11966 : }
11967 : }
11968 :
11969 2174 : gcc_assert (innermost_loop);
11970 :
11971 : /* Now we have split the intervening code into two parts:
11972 : head is the start of the part before the loop/block, terminating
11973 : at *chainp, and tail is the part after it. Mark each part as
11974 : a structured block sequence, and splice the two parts around the
11975 : existing body of the innermost loop. */
11976 7170 : if (head != code)
11977 : {
11978 222 : gfc_code *block = make_structured_block (head);
11979 222 : if (innermost_loop->block->next)
11980 221 : gfc_append_code (block, innermost_loop->block->next);
11981 222 : innermost_loop->block->next = block;
11982 : }
11983 7170 : if (tail)
11984 : {
11985 239 : gfc_code *block = make_structured_block (tail);
11986 239 : if (innermost_loop->block->next)
11987 237 : gfc_append_code (innermost_loop->block->next, block);
11988 : else
11989 2 : innermost_loop->block->next = block;
11990 : }
11991 :
11992 : /* For loops, finally splice CODE into OUTER_LOOP. We already handled
11993 : relinking EXEC_BLOCK above. */
11994 7170 : if (code->op == EXEC_DO && outer_loop)
11995 7086 : outer_loop->block->next = code;
11996 :
11997 7170 : return innermost_loop;
11998 : }
11999 :
12000 : /* CODE is an OMP loop construct. Return true if VAR matches an iteration
12001 : variable outer to level DEPTH. */
12002 : static bool
12003 8083 : is_outer_iteration_variable (gfc_code *code, int depth, gfc_symbol *var)
12004 : {
12005 8083 : int i;
12006 8083 : gfc_code *do_code = code;
12007 :
12008 12610 : for (i = 1; i < depth; i++)
12009 : {
12010 5028 : do_code = find_nested_loop_in_chain (do_code->block->next);
12011 5028 : gcc_assert (do_code);
12012 5028 : if (do_code->op == EXEC_OMP_TILE || do_code->op == EXEC_OMP_UNROLL)
12013 : {
12014 51 : --i;
12015 51 : continue;
12016 : }
12017 4977 : gfc_symbol *ivar = do_code->ext.iterator->var->symtree->n.sym;
12018 4977 : if (var == ivar)
12019 : return true;
12020 : }
12021 : return false;
12022 : }
12023 :
12024 : /* Forward declaration for recursive functions. */
12025 : static gfc_code *
12026 : check_nested_loop_in_block (gfc_code *block, gfc_expr *expr, gfc_symbol *sym,
12027 : bool *bad);
12028 :
12029 : /* Like find_nested_loop_in_chain, but additionally check that EXPR
12030 : does not reference any variables bound in intervening EXEC_BLOCKs
12031 : and that SYM is not bound in such intervening blocks. Either EXPR or SYM
12032 : may be null. Sets *BAD to true if either test fails. */
12033 : static gfc_code *
12034 48165 : check_nested_loop_in_chain (gfc_code *chain, gfc_expr *expr, gfc_symbol *sym,
12035 : bool *bad)
12036 : {
12037 51769 : for (gfc_code *code = chain; code; code = code->next)
12038 : {
12039 51481 : if (code->op == EXEC_DO)
12040 : return code;
12041 4123 : else if (code->op == EXEC_OMP_TILE || code->op == EXEC_OMP_UNROLL)
12042 1682 : return check_nested_loop_in_chain (code->block->next, expr, sym, bad);
12043 2441 : else if (code->op == EXEC_BLOCK)
12044 : {
12045 807 : gfc_code *c = check_nested_loop_in_block (code, expr, sym, bad);
12046 807 : if (c)
12047 : return c;
12048 : }
12049 : }
12050 : return NULL;
12051 : }
12052 :
12053 : /* Code walker for block symtrees. It doesn't take any kind of state
12054 : argument, so use a static variable. */
12055 : static struct check_nested_loop_in_block_state_t {
12056 : gfc_expr *expr;
12057 : gfc_symbol *sym;
12058 : bool *bad;
12059 : } check_nested_loop_in_block_state;
12060 :
12061 : static void
12062 766 : check_nested_loop_in_block_symbol (gfc_symbol *sym)
12063 : {
12064 766 : if (sym == check_nested_loop_in_block_state.sym
12065 766 : || (check_nested_loop_in_block_state.expr
12066 567 : && gfc_find_sym_in_expr (sym,
12067 : check_nested_loop_in_block_state.expr)))
12068 5 : *check_nested_loop_in_block_state.bad = true;
12069 766 : }
12070 :
12071 : /* Return the first nested DO loop in BLOCK, or NULL if there
12072 : isn't one. Set *BAD to true if EXPR references any variables in BLOCK, or
12073 : SYM is bound in BLOCK. Either EXPR or SYM may be null. */
12074 : static gfc_code *
12075 807 : check_nested_loop_in_block (gfc_code *block, gfc_expr *expr,
12076 : gfc_symbol *sym, bool *bad)
12077 : {
12078 807 : gfc_namespace *ns;
12079 807 : gcc_assert (block->op == EXEC_BLOCK);
12080 807 : ns = block->ext.block.ns;
12081 807 : gcc_assert (ns);
12082 :
12083 : /* Skip the check if this block doesn't contain the nested loop, or
12084 : if we already know it's bad. */
12085 807 : gfc_code *result = check_nested_loop_in_chain (ns->code, expr, sym, bad);
12086 807 : if (result && !*bad)
12087 : {
12088 519 : check_nested_loop_in_block_state.expr = expr;
12089 519 : check_nested_loop_in_block_state.sym = sym;
12090 519 : check_nested_loop_in_block_state.bad = bad;
12091 519 : gfc_traverse_ns (ns, check_nested_loop_in_block_symbol);
12092 519 : check_nested_loop_in_block_state.expr = NULL;
12093 519 : check_nested_loop_in_block_state.sym = NULL;
12094 519 : check_nested_loop_in_block_state.bad = NULL;
12095 : }
12096 807 : return result;
12097 : }
12098 :
12099 : /* CODE is an OMP loop construct. Return true if EXPR references
12100 : any variables bound in intervening code, to level DEPTH. */
12101 : static bool
12102 22717 : expr_uses_intervening_var (gfc_code *code, int depth, gfc_expr *expr)
12103 : {
12104 22717 : int i;
12105 22717 : gfc_code *do_code = code;
12106 :
12107 58213 : for (i = 0; i < depth; i++)
12108 : {
12109 35499 : bool bad = false;
12110 35499 : do_code = check_nested_loop_in_chain (do_code->block->next,
12111 : expr, NULL, &bad);
12112 35499 : if (bad)
12113 3 : return true;
12114 : }
12115 : return false;
12116 : }
12117 :
12118 : /* CODE is an OMP loop construct. Return true if SYM is bound in
12119 : intervening code, to level DEPTH. */
12120 : static bool
12121 7582 : is_intervening_var (gfc_code *code, int depth, gfc_symbol *sym)
12122 : {
12123 7582 : int i;
12124 7582 : gfc_code *do_code = code;
12125 :
12126 19439 : for (i = 0; i < depth; i++)
12127 : {
12128 11859 : bool bad = false;
12129 11859 : do_code = check_nested_loop_in_chain (do_code->block->next,
12130 : NULL, sym, &bad);
12131 11859 : if (bad)
12132 2 : return true;
12133 : }
12134 : return false;
12135 : }
12136 :
12137 : /* CODE is an OMP loop construct. Return true if EXPR does not reference
12138 : any iteration variables outer to level DEPTH. */
12139 : static bool
12140 23796 : expr_is_invariant (gfc_code *code, int depth, gfc_expr *expr)
12141 : {
12142 23796 : int i;
12143 23796 : gfc_code *do_code = code;
12144 :
12145 37118 : for (i = 1; i < depth; i++)
12146 : {
12147 14388 : do_code = find_nested_loop_in_chain (do_code->block->next);
12148 14388 : gcc_assert (do_code);
12149 14388 : if (do_code->op == EXEC_OMP_TILE || do_code->op == EXEC_OMP_UNROLL)
12150 : {
12151 136 : --i;
12152 136 : continue;
12153 : }
12154 14252 : gfc_symbol *ivar = do_code->ext.iterator->var->symtree->n.sym;
12155 14252 : if (gfc_find_sym_in_expr (ivar, expr))
12156 : return false;
12157 : }
12158 : return true;
12159 : }
12160 :
12161 : /* CODE is an OMP loop construct. Return true if EXPR matches one of the
12162 : canonical forms for a bound expression. It may include references to
12163 : an iteration variable outer to level DEPTH; set OUTER_VARP if so. */
12164 : static bool
12165 15155 : bound_expr_is_canonical (gfc_code *code, int depth, gfc_expr *expr,
12166 : gfc_symbol **outer_varp)
12167 : {
12168 15155 : gfc_expr *expr2 = NULL;
12169 :
12170 : /* Rectangular case. */
12171 15155 : if (depth == 0 || expr_is_invariant (code, depth, expr))
12172 14587 : return true;
12173 :
12174 : /* Any simple variable that didn't pass expr_is_invariant must be
12175 : an outer_var. */
12176 568 : if (expr->expr_type == EXPR_VARIABLE && expr->rank == 0)
12177 : {
12178 63 : *outer_varp = expr->symtree->n.sym;
12179 63 : return true;
12180 : }
12181 :
12182 : /* All other permitted forms are binary operators. */
12183 505 : if (expr->expr_type != EXPR_OP)
12184 : return false;
12185 :
12186 : /* Check for plus/minus a loop invariant expr. */
12187 503 : if (expr->value.op.op == INTRINSIC_PLUS
12188 503 : || expr->value.op.op == INTRINSIC_MINUS)
12189 : {
12190 483 : if (expr_is_invariant (code, depth, expr->value.op.op1))
12191 48 : expr2 = expr->value.op.op2;
12192 435 : else if (expr_is_invariant (code, depth, expr->value.op.op2))
12193 434 : expr2 = expr->value.op.op1;
12194 : else
12195 : return false;
12196 : }
12197 : else
12198 : expr2 = expr;
12199 :
12200 : /* Check for a product with a loop-invariant expr. */
12201 502 : if (expr2->expr_type == EXPR_OP
12202 96 : && expr2->value.op.op == INTRINSIC_TIMES)
12203 : {
12204 96 : if (expr_is_invariant (code, depth, expr2->value.op.op1))
12205 40 : expr2 = expr2->value.op.op2;
12206 56 : else if (expr_is_invariant (code, depth, expr2->value.op.op2))
12207 53 : expr2 = expr2->value.op.op1;
12208 : else
12209 : return false;
12210 : }
12211 :
12212 : /* What's left must be a reference to an outer loop variable. */
12213 499 : if (expr2->expr_type == EXPR_VARIABLE
12214 499 : && expr2->rank == 0
12215 998 : && is_outer_iteration_variable (code, depth, expr2->symtree->n.sym))
12216 : {
12217 499 : *outer_varp = expr2->symtree->n.sym;
12218 499 : return true;
12219 : }
12220 :
12221 : return false;
12222 : }
12223 :
12224 : static void
12225 5420 : resolve_omp_do (gfc_code *code)
12226 : {
12227 5420 : gfc_code *do_code, *next;
12228 5420 : int i, count, non_generated_count;
12229 5420 : gfc_omp_namelist *n;
12230 5420 : gfc_symbol *dovar;
12231 5420 : const char *name;
12232 5420 : bool is_simd = false;
12233 5420 : bool errorp = false;
12234 5420 : bool perfect_nesting_errorp = false;
12235 5420 : bool imperfect = false;
12236 :
12237 5420 : switch (code->op)
12238 : {
12239 : case EXEC_OMP_DISTRIBUTE: name = "!$OMP DISTRIBUTE"; break;
12240 49 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
12241 49 : name = "!$OMP DISTRIBUTE PARALLEL DO";
12242 49 : break;
12243 32 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
12244 32 : name = "!$OMP DISTRIBUTE PARALLEL DO SIMD";
12245 32 : is_simd = true;
12246 32 : break;
12247 50 : case EXEC_OMP_DISTRIBUTE_SIMD:
12248 50 : name = "!$OMP DISTRIBUTE SIMD";
12249 50 : is_simd = true;
12250 50 : break;
12251 1335 : case EXEC_OMP_DO: name = "!$OMP DO"; break;
12252 134 : case EXEC_OMP_DO_SIMD: name = "!$OMP DO SIMD"; is_simd = true; break;
12253 64 : case EXEC_OMP_LOOP: name = "!$OMP LOOP"; break;
12254 1216 : case EXEC_OMP_PARALLEL_DO: name = "!$OMP PARALLEL DO"; break;
12255 304 : case EXEC_OMP_PARALLEL_DO_SIMD:
12256 304 : name = "!$OMP PARALLEL DO SIMD";
12257 304 : is_simd = true;
12258 304 : break;
12259 46 : case EXEC_OMP_PARALLEL_LOOP: name = "!$OMP PARALLEL LOOP"; break;
12260 7 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
12261 7 : name = "!$OMP PARALLEL MASKED TASKLOOP";
12262 7 : break;
12263 10 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
12264 10 : name = "!$OMP PARALLEL MASKED TASKLOOP SIMD";
12265 10 : is_simd = true;
12266 10 : break;
12267 12 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
12268 12 : name = "!$OMP PARALLEL MASTER TASKLOOP";
12269 12 : break;
12270 18 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
12271 18 : name = "!$OMP PARALLEL MASTER TASKLOOP SIMD";
12272 18 : is_simd = true;
12273 18 : break;
12274 8 : case EXEC_OMP_MASKED_TASKLOOP: name = "!$OMP MASKED TASKLOOP"; break;
12275 14 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
12276 14 : name = "!$OMP MASKED TASKLOOP SIMD";
12277 14 : is_simd = true;
12278 14 : break;
12279 14 : case EXEC_OMP_MASTER_TASKLOOP: name = "!$OMP MASTER TASKLOOP"; break;
12280 19 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
12281 19 : name = "!$OMP MASTER TASKLOOP SIMD";
12282 19 : is_simd = true;
12283 19 : break;
12284 783 : case EXEC_OMP_SIMD: name = "!$OMP SIMD"; is_simd = true; break;
12285 88 : case EXEC_OMP_TARGET_PARALLEL_DO: name = "!$OMP TARGET PARALLEL DO"; break;
12286 19 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
12287 19 : name = "!$OMP TARGET PARALLEL DO SIMD";
12288 19 : is_simd = true;
12289 19 : break;
12290 16 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
12291 16 : name = "!$OMP TARGET PARALLEL LOOP";
12292 16 : break;
12293 33 : case EXEC_OMP_TARGET_SIMD:
12294 33 : name = "!$OMP TARGET SIMD";
12295 33 : is_simd = true;
12296 33 : break;
12297 20 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
12298 20 : name = "!$OMP TARGET TEAMS DISTRIBUTE";
12299 20 : break;
12300 75 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
12301 75 : name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
12302 75 : break;
12303 37 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12304 37 : name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
12305 37 : is_simd = true;
12306 37 : break;
12307 20 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
12308 20 : name = "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
12309 20 : is_simd = true;
12310 20 : break;
12311 19 : case EXEC_OMP_TARGET_TEAMS_LOOP: name = "!$OMP TARGET TEAMS LOOP"; break;
12312 69 : case EXEC_OMP_TASKLOOP: name = "!$OMP TASKLOOP"; break;
12313 38 : case EXEC_OMP_TASKLOOP_SIMD:
12314 38 : name = "!$OMP TASKLOOP SIMD";
12315 38 : is_simd = true;
12316 38 : break;
12317 20 : case EXEC_OMP_TEAMS_DISTRIBUTE: name = "!$OMP TEAMS DISTRIBUTE"; break;
12318 37 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
12319 37 : name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
12320 37 : break;
12321 60 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12322 60 : name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
12323 60 : is_simd = true;
12324 60 : break;
12325 42 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
12326 42 : name = "!$OMP TEAMS DISTRIBUTE SIMD";
12327 42 : is_simd = true;
12328 42 : break;
12329 48 : case EXEC_OMP_TEAMS_LOOP: name = "!$OMP TEAMS LOOP"; break;
12330 195 : case EXEC_OMP_TILE: name = "!$OMP TILE"; break;
12331 415 : case EXEC_OMP_UNROLL: name = "!$OMP UNROLL"; break;
12332 0 : default: gcc_unreachable ();
12333 : }
12334 :
12335 5420 : if (code->ext.omp_clauses)
12336 5420 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
12337 :
12338 5420 : if (code->op == EXEC_OMP_TILE && code->ext.omp_clauses->sizes_list == NULL)
12339 0 : gfc_error ("SIZES clause is required on !$OMP TILE construct at %L",
12340 : &code->loc);
12341 :
12342 5420 : do_code = code->block->next;
12343 5420 : if (code->ext.omp_clauses->orderedc)
12344 : count = code->ext.omp_clauses->orderedc;
12345 5276 : else if (code->ext.omp_clauses->sizes_list)
12346 195 : count = gfc_expr_list_len (code->ext.omp_clauses->sizes_list);
12347 : else
12348 : {
12349 5081 : count = code->ext.omp_clauses->collapse;
12350 5081 : if (count <= 0)
12351 : count = 1;
12352 : }
12353 :
12354 5420 : non_generated_count = count;
12355 : /* While the spec defines the loop nest depth independently of the COLLAPSE
12356 : clause, in practice the middle end only pays attention to the COLLAPSE
12357 : depth and treats any further inner loops as the final-loop-body. So
12358 : here we also check canonical loop nest form only for the number of
12359 : outer loops specified by the COLLAPSE clause too. */
12360 8060 : for (i = 1; i <= count; i++)
12361 : {
12362 8060 : gfc_symbol *start_var = NULL, *end_var = NULL;
12363 : /* Parse errors are not recoverable. */
12364 8060 : if (do_code->op == EXEC_DO_WHILE)
12365 : {
12366 6 : gfc_error ("%s cannot be a DO WHILE or DO without loop control "
12367 : "at %L", name, &do_code->loc);
12368 106 : goto fail;
12369 : }
12370 8054 : if (do_code->op == EXEC_DO_CONCURRENT)
12371 : {
12372 4 : gfc_error ("%s cannot be a DO CONCURRENT loop at %L", name,
12373 : &do_code->loc);
12374 4 : goto fail;
12375 : }
12376 8050 : if (do_code->op == EXEC_OMP_TILE || do_code->op == EXEC_OMP_UNROLL)
12377 : {
12378 466 : if (do_code->op == EXEC_OMP_UNROLL)
12379 : {
12380 308 : if (!do_code->ext.omp_clauses->partial)
12381 : {
12382 53 : gfc_error ("Generated loop of UNROLL construct at %L "
12383 : "without PARTIAL clause does not have "
12384 : "canonical form", &do_code->loc);
12385 53 : goto fail;
12386 : }
12387 255 : else if (i != count)
12388 : {
12389 5 : gfc_error ("UNROLL construct at %L with PARTIAL clause "
12390 : "generates just one loop with canonical form "
12391 : "but %d loops are needed",
12392 5 : &do_code->loc, count - i + 1);
12393 5 : goto fail;
12394 : }
12395 : }
12396 158 : else if (do_code->op == EXEC_OMP_TILE)
12397 : {
12398 158 : if (do_code->ext.omp_clauses->sizes_list == NULL)
12399 : /* This should have been diagnosed earlier already. */
12400 0 : return;
12401 158 : int l = gfc_expr_list_len (do_code->ext.omp_clauses->sizes_list);
12402 158 : if (count - i + 1 > l)
12403 : {
12404 14 : gfc_error ("TILE construct at %L generates %d loops "
12405 : "with canonical form but %d loops are needed",
12406 : &do_code->loc, l, count - i + 1);
12407 14 : goto fail;
12408 : }
12409 : }
12410 394 : if (do_code->ext.omp_clauses && do_code->ext.omp_clauses->erroneous)
12411 17 : goto fail;
12412 377 : if (imperfect && !perfect_nesting_errorp)
12413 : {
12414 4 : sorry_at (gfc_get_location (&do_code->loc),
12415 : "Imperfectly nested loop using generated loops");
12416 4 : errorp = true;
12417 : }
12418 377 : if (non_generated_count == count)
12419 329 : non_generated_count = i - 1;
12420 377 : --i;
12421 377 : do_code = do_code->block->next;
12422 377 : continue;
12423 377 : }
12424 7584 : gcc_assert (do_code->op == EXEC_DO);
12425 7584 : if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
12426 : {
12427 3 : gfc_error ("%s iteration variable must be of type integer at %L",
12428 : name, &do_code->loc);
12429 3 : errorp = true;
12430 : }
12431 7584 : dovar = do_code->ext.iterator->var->symtree->n.sym;
12432 7584 : if (dovar->attr.threadprivate)
12433 : {
12434 0 : gfc_error ("%s iteration variable must not be THREADPRIVATE "
12435 : "at %L", name, &do_code->loc);
12436 0 : errorp = true;
12437 : }
12438 7584 : if (code->ext.omp_clauses)
12439 303360 : for (enum gfc_omp_list_type list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
12440 295776 : list = gfc_omp_list_type (list + 1))
12441 97461 : if (!is_simd || code->ext.omp_clauses->collapse > 1
12442 295776 : ? (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE
12443 254670 : && list != OMP_LIST_ALLOCATE)
12444 41106 : : (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE
12445 41106 : && list != OMP_LIST_ALLOCATE && list != OMP_LIST_LINEAR))
12446 276351 : for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
12447 4381 : if (dovar == n->sym)
12448 : {
12449 5 : if (!is_simd || code->ext.omp_clauses->collapse > 1)
12450 4 : gfc_error ("%s iteration variable present on clause "
12451 : "other than PRIVATE, LASTPRIVATE or "
12452 : "ALLOCATE at %L", name, &do_code->loc);
12453 : else
12454 1 : gfc_error ("%s iteration variable present on clause "
12455 : "other than PRIVATE, LASTPRIVATE, ALLOCATE or "
12456 : "LINEAR at %L", name, &do_code->loc);
12457 : errorp = true;
12458 : }
12459 7584 : if (is_outer_iteration_variable (code, i, dovar))
12460 : {
12461 2 : gfc_error ("%s iteration variable used in more than one loop at %L",
12462 : name, &do_code->loc);
12463 2 : errorp = true;
12464 : }
12465 7582 : else if (is_intervening_var (code, i, dovar))
12466 : {
12467 2 : gfc_error ("%s iteration variable at %L is bound in "
12468 : "intervening code",
12469 : name, &do_code->loc);
12470 2 : errorp = true;
12471 : }
12472 7580 : else if (!bound_expr_is_canonical (code, i,
12473 7580 : do_code->ext.iterator->start,
12474 : &start_var))
12475 : {
12476 4 : gfc_error ("%s loop start expression not in canonical form at %L",
12477 : name, &do_code->loc);
12478 4 : errorp = true;
12479 : }
12480 7576 : else if (expr_uses_intervening_var (code, i,
12481 7576 : do_code->ext.iterator->start))
12482 : {
12483 1 : gfc_error ("%s loop start expression at %L uses variable bound in "
12484 : "intervening code",
12485 : name, &do_code->loc);
12486 1 : errorp = true;
12487 : }
12488 7575 : else if (!bound_expr_is_canonical (code, i,
12489 7575 : do_code->ext.iterator->end,
12490 : &end_var))
12491 : {
12492 2 : gfc_error ("%s loop end expression not in canonical form at %L",
12493 : name, &do_code->loc);
12494 2 : errorp = true;
12495 : }
12496 7573 : else if (expr_uses_intervening_var (code, i,
12497 7573 : do_code->ext.iterator->end))
12498 : {
12499 1 : gfc_error ("%s loop end expression at %L uses variable bound in "
12500 : "intervening code",
12501 : name, &do_code->loc);
12502 1 : errorp = true;
12503 : }
12504 7572 : else if (start_var && end_var && start_var != end_var)
12505 : {
12506 1 : gfc_error ("%s loop bounds reference different "
12507 : "iteration variables at %L", name, &do_code->loc);
12508 1 : errorp = true;
12509 : }
12510 7571 : else if (!expr_is_invariant (code, i, do_code->ext.iterator->step))
12511 : {
12512 3 : gfc_error ("%s loop increment not in canonical form at %L",
12513 : name, &do_code->loc);
12514 3 : errorp = true;
12515 : }
12516 7568 : else if (expr_uses_intervening_var (code, i,
12517 7568 : do_code->ext.iterator->step))
12518 : {
12519 1 : gfc_error ("%s loop increment expression at %L uses variable "
12520 : "bound in intervening code",
12521 : name, &do_code->loc);
12522 1 : errorp = true;
12523 : }
12524 7584 : if (start_var || end_var)
12525 : {
12526 528 : code->ext.omp_clauses->non_rectangular = 1;
12527 528 : if (i > non_generated_count)
12528 : {
12529 3 : sorry_at (gfc_get_location (&do_code->loc),
12530 : "Non-rectangular loops from generated loops "
12531 : "unsupported");
12532 3 : errorp = true;
12533 : }
12534 : }
12535 :
12536 : /* Only parse loop body into nested loop and intervening code if
12537 : there are supposed to be more loops in the nest to collapse. */
12538 7584 : if (i == count)
12539 : break;
12540 :
12541 2270 : next = find_nested_loop_in_chain (do_code->block->next);
12542 :
12543 2270 : if (!next)
12544 : {
12545 : /* Parse error, can't recover from this. */
12546 7 : gfc_error ("not enough DO loops for collapsed %s (level %d) at %L",
12547 : name, i, &code->loc);
12548 7 : goto fail;
12549 : }
12550 2263 : else if (next != do_code->block->next
12551 2103 : || (next->next && next->next->op != EXEC_CONTINUE))
12552 : /* Imperfectly nested loop found. */
12553 : {
12554 : /* Only diagnose violation of imperfect nesting constraints once. */
12555 177 : if (!perfect_nesting_errorp)
12556 : {
12557 176 : if (code->ext.omp_clauses->orderedc)
12558 : {
12559 3 : gfc_error ("%s inner loops must be perfectly nested with "
12560 : "ORDERED clause at %L",
12561 : name, &code->loc);
12562 3 : perfect_nesting_errorp = true;
12563 : }
12564 173 : else if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
12565 : {
12566 2 : gfc_error ("%s inner loops must be perfectly nested with "
12567 : "REDUCTION INSCAN clause at %L",
12568 : name, &code->loc);
12569 2 : perfect_nesting_errorp = true;
12570 : }
12571 171 : else if (code->op == EXEC_OMP_TILE)
12572 : {
12573 8 : gfc_error ("%s inner loops must be perfectly nested at %L",
12574 : name, &code->loc);
12575 8 : perfect_nesting_errorp = true;
12576 : }
12577 13 : if (perfect_nesting_errorp)
12578 : errorp = true;
12579 : }
12580 177 : if (diagnose_intervening_code_errors (do_code->block->next,
12581 : name, next))
12582 5 : errorp = true;
12583 : imperfect = true;
12584 : }
12585 2263 : do_code = next;
12586 : }
12587 :
12588 : /* Give up now if we found any constraint violations. */
12589 5314 : if (errorp)
12590 : {
12591 48 : fail:
12592 154 : if (code->ext.omp_clauses)
12593 154 : code->ext.omp_clauses->erroneous = 1;
12594 154 : return;
12595 : }
12596 :
12597 5266 : if (non_generated_count)
12598 4996 : restructure_intervening_code (&code->block->next, code,
12599 : non_generated_count);
12600 : }
12601 :
12602 : /* Resolve the context selector. In particular, SKIP_P is set to true,
12603 : the context can never be matched. */
12604 :
12605 : static void
12606 764 : gfc_resolve_omp_context_selector (gfc_omp_set_selector *oss,
12607 : bool is_metadirective, bool *skip_p)
12608 : {
12609 764 : if (skip_p)
12610 310 : *skip_p = false;
12611 1453 : for (gfc_omp_set_selector *set_selector = oss; set_selector;
12612 689 : set_selector = set_selector->next)
12613 1485 : for (gfc_omp_selector *os = set_selector->trait_selectors; os; os = os->next)
12614 : {
12615 814 : if (os->score)
12616 : {
12617 52 : if (!gfc_resolve_expr (os->score)
12618 52 : || os->score->ts.type != BT_INTEGER
12619 104 : || os->score->rank != 0)
12620 : {
12621 0 : gfc_error ("%<score%> argument must be constant integer "
12622 0 : "expression at %L", &os->score->where);
12623 0 : gfc_free_expr (os->score);
12624 0 : os->score = nullptr;
12625 : }
12626 52 : else if (os->score->expr_type == EXPR_CONSTANT
12627 52 : && mpz_sgn (os->score->value.integer) < 0)
12628 : {
12629 1 : gfc_error ("%<score%> argument must be non-negative at %L",
12630 : &os->score->where);
12631 1 : gfc_free_expr (os->score);
12632 1 : os->score = nullptr;
12633 : }
12634 : }
12635 :
12636 814 : if (os->code == OMP_TRAIT_INVALID)
12637 : break;
12638 796 : enum omp_tp_type property_kind = omp_ts_map[os->code].tp_type;
12639 796 : gfc_omp_trait_property *otp = os->properties;
12640 :
12641 796 : if (!otp)
12642 409 : continue;
12643 387 : switch (property_kind)
12644 : {
12645 139 : case OMP_TRAIT_PROPERTY_DEV_NUM_EXPR:
12646 139 : case OMP_TRAIT_PROPERTY_BOOL_EXPR:
12647 139 : if (!gfc_resolve_expr (otp->expr)
12648 138 : || (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR
12649 124 : && otp->expr->ts.type != BT_LOGICAL)
12650 137 : || (property_kind == OMP_TRAIT_PROPERTY_DEV_NUM_EXPR
12651 14 : && otp->expr->ts.type != BT_INTEGER)
12652 137 : || otp->expr->rank != 0
12653 276 : || (!is_metadirective && otp->expr->expr_type != EXPR_CONSTANT))
12654 : {
12655 3 : if (is_metadirective)
12656 : {
12657 0 : if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR)
12658 0 : gfc_error ("property must be a "
12659 : "logical expression at %L",
12660 0 : &otp->expr->where);
12661 : else
12662 0 : gfc_error ("property must be an "
12663 : "integer expression at %L",
12664 0 : &otp->expr->where);
12665 : }
12666 : else
12667 : {
12668 3 : if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR)
12669 2 : gfc_error ("property must be a constant "
12670 : "logical expression at %L",
12671 2 : &otp->expr->where);
12672 : else
12673 1 : gfc_error ("property must be a constant "
12674 : "integer expression at %L",
12675 1 : &otp->expr->where);
12676 : }
12677 : /* Prevent later ICEs. */
12678 3 : gfc_expr *e;
12679 3 : if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR)
12680 2 : e = gfc_get_logical_expr (gfc_default_logical_kind,
12681 2 : &otp->expr->where, true);
12682 : else
12683 1 : e = gfc_get_int_expr (gfc_default_integer_kind,
12684 1 : &otp->expr->where, 0);
12685 3 : gfc_free_expr (otp->expr);
12686 3 : otp->expr = e;
12687 3 : continue;
12688 3 : }
12689 : /* Device number must be conforming, which includes
12690 : omp_initial_device (-1), omp_invalid_device (-4),
12691 : and omp_default_device (-5). */
12692 136 : if (property_kind == OMP_TRAIT_PROPERTY_DEV_NUM_EXPR
12693 14 : && otp->expr->expr_type == EXPR_CONSTANT
12694 5 : && mpz_sgn (otp->expr->value.integer) < 0
12695 3 : && mpz_cmp_si (otp->expr->value.integer, -1) != 0
12696 2 : && mpz_cmp_si (otp->expr->value.integer, -4) != 0
12697 1 : && mpz_cmp_si (otp->expr->value.integer, -5) != 0)
12698 1 : gfc_error ("property must be a conforming device number at %L",
12699 : &otp->expr->where);
12700 : break;
12701 : default:
12702 : break;
12703 : }
12704 : /* This only handles one specific case: User condition.
12705 : FIXME: Handle more cases by calling omp_context_selector_matches;
12706 : unfortunately, we cannot generate the tree here as, e.g., PARM_DECL
12707 : backend decl are not available at this stage - but might be used in,
12708 : e.g. user conditions. See PR122361. */
12709 384 : if (skip_p && otp
12710 138 : && os->code == OMP_TRAIT_USER_CONDITION
12711 81 : && otp->expr->expr_type == EXPR_CONSTANT
12712 14 : && otp->expr->value.logical == false)
12713 12 : *skip_p = true;
12714 : }
12715 764 : }
12716 :
12717 :
12718 : static void
12719 138 : resolve_omp_metadirective (gfc_code *code, gfc_namespace *ns)
12720 : {
12721 138 : gfc_omp_variant *variant = code->ext.omp_variants;
12722 138 : gfc_omp_variant *prev_variant = variant;
12723 :
12724 448 : while (variant)
12725 : {
12726 310 : bool skip;
12727 310 : gfc_resolve_omp_context_selector (variant->selectors, true, &skip);
12728 310 : gfc_code *variant_code = variant->code;
12729 310 : gfc_resolve_code (variant_code, ns);
12730 310 : if (skip)
12731 : {
12732 : /* The following should only be true if an error occurred
12733 : as the 'otherwise' clause should always match. */
12734 12 : if (variant == code->ext.omp_variants && !variant->next)
12735 : break;
12736 12 : gfc_omp_variant *tmp = variant;
12737 12 : if (variant == code->ext.omp_variants)
12738 11 : variant = prev_variant = code->ext.omp_variants = variant->next;
12739 : else
12740 1 : variant = prev_variant->next = variant->next;
12741 12 : gfc_free_omp_set_selector_list (tmp->selectors);
12742 12 : free (tmp);
12743 : }
12744 : else
12745 : {
12746 298 : prev_variant = variant;
12747 298 : variant = variant->next;
12748 : }
12749 : }
12750 : /* Replace metadirective by its body if only 'nothing' remains. */
12751 138 : if (!code->ext.omp_variants->next && code->ext.omp_variants->stmt == ST_NONE)
12752 : {
12753 11 : gfc_code *next = code->next;
12754 11 : gfc_code *inner = code->ext.omp_variants->code;
12755 11 : gfc_free_omp_set_selector_list (code->ext.omp_variants->selectors);
12756 11 : free (code->ext.omp_variants);
12757 11 : *code = *inner;
12758 11 : free (inner);
12759 11 : while (code->next)
12760 : code = code->next;
12761 11 : code->next = next;
12762 : }
12763 138 : }
12764 :
12765 :
12766 : static gfc_statement
12767 63 : omp_code_to_statement (gfc_code *code)
12768 : {
12769 63 : switch (code->op)
12770 : {
12771 : case EXEC_OMP_PARALLEL:
12772 : return ST_OMP_PARALLEL;
12773 0 : case EXEC_OMP_PARALLEL_MASKED:
12774 0 : return ST_OMP_PARALLEL_MASKED;
12775 0 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
12776 0 : return ST_OMP_PARALLEL_MASKED_TASKLOOP;
12777 0 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
12778 0 : return ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD;
12779 0 : case EXEC_OMP_PARALLEL_MASTER:
12780 0 : return ST_OMP_PARALLEL_MASTER;
12781 0 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
12782 0 : return ST_OMP_PARALLEL_MASTER_TASKLOOP;
12783 0 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
12784 0 : return ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD;
12785 1 : case EXEC_OMP_PARALLEL_SECTIONS:
12786 1 : return ST_OMP_PARALLEL_SECTIONS;
12787 1 : case EXEC_OMP_SECTIONS:
12788 1 : return ST_OMP_SECTIONS;
12789 1 : case EXEC_OMP_ORDERED:
12790 1 : return ST_OMP_ORDERED;
12791 1 : case EXEC_OMP_CRITICAL:
12792 1 : return ST_OMP_CRITICAL;
12793 0 : case EXEC_OMP_MASKED:
12794 0 : return ST_OMP_MASKED;
12795 0 : case EXEC_OMP_MASKED_TASKLOOP:
12796 0 : return ST_OMP_MASKED_TASKLOOP;
12797 0 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
12798 0 : return ST_OMP_MASKED_TASKLOOP_SIMD;
12799 1 : case EXEC_OMP_MASTER:
12800 1 : return ST_OMP_MASTER;
12801 0 : case EXEC_OMP_MASTER_TASKLOOP:
12802 0 : return ST_OMP_MASTER_TASKLOOP;
12803 0 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
12804 0 : return ST_OMP_MASTER_TASKLOOP_SIMD;
12805 1 : case EXEC_OMP_SINGLE:
12806 1 : return ST_OMP_SINGLE;
12807 1 : case EXEC_OMP_TASK:
12808 1 : return ST_OMP_TASK;
12809 1 : case EXEC_OMP_WORKSHARE:
12810 1 : return ST_OMP_WORKSHARE;
12811 1 : case EXEC_OMP_PARALLEL_WORKSHARE:
12812 1 : return ST_OMP_PARALLEL_WORKSHARE;
12813 3 : case EXEC_OMP_DO:
12814 3 : return ST_OMP_DO;
12815 0 : case EXEC_OMP_LOOP:
12816 0 : return ST_OMP_LOOP;
12817 0 : case EXEC_OMP_ALLOCATE:
12818 0 : return ST_OMP_ALLOCATE_EXEC;
12819 0 : case EXEC_OMP_ALLOCATORS:
12820 0 : return ST_OMP_ALLOCATORS;
12821 0 : case EXEC_OMP_ASSUME:
12822 0 : return ST_OMP_ASSUME;
12823 1 : case EXEC_OMP_ATOMIC:
12824 1 : return ST_OMP_ATOMIC;
12825 1 : case EXEC_OMP_BARRIER:
12826 1 : return ST_OMP_BARRIER;
12827 1 : case EXEC_OMP_CANCEL:
12828 1 : return ST_OMP_CANCEL;
12829 1 : case EXEC_OMP_CANCELLATION_POINT:
12830 1 : return ST_OMP_CANCELLATION_POINT;
12831 0 : case EXEC_OMP_ERROR:
12832 0 : return ST_OMP_ERROR;
12833 1 : case EXEC_OMP_FLUSH:
12834 1 : return ST_OMP_FLUSH;
12835 0 : case EXEC_OMP_INTEROP:
12836 0 : return ST_OMP_INTEROP;
12837 1 : case EXEC_OMP_DISTRIBUTE:
12838 1 : return ST_OMP_DISTRIBUTE;
12839 1 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
12840 1 : return ST_OMP_DISTRIBUTE_PARALLEL_DO;
12841 1 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
12842 1 : return ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD;
12843 1 : case EXEC_OMP_DISTRIBUTE_SIMD:
12844 1 : return ST_OMP_DISTRIBUTE_SIMD;
12845 1 : case EXEC_OMP_DO_SIMD:
12846 1 : return ST_OMP_DO_SIMD;
12847 0 : case EXEC_OMP_SCAN:
12848 0 : return ST_OMP_SCAN;
12849 0 : case EXEC_OMP_SCOPE:
12850 0 : return ST_OMP_SCOPE;
12851 1 : case EXEC_OMP_SIMD:
12852 1 : return ST_OMP_SIMD;
12853 1 : case EXEC_OMP_TARGET:
12854 1 : return ST_OMP_TARGET;
12855 1 : case EXEC_OMP_TARGET_DATA:
12856 1 : return ST_OMP_TARGET_DATA;
12857 1 : case EXEC_OMP_TARGET_ENTER_DATA:
12858 1 : return ST_OMP_TARGET_ENTER_DATA;
12859 1 : case EXEC_OMP_TARGET_EXIT_DATA:
12860 1 : return ST_OMP_TARGET_EXIT_DATA;
12861 1 : case EXEC_OMP_TARGET_PARALLEL:
12862 1 : return ST_OMP_TARGET_PARALLEL;
12863 1 : case EXEC_OMP_TARGET_PARALLEL_DO:
12864 1 : return ST_OMP_TARGET_PARALLEL_DO;
12865 1 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
12866 1 : return ST_OMP_TARGET_PARALLEL_DO_SIMD;
12867 0 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
12868 0 : return ST_OMP_TARGET_PARALLEL_LOOP;
12869 1 : case EXEC_OMP_TARGET_SIMD:
12870 1 : return ST_OMP_TARGET_SIMD;
12871 1 : case EXEC_OMP_TARGET_TEAMS:
12872 1 : return ST_OMP_TARGET_TEAMS;
12873 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
12874 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE;
12875 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
12876 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
12877 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12878 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
12879 1 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
12880 1 : return ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD;
12881 0 : case EXEC_OMP_TARGET_TEAMS_LOOP:
12882 0 : return ST_OMP_TARGET_TEAMS_LOOP;
12883 1 : case EXEC_OMP_TARGET_UPDATE:
12884 1 : return ST_OMP_TARGET_UPDATE;
12885 1 : case EXEC_OMP_TASKGROUP:
12886 1 : return ST_OMP_TASKGROUP;
12887 1 : case EXEC_OMP_TASKLOOP:
12888 1 : return ST_OMP_TASKLOOP;
12889 1 : case EXEC_OMP_TASKLOOP_SIMD:
12890 1 : return ST_OMP_TASKLOOP_SIMD;
12891 1 : case EXEC_OMP_TASKWAIT:
12892 1 : return ST_OMP_TASKWAIT;
12893 1 : case EXEC_OMP_TASKYIELD:
12894 1 : return ST_OMP_TASKYIELD;
12895 1 : case EXEC_OMP_TEAMS:
12896 1 : return ST_OMP_TEAMS;
12897 1 : case EXEC_OMP_TEAMS_DISTRIBUTE:
12898 1 : return ST_OMP_TEAMS_DISTRIBUTE;
12899 1 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
12900 1 : return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO;
12901 1 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
12902 1 : return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
12903 1 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
12904 1 : return ST_OMP_TEAMS_DISTRIBUTE_SIMD;
12905 0 : case EXEC_OMP_TEAMS_LOOP:
12906 0 : return ST_OMP_TEAMS_LOOP;
12907 6 : case EXEC_OMP_PARALLEL_DO:
12908 6 : return ST_OMP_PARALLEL_DO;
12909 1 : case EXEC_OMP_PARALLEL_DO_SIMD:
12910 1 : return ST_OMP_PARALLEL_DO_SIMD;
12911 0 : case EXEC_OMP_PARALLEL_LOOP:
12912 0 : return ST_OMP_PARALLEL_LOOP;
12913 1 : case EXEC_OMP_DEPOBJ:
12914 1 : return ST_OMP_DEPOBJ;
12915 0 : case EXEC_OMP_TILE:
12916 0 : return ST_OMP_TILE;
12917 0 : case EXEC_OMP_UNROLL:
12918 0 : return ST_OMP_UNROLL;
12919 0 : case EXEC_OMP_DISPATCH:
12920 0 : return ST_OMP_DISPATCH;
12921 0 : default:
12922 0 : gcc_unreachable ();
12923 : }
12924 : }
12925 :
12926 : static gfc_statement
12927 63 : oacc_code_to_statement (gfc_code *code)
12928 : {
12929 63 : switch (code->op)
12930 : {
12931 : case EXEC_OACC_PARALLEL:
12932 : return ST_OACC_PARALLEL;
12933 : case EXEC_OACC_KERNELS:
12934 : return ST_OACC_KERNELS;
12935 : case EXEC_OACC_SERIAL:
12936 : return ST_OACC_SERIAL;
12937 : case EXEC_OACC_DATA:
12938 : return ST_OACC_DATA;
12939 : case EXEC_OACC_HOST_DATA:
12940 : return ST_OACC_HOST_DATA;
12941 : case EXEC_OACC_PARALLEL_LOOP:
12942 : return ST_OACC_PARALLEL_LOOP;
12943 : case EXEC_OACC_KERNELS_LOOP:
12944 : return ST_OACC_KERNELS_LOOP;
12945 : case EXEC_OACC_SERIAL_LOOP:
12946 : return ST_OACC_SERIAL_LOOP;
12947 : case EXEC_OACC_LOOP:
12948 : return ST_OACC_LOOP;
12949 : case EXEC_OACC_ATOMIC:
12950 : return ST_OACC_ATOMIC;
12951 : case EXEC_OACC_ROUTINE:
12952 : return ST_OACC_ROUTINE;
12953 : case EXEC_OACC_UPDATE:
12954 : return ST_OACC_UPDATE;
12955 : case EXEC_OACC_WAIT:
12956 : return ST_OACC_WAIT;
12957 : case EXEC_OACC_CACHE:
12958 : return ST_OACC_CACHE;
12959 : case EXEC_OACC_ENTER_DATA:
12960 : return ST_OACC_ENTER_DATA;
12961 : case EXEC_OACC_EXIT_DATA:
12962 : return ST_OACC_EXIT_DATA;
12963 : case EXEC_OACC_DECLARE:
12964 : return ST_OACC_DECLARE;
12965 0 : default:
12966 0 : gcc_unreachable ();
12967 : }
12968 : }
12969 :
12970 : static void
12971 13168 : resolve_oacc_directive_inside_omp_region (gfc_code *code)
12972 : {
12973 13168 : if (omp_current_ctx != NULL && omp_current_ctx->is_openmp)
12974 : {
12975 11 : gfc_statement st = omp_code_to_statement (omp_current_ctx->code);
12976 11 : gfc_statement oacc_st = oacc_code_to_statement (code);
12977 11 : gfc_error ("The %s directive cannot be specified within "
12978 : "a %s region at %L", gfc_ascii_statement (oacc_st),
12979 : gfc_ascii_statement (st), &code->loc);
12980 : }
12981 13168 : }
12982 :
12983 : static void
12984 20795 : resolve_omp_directive_inside_oacc_region (gfc_code *code)
12985 : {
12986 20795 : if (omp_current_ctx != NULL && !omp_current_ctx->is_openmp)
12987 : {
12988 52 : gfc_statement st = oacc_code_to_statement (omp_current_ctx->code);
12989 52 : gfc_statement omp_st = omp_code_to_statement (code);
12990 52 : gfc_error ("The %s directive cannot be specified within "
12991 : "a %s region at %L", gfc_ascii_statement (omp_st),
12992 : gfc_ascii_statement (st), &code->loc);
12993 : }
12994 20795 : }
12995 :
12996 :
12997 : static void
12998 5272 : resolve_oacc_nested_loops (gfc_code *code, gfc_code* do_code, int collapse,
12999 : const char *clause)
13000 : {
13001 5272 : gfc_symbol *dovar;
13002 5272 : gfc_code *c;
13003 5272 : int i;
13004 :
13005 5792 : for (i = 1; i <= collapse; i++)
13006 : {
13007 5792 : if (do_code->op == EXEC_DO_WHILE)
13008 : {
13009 10 : gfc_error ("!$ACC LOOP cannot be a DO WHILE or DO without loop control "
13010 : "at %L", &do_code->loc);
13011 10 : break;
13012 : }
13013 5782 : if (do_code->op == EXEC_DO_CONCURRENT)
13014 : {
13015 3 : gfc_error ("!$ACC LOOP cannot be a DO CONCURRENT loop at %L",
13016 : &do_code->loc);
13017 3 : break;
13018 : }
13019 5779 : gcc_assert (do_code->op == EXEC_DO);
13020 5779 : if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
13021 6 : gfc_error ("!$ACC LOOP iteration variable must be of type integer at %L",
13022 : &do_code->loc);
13023 5779 : dovar = do_code->ext.iterator->var->symtree->n.sym;
13024 5779 : if (i > 1)
13025 : {
13026 518 : gfc_code *do_code2 = code->block->next;
13027 518 : int j;
13028 :
13029 1218 : for (j = 1; j < i; j++)
13030 : {
13031 710 : gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
13032 710 : if (dovar == ivar
13033 710 : || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
13034 701 : || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
13035 1410 : || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
13036 : {
13037 10 : gfc_error ("!$ACC LOOP %s loops don't form rectangular "
13038 : "iteration space at %L", clause, &do_code->loc);
13039 10 : break;
13040 : }
13041 700 : do_code2 = do_code2->block->next;
13042 : }
13043 : }
13044 5779 : if (i == collapse)
13045 : break;
13046 577 : for (c = do_code->next; c; c = c->next)
13047 48 : if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
13048 : {
13049 0 : gfc_error ("%s !$ACC LOOP loops not perfectly nested at %L",
13050 : clause, &c->loc);
13051 0 : break;
13052 : }
13053 529 : if (c)
13054 : break;
13055 529 : do_code = do_code->block;
13056 529 : if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
13057 0 : && do_code->op != EXEC_DO_CONCURRENT)
13058 : {
13059 0 : gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
13060 : clause, &code->loc);
13061 0 : break;
13062 : }
13063 529 : do_code = do_code->next;
13064 529 : if (do_code == NULL
13065 522 : || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
13066 2 : && do_code->op != EXEC_DO_CONCURRENT))
13067 : {
13068 9 : gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
13069 : clause, &code->loc);
13070 9 : break;
13071 : }
13072 : }
13073 5272 : }
13074 :
13075 :
13076 : static void
13077 10119 : resolve_oacc_loop_blocks (gfc_code *code)
13078 : {
13079 10119 : if (!oacc_is_loop (code))
13080 : return;
13081 :
13082 5272 : if (code->ext.omp_clauses->tile_list && code->ext.omp_clauses->gang
13083 24 : && code->ext.omp_clauses->worker && code->ext.omp_clauses->vector)
13084 0 : gfc_error ("Tiled loop cannot be parallelized across gangs, workers and "
13085 : "vectors at the same time at %L", &code->loc);
13086 :
13087 5272 : if (code->ext.omp_clauses->tile_list)
13088 : {
13089 : gfc_expr_list *el;
13090 501 : for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
13091 : {
13092 304 : if (el->expr == NULL)
13093 : {
13094 : /* NULL expressions are used to represent '*' arguments.
13095 : Convert those to a 0 expressions. */
13096 113 : el->expr = gfc_get_constant_expr (BT_INTEGER,
13097 : gfc_default_integer_kind,
13098 : &code->loc);
13099 113 : mpz_set_si (el->expr->value.integer, 0);
13100 : }
13101 : else
13102 : {
13103 191 : resolve_positive_int_expr (el->expr, "TILE");
13104 191 : if (el->expr->expr_type != EXPR_CONSTANT)
13105 14 : gfc_error ("TILE requires constant expression at %L",
13106 : &code->loc);
13107 : }
13108 : }
13109 : }
13110 : }
13111 :
13112 :
13113 : void
13114 10119 : gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns)
13115 : {
13116 10119 : fortran_omp_context ctx;
13117 10119 : gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
13118 10119 : gfc_omp_namelist *n;
13119 :
13120 10119 : resolve_oacc_loop_blocks (code);
13121 :
13122 10119 : ctx.code = code;
13123 10119 : ctx.sharing_clauses = new hash_set<gfc_symbol *>;
13124 10119 : ctx.private_iterators = new hash_set<gfc_symbol *>;
13125 10119 : ctx.previous = omp_current_ctx;
13126 10119 : ctx.is_openmp = false;
13127 10119 : omp_current_ctx = &ctx;
13128 :
13129 404760 : for (enum gfc_omp_list_type list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
13130 394641 : list = gfc_omp_list_type (list + 1))
13131 394641 : switch (list)
13132 : {
13133 10119 : case OMP_LIST_PRIVATE:
13134 10710 : for (n = omp_clauses->lists[list]; n; n = n->next)
13135 591 : ctx.sharing_clauses->add (n->sym);
13136 : break;
13137 : default:
13138 : break;
13139 : }
13140 :
13141 10119 : gfc_resolve_blocks (code->block, ns);
13142 :
13143 10119 : omp_current_ctx = ctx.previous;
13144 20238 : delete ctx.sharing_clauses;
13145 20238 : delete ctx.private_iterators;
13146 10119 : }
13147 :
13148 :
13149 : static void
13150 5272 : resolve_oacc_loop (gfc_code *code)
13151 : {
13152 5272 : gfc_code *do_code;
13153 5272 : int collapse;
13154 :
13155 5272 : if (code->ext.omp_clauses)
13156 5272 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
13157 :
13158 5272 : do_code = code->block->next;
13159 5272 : collapse = code->ext.omp_clauses->collapse;
13160 :
13161 : /* Both collapsed and tiled loops are lowered the same way, but are not
13162 : compatible. In gfc_trans_omp_do, the tile is prioritized. */
13163 5272 : if (code->ext.omp_clauses->tile_list)
13164 : {
13165 : int num = 0;
13166 : gfc_expr_list *el;
13167 501 : for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
13168 304 : ++num;
13169 197 : resolve_oacc_nested_loops (code, code->block->next, num, "tiled");
13170 197 : return;
13171 : }
13172 :
13173 5075 : if (collapse <= 0)
13174 : collapse = 1;
13175 5075 : resolve_oacc_nested_loops (code, do_code, collapse, "collapsed");
13176 : }
13177 :
13178 : void
13179 332159 : gfc_resolve_oacc_declare (gfc_namespace *ns)
13180 : {
13181 332159 : enum gfc_omp_list_type list;
13182 332159 : gfc_omp_namelist *n;
13183 332159 : gfc_oacc_declare *oc;
13184 :
13185 332159 : if (ns->oacc_declare == NULL)
13186 : return;
13187 :
13188 290 : for (oc = ns->oacc_declare; oc; oc = oc->next)
13189 : {
13190 6480 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
13191 6318 : list = gfc_omp_list_type (list + 1))
13192 6574 : for (n = oc->clauses->lists[list]; n; n = n->next)
13193 : {
13194 256 : n->sym->mark = 0;
13195 256 : if (n->sym->attr.flavor != FL_VARIABLE
13196 16 : && (n->sym->attr.flavor != FL_PROCEDURE
13197 8 : || n->sym->result != n->sym))
13198 : {
13199 14 : if (n->sym->attr.flavor != FL_PARAMETER)
13200 : {
13201 8 : gfc_error ("Object %qs is not a variable at %L",
13202 : n->sym->name, &oc->loc);
13203 8 : continue;
13204 : }
13205 : /* Note that OpenACC 3.4 permits name constants, but the
13206 : implementation is permitted to ignore the clause;
13207 : as semantically, device_resident kind of makes sense
13208 : (and the wording with it is a bit odd), the warning
13209 : is suppressed. */
13210 6 : if (list != OMP_LIST_DEVICE_RESIDENT)
13211 5 : gfc_warning (OPT_Wsurprising, "Object %qs at %L is ignored as"
13212 : " parameters need not be copied", n->sym->name,
13213 : &oc->loc);
13214 : }
13215 :
13216 248 : if (n->expr && n->expr->ref->type == REF_ARRAY)
13217 : {
13218 1 : gfc_error ("Array sections: %qs not allowed in"
13219 1 : " !$ACC DECLARE at %L", n->sym->name, &oc->loc);
13220 1 : continue;
13221 : }
13222 : }
13223 :
13224 252 : for (n = oc->clauses->lists[OMP_LIST_DEVICE_RESIDENT]; n; n = n->next)
13225 90 : check_array_not_assumed (n->sym, oc->loc, "DEVICE_RESIDENT");
13226 : }
13227 :
13228 290 : for (oc = ns->oacc_declare; oc; oc = oc->next)
13229 : {
13230 6480 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
13231 6318 : list = gfc_omp_list_type (list + 1))
13232 6574 : for (n = oc->clauses->lists[list]; n; n = n->next)
13233 : {
13234 256 : if (n->sym->mark)
13235 : {
13236 9 : gfc_error ("Symbol %qs present on multiple clauses at %L",
13237 : n->sym->name, &oc->loc);
13238 9 : continue;
13239 : }
13240 : else
13241 247 : n->sym->mark = 1;
13242 : }
13243 : }
13244 :
13245 290 : for (oc = ns->oacc_declare; oc; oc = oc->next)
13246 : {
13247 6480 : for (list = OMP_LIST_FIRST; list < OMP_LIST_NUM;
13248 6318 : list = gfc_omp_list_type (list + 1))
13249 6574 : for (n = oc->clauses->lists[list]; n; n = n->next)
13250 256 : n->sym->mark = 0;
13251 : }
13252 : }
13253 :
13254 :
13255 : void
13256 332159 : gfc_resolve_oacc_routines (gfc_namespace *ns)
13257 : {
13258 332159 : for (gfc_oacc_routine_name *orn = ns->oacc_routine_names;
13259 332259 : orn;
13260 100 : orn = orn->next)
13261 : {
13262 100 : gfc_symbol *sym = orn->sym;
13263 100 : if (!sym->attr.external
13264 29 : && !sym->attr.function
13265 27 : && !sym->attr.subroutine)
13266 : {
13267 7 : gfc_error ("NAME %qs does not refer to a subroutine or function"
13268 : " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
13269 7 : continue;
13270 : }
13271 93 : if (!gfc_add_omp_declare_target (&sym->attr, sym->name, &orn->loc))
13272 : {
13273 20 : gfc_error ("NAME %qs invalid"
13274 : " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
13275 20 : continue;
13276 : }
13277 : }
13278 332159 : }
13279 :
13280 :
13281 : void
13282 13168 : gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
13283 : {
13284 13168 : resolve_oacc_directive_inside_omp_region (code);
13285 :
13286 13168 : switch (code->op)
13287 : {
13288 7353 : case EXEC_OACC_PARALLEL:
13289 7353 : case EXEC_OACC_KERNELS:
13290 7353 : case EXEC_OACC_SERIAL:
13291 7353 : case EXEC_OACC_DATA:
13292 7353 : case EXEC_OACC_HOST_DATA:
13293 7353 : case EXEC_OACC_UPDATE:
13294 7353 : case EXEC_OACC_ENTER_DATA:
13295 7353 : case EXEC_OACC_EXIT_DATA:
13296 7353 : case EXEC_OACC_WAIT:
13297 7353 : case EXEC_OACC_CACHE:
13298 7353 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
13299 7353 : break;
13300 5272 : case EXEC_OACC_PARALLEL_LOOP:
13301 5272 : case EXEC_OACC_KERNELS_LOOP:
13302 5272 : case EXEC_OACC_SERIAL_LOOP:
13303 5272 : case EXEC_OACC_LOOP:
13304 5272 : resolve_oacc_loop (code);
13305 5272 : break;
13306 543 : case EXEC_OACC_ATOMIC:
13307 543 : resolve_omp_atomic (code);
13308 543 : break;
13309 : default:
13310 : break;
13311 : }
13312 13168 : }
13313 :
13314 :
13315 : static void
13316 1928 : resolve_omp_target (gfc_code *code)
13317 : {
13318 : #define GFC_IS_TEAMS_CONSTRUCT(op) \
13319 : (op == EXEC_OMP_TEAMS \
13320 : || op == EXEC_OMP_TEAMS_DISTRIBUTE \
13321 : || op == EXEC_OMP_TEAMS_DISTRIBUTE_SIMD \
13322 : || op == EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO \
13323 : || op == EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD \
13324 : || op == EXEC_OMP_TEAMS_LOOP)
13325 :
13326 1928 : if (!code->ext.omp_clauses->contains_teams_construct)
13327 : return;
13328 203 : gfc_code *c = code->block->next;
13329 203 : if (c->op == EXEC_BLOCK)
13330 30 : c = c->ext.block.ns->code;
13331 203 : if (code->ext.omp_clauses->target_first_st_is_teams_or_meta)
13332 : {
13333 192 : if (c->op == EXEC_OMP_METADIRECTIVE)
13334 : {
13335 15 : struct gfc_omp_variant *mc
13336 : = c->ext.omp_variants;
13337 : /* All mc->(next...->)code should be identical with regards
13338 : to the diagnostic below. */
13339 16 : do
13340 : {
13341 16 : if (mc->stmt != ST_NONE
13342 15 : && GFC_IS_TEAMS_CONSTRUCT (mc->code->op))
13343 : {
13344 14 : if (c->next == NULL && mc->code->next == NULL)
13345 : return;
13346 : c = mc->code;
13347 : break;
13348 : }
13349 2 : mc = mc->next;
13350 : }
13351 2 : while (mc);
13352 : }
13353 177 : else if (GFC_IS_TEAMS_CONSTRUCT (c->op) && c->next == NULL)
13354 : return;
13355 : }
13356 :
13357 31 : while (c && !GFC_IS_TEAMS_CONSTRUCT (c->op))
13358 8 : c = c->next;
13359 23 : if (c)
13360 19 : gfc_error ("!$OMP TARGET region at %L with a nested TEAMS at %L may not "
13361 : "contain any other statement, declaration or directive outside "
13362 : "of the single TEAMS construct", &c->loc, &code->loc);
13363 : else
13364 4 : gfc_error ("!$OMP TARGET region at %L with a nested TEAMS may not "
13365 : "contain any other statement, declaration or directive outside "
13366 : "of the single TEAMS construct", &code->loc);
13367 : #undef GFC_IS_TEAMS_CONSTRUCT
13368 : }
13369 :
13370 : static void
13371 154 : resolve_omp_dispatch (gfc_code *code)
13372 : {
13373 154 : gfc_code *next = code->block->next;
13374 154 : if (next == NULL)
13375 : return;
13376 :
13377 151 : gfc_exec_op op = next->op;
13378 151 : gcc_assert (op == EXEC_CALL || op == EXEC_ASSIGN);
13379 151 : if (op != EXEC_CALL
13380 74 : && (op != EXEC_ASSIGN || next->expr2->expr_type != EXPR_FUNCTION))
13381 3 : gfc_error (
13382 : "%<OMP DISPATCH%> directive at %L must be followed by a procedure "
13383 : "call with optional assignment",
13384 : &code->loc);
13385 :
13386 77 : if ((op == EXEC_CALL && next->resolved_sym != NULL
13387 76 : && next->resolved_sym->attr.proc_pointer)
13388 150 : || (op == EXEC_ASSIGN && gfc_expr_attr (next->expr2).proc_pointer))
13389 1 : gfc_error ("%<OMP DISPATCH%> directive at %L cannot be followed by a "
13390 : "procedure pointer",
13391 : &code->loc);
13392 : }
13393 :
13394 : /* Resolve OpenMP directive clauses and check various requirements
13395 : of each directive. */
13396 :
13397 : void
13398 20795 : gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns)
13399 : {
13400 20795 : resolve_omp_directive_inside_oacc_region (code);
13401 :
13402 20795 : if (code->op != EXEC_OMP_ATOMIC)
13403 18641 : gfc_maybe_initialize_eh ();
13404 :
13405 20795 : switch (code->op)
13406 : {
13407 5420 : case EXEC_OMP_DISTRIBUTE:
13408 5420 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
13409 5420 : case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
13410 5420 : case EXEC_OMP_DISTRIBUTE_SIMD:
13411 5420 : case EXEC_OMP_DO:
13412 5420 : case EXEC_OMP_DO_SIMD:
13413 5420 : case EXEC_OMP_LOOP:
13414 5420 : case EXEC_OMP_PARALLEL_DO:
13415 5420 : case EXEC_OMP_PARALLEL_DO_SIMD:
13416 5420 : case EXEC_OMP_PARALLEL_LOOP:
13417 5420 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
13418 5420 : case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
13419 5420 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
13420 5420 : case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
13421 5420 : case EXEC_OMP_MASKED_TASKLOOP:
13422 5420 : case EXEC_OMP_MASKED_TASKLOOP_SIMD:
13423 5420 : case EXEC_OMP_MASTER_TASKLOOP:
13424 5420 : case EXEC_OMP_MASTER_TASKLOOP_SIMD:
13425 5420 : case EXEC_OMP_SIMD:
13426 5420 : case EXEC_OMP_TARGET_PARALLEL_DO:
13427 5420 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
13428 5420 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
13429 5420 : case EXEC_OMP_TARGET_SIMD:
13430 5420 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
13431 5420 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
13432 5420 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13433 5420 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
13434 5420 : case EXEC_OMP_TARGET_TEAMS_LOOP:
13435 5420 : case EXEC_OMP_TASKLOOP:
13436 5420 : case EXEC_OMP_TASKLOOP_SIMD:
13437 5420 : case EXEC_OMP_TEAMS_DISTRIBUTE:
13438 5420 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
13439 5420 : case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
13440 5420 : case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
13441 5420 : case EXEC_OMP_TEAMS_LOOP:
13442 5420 : case EXEC_OMP_TILE:
13443 5420 : case EXEC_OMP_UNROLL:
13444 5420 : resolve_omp_do (code);
13445 5420 : break;
13446 1928 : case EXEC_OMP_TARGET:
13447 1928 : resolve_omp_target (code);
13448 9848 : gcc_fallthrough ();
13449 9848 : case EXEC_OMP_ALLOCATE:
13450 9848 : case EXEC_OMP_ALLOCATORS:
13451 9848 : case EXEC_OMP_ASSUME:
13452 9848 : case EXEC_OMP_CANCEL:
13453 9848 : case EXEC_OMP_ERROR:
13454 9848 : case EXEC_OMP_INTEROP:
13455 9848 : case EXEC_OMP_MASKED:
13456 9848 : case EXEC_OMP_ORDERED:
13457 9848 : case EXEC_OMP_PARALLEL_WORKSHARE:
13458 9848 : case EXEC_OMP_PARALLEL:
13459 9848 : case EXEC_OMP_PARALLEL_MASKED:
13460 9848 : case EXEC_OMP_PARALLEL_MASTER:
13461 9848 : case EXEC_OMP_PARALLEL_SECTIONS:
13462 9848 : case EXEC_OMP_SCOPE:
13463 9848 : case EXEC_OMP_SECTIONS:
13464 9848 : case EXEC_OMP_SINGLE:
13465 9848 : case EXEC_OMP_TARGET_DATA:
13466 9848 : case EXEC_OMP_TARGET_ENTER_DATA:
13467 9848 : case EXEC_OMP_TARGET_EXIT_DATA:
13468 9848 : case EXEC_OMP_TARGET_PARALLEL:
13469 9848 : case EXEC_OMP_TARGET_TEAMS:
13470 9848 : case EXEC_OMP_TASK:
13471 9848 : case EXEC_OMP_TASKWAIT:
13472 9848 : case EXEC_OMP_TEAMS:
13473 9848 : case EXEC_OMP_WORKSHARE:
13474 9848 : case EXEC_OMP_DEPOBJ:
13475 9848 : if (code->ext.omp_clauses)
13476 9715 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
13477 : break;
13478 1704 : case EXEC_OMP_TARGET_UPDATE:
13479 1704 : if (code->ext.omp_clauses)
13480 1704 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
13481 1704 : if (code->ext.omp_clauses == NULL
13482 1704 : || (code->ext.omp_clauses->lists[OMP_LIST_TO] == NULL
13483 992 : && code->ext.omp_clauses->lists[OMP_LIST_FROM] == NULL))
13484 0 : gfc_error ("OMP TARGET UPDATE at %L requires at least one TO or "
13485 : "FROM clause", &code->loc);
13486 : break;
13487 2154 : case EXEC_OMP_ATOMIC:
13488 2154 : resolve_omp_clauses (code, code->block->ext.omp_clauses, NULL);
13489 2154 : resolve_omp_atomic (code);
13490 2154 : break;
13491 159 : case EXEC_OMP_CRITICAL:
13492 159 : resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
13493 159 : if (!code->ext.omp_clauses->critical_name
13494 112 : && code->ext.omp_clauses->hint
13495 3 : && code->ext.omp_clauses->hint->ts.type == BT_INTEGER
13496 3 : && code->ext.omp_clauses->hint->expr_type == EXPR_CONSTANT
13497 3 : && mpz_sgn (code->ext.omp_clauses->hint->value.integer) != 0)
13498 1 : gfc_error ("OMP CRITICAL at %L with HINT clause requires a NAME, "
13499 : "except when omp_sync_hint_none is used", &code->loc);
13500 : break;
13501 49 : case EXEC_OMP_SCAN:
13502 : /* Flag is only used to checking, hence, it is unset afterwards. */
13503 49 : if (!code->ext.omp_clauses->if_present)
13504 10 : gfc_error ("Unexpected !$OMP SCAN at %L outside loop construct with "
13505 : "%<inscan%> REDUCTION clause", &code->loc);
13506 49 : code->ext.omp_clauses->if_present = false;
13507 49 : resolve_omp_clauses (code, code->ext.omp_clauses, ns);
13508 49 : break;
13509 154 : case EXEC_OMP_DISPATCH:
13510 154 : if (code->ext.omp_clauses)
13511 154 : resolve_omp_clauses (code, code->ext.omp_clauses, ns);
13512 154 : resolve_omp_dispatch (code);
13513 154 : break;
13514 138 : case EXEC_OMP_METADIRECTIVE:
13515 138 : resolve_omp_metadirective (code, ns);
13516 138 : break;
13517 : default:
13518 : break;
13519 : }
13520 20795 : }
13521 :
13522 : /* Resolve !$omp declare {variant|simd} constructs in NS.
13523 : Note that !$omp declare target is resolved in resolve_symbol. */
13524 :
13525 : void
13526 343587 : gfc_resolve_omp_declare (gfc_namespace *ns)
13527 : {
13528 343587 : gfc_omp_declare_simd *ods;
13529 343823 : for (ods = ns->omp_declare_simd; ods; ods = ods->next)
13530 : {
13531 236 : if (ods->proc_name != NULL
13532 196 : && ods->proc_name != ns->proc_name)
13533 6 : gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure "
13534 : "%qs at %L", ns->proc_name->name, &ods->where);
13535 236 : if (ods->clauses)
13536 218 : resolve_omp_clauses (NULL, ods->clauses, ns);
13537 : }
13538 :
13539 343587 : gfc_omp_declare_variant *odv;
13540 343587 : gfc_omp_namelist *range_begin = NULL;
13541 :
13542 344041 : for (odv = ns->omp_declare_variant; odv; odv = odv->next)
13543 454 : gfc_resolve_omp_context_selector (odv->set_selectors, false, nullptr);
13544 344041 : for (odv = ns->omp_declare_variant; odv; odv = odv->next)
13545 657 : for (gfc_omp_namelist *n = odv->adjust_args_list; n != NULL; n = n->next)
13546 : {
13547 203 : if ((n->expr == NULL
13548 6 : && (range_begin
13549 4 : || n->u.adj_args.range_start
13550 1 : || n->u.adj_args.omp_num_args_plus
13551 1 : || n->u.adj_args.omp_num_args_minus))
13552 198 : || n->u.adj_args.error_p)
13553 : {
13554 : }
13555 197 : else if (range_begin
13556 191 : || n->u.adj_args.range_start
13557 186 : || n->u.adj_args.omp_num_args_plus
13558 186 : || n->u.adj_args.omp_num_args_minus)
13559 : {
13560 11 : if (!n->expr
13561 11 : || !gfc_resolve_expr (n->expr)
13562 11 : || n->expr->expr_type != EXPR_CONSTANT
13563 10 : || n->expr->ts.type != BT_INTEGER
13564 10 : || n->expr->rank != 0
13565 10 : || mpz_sgn (n->expr->value.integer) < 0
13566 20 : || ((n->u.adj_args.omp_num_args_plus
13567 8 : || n->u.adj_args.omp_num_args_minus)
13568 5 : && mpz_sgn (n->expr->value.integer) == 0))
13569 : {
13570 2 : if (n->u.adj_args.omp_num_args_plus
13571 2 : || n->u.adj_args.omp_num_args_minus)
13572 0 : gfc_error ("Expected constant non-negative scalar integer "
13573 : "offset expression at %L", &n->where);
13574 : else
13575 2 : gfc_error ("For range-based %<adjust_args%>, a constant "
13576 : "positive scalar integer expression is required "
13577 : "at %L", &n->where);
13578 : }
13579 : }
13580 186 : else if (n->expr
13581 186 : && n->expr->expr_type == EXPR_CONSTANT
13582 21 : && n->expr->ts.type == BT_INTEGER
13583 20 : && mpz_sgn (n->expr->value.integer) > 0)
13584 : {
13585 : }
13586 166 : else if (!n->expr
13587 166 : || !gfc_resolve_expr (n->expr)
13588 331 : || n->expr->expr_type != EXPR_VARIABLE)
13589 2 : gfc_error ("Expected dummy parameter name or a positive integer "
13590 : "at %L", &n->where);
13591 164 : else if (n->expr->expr_type == EXPR_VARIABLE)
13592 164 : n->sym = n->expr->symtree->n.sym;
13593 :
13594 203 : range_begin = n->u.adj_args.range_start ? n : NULL;
13595 : }
13596 343587 : }
13597 :
13598 : struct omp_udr_callback_data
13599 : {
13600 : gfc_omp_udr *omp_udr;
13601 : bool is_initializer;
13602 : };
13603 :
13604 : static int
13605 3598 : omp_udr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
13606 : void *data)
13607 : {
13608 3598 : struct omp_udr_callback_data *cd = (struct omp_udr_callback_data *) data;
13609 3598 : if ((*e)->expr_type == EXPR_VARIABLE)
13610 : {
13611 2203 : if (cd->is_initializer)
13612 : {
13613 535 : if ((*e)->symtree->n.sym != cd->omp_udr->omp_priv
13614 140 : && (*e)->symtree->n.sym != cd->omp_udr->omp_orig)
13615 4 : gfc_error ("Variable other than OMP_PRIV or OMP_ORIG used in "
13616 : "INITIALIZER clause of !$OMP DECLARE REDUCTION at %L",
13617 : &(*e)->where);
13618 : }
13619 : else
13620 : {
13621 1668 : if ((*e)->symtree->n.sym != cd->omp_udr->omp_out
13622 597 : && (*e)->symtree->n.sym != cd->omp_udr->omp_in)
13623 6 : gfc_error ("Variable other than OMP_OUT or OMP_IN used in "
13624 : "combiner of !$OMP DECLARE REDUCTION at %L",
13625 : &(*e)->where);
13626 : }
13627 : }
13628 3598 : return 0;
13629 : }
13630 :
13631 : /* Resolve !$omp declare reduction constructs. */
13632 :
13633 : static void
13634 600 : gfc_resolve_omp_udr (gfc_omp_udr *omp_udr)
13635 : {
13636 600 : gfc_actual_arglist *a;
13637 600 : const char *predef_name = NULL;
13638 :
13639 600 : switch (omp_udr->rop)
13640 : {
13641 599 : case OMP_REDUCTION_PLUS:
13642 599 : case OMP_REDUCTION_TIMES:
13643 599 : case OMP_REDUCTION_MINUS:
13644 599 : case OMP_REDUCTION_AND:
13645 599 : case OMP_REDUCTION_OR:
13646 599 : case OMP_REDUCTION_EQV:
13647 599 : case OMP_REDUCTION_NEQV:
13648 599 : case OMP_REDUCTION_MAX:
13649 599 : case OMP_REDUCTION_USER:
13650 599 : break;
13651 1 : default:
13652 1 : gfc_error ("Invalid operator for !$OMP DECLARE REDUCTION %s at %L",
13653 : omp_udr->name, &omp_udr->where);
13654 22 : return;
13655 : }
13656 :
13657 599 : if (gfc_omp_udr_predef (omp_udr->rop, omp_udr->name,
13658 : &omp_udr->ts, &predef_name))
13659 : {
13660 18 : if (predef_name)
13661 18 : gfc_error_now ("Redefinition of predefined %s "
13662 : "!$OMP DECLARE REDUCTION at %L",
13663 : predef_name, &omp_udr->where);
13664 : else
13665 0 : gfc_error_now ("Redefinition of predefined "
13666 : "!$OMP DECLARE REDUCTION at %L", &omp_udr->where);
13667 18 : return;
13668 : }
13669 :
13670 581 : if (omp_udr->ts.type == BT_CHARACTER
13671 62 : && omp_udr->ts.u.cl->length
13672 32 : && omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
13673 : {
13674 1 : gfc_error ("CHARACTER length in !$OMP DECLARE REDUCTION %s not "
13675 : "constant at %L", omp_udr->name, &omp_udr->where);
13676 1 : return;
13677 : }
13678 :
13679 580 : struct omp_udr_callback_data cd;
13680 580 : cd.omp_udr = omp_udr;
13681 580 : cd.is_initializer = false;
13682 580 : gfc_code_walker (&omp_udr->combiner_ns->code, gfc_dummy_code_callback,
13683 : omp_udr_callback, &cd);
13684 580 : if (omp_udr->combiner_ns->code->op == EXEC_CALL)
13685 : {
13686 346 : for (a = omp_udr->combiner_ns->code->ext.actual; a; a = a->next)
13687 237 : if (a->expr == NULL)
13688 : break;
13689 110 : if (a)
13690 1 : gfc_error ("Subroutine call with alternate returns in combiner "
13691 : "of !$OMP DECLARE REDUCTION at %L",
13692 : &omp_udr->combiner_ns->code->loc);
13693 : }
13694 580 : if (omp_udr->initializer_ns)
13695 : {
13696 373 : cd.is_initializer = true;
13697 373 : gfc_code_walker (&omp_udr->initializer_ns->code, gfc_dummy_code_callback,
13698 : omp_udr_callback, &cd);
13699 373 : if (omp_udr->initializer_ns->code->op == EXEC_CALL)
13700 : {
13701 377 : for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
13702 243 : if (a->expr == NULL)
13703 : break;
13704 135 : if (a)
13705 1 : gfc_error ("Subroutine call with alternate returns in "
13706 : "INITIALIZER clause of !$OMP DECLARE REDUCTION "
13707 : "at %L", &omp_udr->initializer_ns->code->loc);
13708 136 : for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
13709 135 : if (a->expr
13710 135 : && a->expr->expr_type == EXPR_VARIABLE
13711 135 : && a->expr->symtree->n.sym == omp_udr->omp_priv
13712 134 : && a->expr->ref == NULL)
13713 : break;
13714 135 : if (a == NULL)
13715 1 : gfc_error ("One of actual subroutine arguments in INITIALIZER "
13716 : "clause of !$OMP DECLARE REDUCTION must be OMP_PRIV "
13717 : "at %L", &omp_udr->initializer_ns->code->loc);
13718 : }
13719 : }
13720 207 : else if (omp_udr->ts.type == BT_DERIVED
13721 207 : && !gfc_has_default_initializer (omp_udr->ts.u.derived))
13722 : {
13723 1 : gfc_error ("Missing INITIALIZER clause for !$OMP DECLARE REDUCTION "
13724 : "of derived type without default initializer at %L",
13725 : &omp_udr->where);
13726 1 : return;
13727 : }
13728 : }
13729 :
13730 : void
13731 344595 : gfc_resolve_omp_udrs (gfc_symtree *st)
13732 : {
13733 344595 : gfc_omp_udr *omp_udr;
13734 :
13735 344595 : if (st == NULL)
13736 : return;
13737 504 : gfc_resolve_omp_udrs (st->left);
13738 504 : gfc_resolve_omp_udrs (st->right);
13739 1104 : for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
13740 600 : gfc_resolve_omp_udr (omp_udr);
13741 : }
|
