1/* OpenMP directive matching and resolving.
2 Copyright (C) 2005-2023 Free Software Foundation, Inc.
3 Contributed by Jakub Jelinek
4
5This file is part of GCC.
6
7GCC is free software; you can redistribute it and/or modify it under
8the terms of the GNU General Public License as published by the Free
9Software Foundation; either version 3, or (at your option) any later
10version.
11
12GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13WARRANTY; without even the implied warranty of MERCHANTABILITY or
14FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15for more details.
16
17You should have received a copy of the GNU General Public License
18along with GCC; see the file COPYING3. If not see
19<http://www.gnu.org/licenses/>. */
20
21#include "config.h"
22#include "system.h"
23#include "coretypes.h"
24#include "gfortran.h"
25#include "arith.h"
26#include "match.h"
27#include "parse.h"
28#include "constructor.h"
29#include "diagnostic.h"
30#include "gomp-constants.h"
31#include "target-memory.h" /* For gfc_encode_character. */
32#include "bitmap.h"
33#include "omp-api.h" /* For omp_runtime_api_procname. */
34
35
36static gfc_statement omp_code_to_statement (gfc_code *);
37
38enum gfc_omp_directive_kind {
39 GFC_OMP_DIR_DECLARATIVE,
40 GFC_OMP_DIR_EXECUTABLE,
41 GFC_OMP_DIR_INFORMATIONAL,
42 GFC_OMP_DIR_META,
43 GFC_OMP_DIR_SUBSIDIARY,
44 GFC_OMP_DIR_UTILITY
45};
46
47struct gfc_omp_directive {
48 const char *name;
49 enum gfc_omp_directive_kind kind;
50 gfc_statement st;
51};
52
53/* Alphabetically sorted OpenMP clauses, except that longer strings are before
54 substrings; excludes combined/composite directives. See note for "ordered"
55 and "nothing". */
56
57static const struct gfc_omp_directive gfc_omp_directives[] = {
58 {.name: "allocate", .kind: GFC_OMP_DIR_DECLARATIVE, .st: ST_OMP_ALLOCATE},
59 {.name: "allocators", .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_ALLOCATORS},
60 {.name: "assumes", .kind: GFC_OMP_DIR_INFORMATIONAL, .st: ST_OMP_ASSUMES},
61 {.name: "assume", .kind: GFC_OMP_DIR_INFORMATIONAL, .st: ST_OMP_ASSUME},
62 {.name: "atomic", .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_ATOMIC},
63 {.name: "barrier", .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_BARRIER},
64 {.name: "cancellation point", .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_CANCELLATION_POINT},
65 {.name: "cancel", .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_CANCEL},
66 {.name: "critical", .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_CRITICAL},
67 /* {"declare mapper", GFC_OMP_DIR_DECLARATIVE, ST_OMP_DECLARE_MAPPER}, */
68 {.name: "declare reduction", .kind: GFC_OMP_DIR_DECLARATIVE, .st: ST_OMP_DECLARE_REDUCTION},
69 {.name: "declare simd", .kind: GFC_OMP_DIR_DECLARATIVE, .st: ST_OMP_DECLARE_SIMD},
70 {.name: "declare target", .kind: GFC_OMP_DIR_DECLARATIVE, .st: ST_OMP_DECLARE_TARGET},
71 {.name: "declare variant", .kind: GFC_OMP_DIR_DECLARATIVE, .st: ST_OMP_DECLARE_VARIANT},
72 {.name: "depobj", .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_DEPOBJ},
73 /* {"dispatch", GFC_OMP_DIR_EXECUTABLE, ST_OMP_DISPATCH}, */
74 {.name: "distribute", .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_DISTRIBUTE},
75 {.name: "do", .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_DO},
76 /* "error" becomes GFC_OMP_DIR_EXECUTABLE with at(execution) */
77 {.name: "error", .kind: GFC_OMP_DIR_UTILITY, .st: ST_OMP_ERROR},
78 {.name: "flush", .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_FLUSH},
79 /* {"interop", GFC_OMP_DIR_EXECUTABLE, ST_OMP_INTEROP}, */
80 {.name: "loop", .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_LOOP},
81 {.name: "masked", .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_MASKED},
82 /* {"metadirective", GFC_OMP_DIR_META, ST_OMP_METADIRECTIVE}, */
83 /* Note: gfc_match_omp_nothing returns ST_NONE. */
84 {.name: "nothing", .kind: GFC_OMP_DIR_UTILITY, .st: ST_OMP_NOTHING},
85 /* Special case; for now map to the first one.
86 ordered-blockassoc = ST_OMP_ORDERED
87 ordered-standalone = ST_OMP_ORDERED_DEPEND + depend/doacross. */
88 {.name: "ordered", .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_ORDERED},
89 {.name: "parallel", .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_PARALLEL},
90 {.name: "requires", .kind: GFC_OMP_DIR_INFORMATIONAL, .st: ST_OMP_REQUIRES},
91 {.name: "scan", .kind: GFC_OMP_DIR_SUBSIDIARY, .st: ST_OMP_SCAN},
92 {.name: "scope", .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_SCOPE},
93 {.name: "sections", .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_SECTIONS},
94 {.name: "section", .kind: GFC_OMP_DIR_SUBSIDIARY, .st: ST_OMP_SECTION},
95 {.name: "simd", .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_SIMD},
96 {.name: "single", .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_SINGLE},
97 {.name: "target data", .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_TARGET_DATA},
98 {.name: "target enter data", .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_TARGET_ENTER_DATA},
99 {.name: "target exit data", .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_TARGET_EXIT_DATA},
100 {.name: "target update", .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_TARGET_UPDATE},
101 {.name: "target", .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_TARGET},
102 {.name: "taskloop", .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_TASKLOOP},
103 {.name: "taskwait", .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_TASKWAIT},
104 {.name: "taskyield", .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_TASKYIELD},
105 {.name: "task", .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_TASK},
106 {.name: "teams", .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_TEAMS},
107 {.name: "threadprivate", .kind: GFC_OMP_DIR_DECLARATIVE, .st: ST_OMP_THREADPRIVATE},
108 /* {"tile", GFC_OMP_DIR_EXECUTABLE, ST_OMP_TILE}, */
109 /* {"unroll", GFC_OMP_DIR_EXECUTABLE, ST_OMP_UNROLL}, */
110 {.name: "workshare", .kind: GFC_OMP_DIR_EXECUTABLE, .st: ST_OMP_WORKSHARE},
111};
112
113
114/* Match an end of OpenMP directive. End of OpenMP directive is optional
115 whitespace, followed by '\n' or comment '!'. */
116
117static match
118gfc_match_omp_eos (void)
119{
120 locus old_loc;
121 char c;
122
123 old_loc = gfc_current_locus;
124 gfc_gobble_whitespace ();
125
126 c = gfc_next_ascii_char ();
127 switch (c)
128 {
129 case '!':
130 do
131 c = gfc_next_ascii_char ();
132 while (c != '\n');
133 /* Fall through */
134
135 case '\n':
136 return MATCH_YES;
137 }
138
139 gfc_current_locus = old_loc;
140 return MATCH_NO;
141}
142
143match
144gfc_match_omp_eos_error (void)
145{
146 if (gfc_match_omp_eos() == MATCH_YES)
147 return MATCH_YES;
148
149 gfc_error ("Unexpected junk at %C");
150 return MATCH_ERROR;
151}
152
153
154/* Free an omp_clauses structure. */
155
156void
157gfc_free_omp_clauses (gfc_omp_clauses *c)
158{
159 int i;
160 if (c == NULL)
161 return;
162
163 gfc_free_expr (c->if_expr);
164 for (i = 0; i < OMP_IF_LAST; i++)
165 gfc_free_expr (c->if_exprs[i]);
166 gfc_free_expr (c->final_expr);
167 gfc_free_expr (c->num_threads);
168 gfc_free_expr (c->chunk_size);
169 gfc_free_expr (c->safelen_expr);
170 gfc_free_expr (c->simdlen_expr);
171 gfc_free_expr (c->num_teams_lower);
172 gfc_free_expr (c->num_teams_upper);
173 gfc_free_expr (c->device);
174 gfc_free_expr (c->thread_limit);
175 gfc_free_expr (c->dist_chunk_size);
176 gfc_free_expr (c->grainsize);
177 gfc_free_expr (c->hint);
178 gfc_free_expr (c->num_tasks);
179 gfc_free_expr (c->priority);
180 gfc_free_expr (c->detach);
181 gfc_free_expr (c->async_expr);
182 gfc_free_expr (c->gang_num_expr);
183 gfc_free_expr (c->gang_static_expr);
184 gfc_free_expr (c->worker_expr);
185 gfc_free_expr (c->vector_expr);
186 gfc_free_expr (c->num_gangs_expr);
187 gfc_free_expr (c->num_workers_expr);
188 gfc_free_expr (c->vector_length_expr);
189 for (i = 0; i < OMP_LIST_NUM; i++)
190 gfc_free_omp_namelist (c->lists[i],
191 i == OMP_LIST_AFFINITY || i == OMP_LIST_DEPEND,
192 i == OMP_LIST_ALLOCATE,
193 i == OMP_LIST_USES_ALLOCATORS);
194 gfc_free_expr_list (c->wait_list);
195 gfc_free_expr_list (c->tile_list);
196 free (CONST_CAST (char *, c->critical_name));
197 if (c->assume)
198 {
199 free (ptr: c->assume->absent);
200 free (ptr: c->assume->contains);
201 gfc_free_expr_list (c->assume->holds);
202 free (ptr: c->assume);
203 }
204 free (ptr: c);
205}
206
207/* Free oacc_declare structures. */
208
209void
210gfc_free_oacc_declare_clauses (struct gfc_oacc_declare *oc)
211{
212 struct gfc_oacc_declare *decl = oc;
213
214 do
215 {
216 struct gfc_oacc_declare *next;
217
218 next = decl->next;
219 gfc_free_omp_clauses (c: decl->clauses);
220 free (ptr: decl);
221 decl = next;
222 }
223 while (decl);
224}
225
226/* Free expression list. */
227void
228gfc_free_expr_list (gfc_expr_list *list)
229{
230 gfc_expr_list *n;
231
232 for (; list; list = n)
233 {
234 n = list->next;
235 free (ptr: list);
236 }
237}
238
239/* Free an !$omp declare simd construct list. */
240
241void
242gfc_free_omp_declare_simd (gfc_omp_declare_simd *ods)
243{
244 if (ods)
245 {
246 gfc_free_omp_clauses (c: ods->clauses);
247 free (ptr: ods);
248 }
249}
250
251void
252gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *list)
253{
254 while (list)
255 {
256 gfc_omp_declare_simd *current = list;
257 list = list->next;
258 gfc_free_omp_declare_simd (ods: current);
259 }
260}
261
262static void
263gfc_free_omp_trait_property_list (gfc_omp_trait_property *list)
264{
265 while (list)
266 {
267 gfc_omp_trait_property *current = list;
268 list = list->next;
269 switch (current->property_kind)
270 {
271 case CTX_PROPERTY_ID:
272 free (ptr: current->name);
273 break;
274 case CTX_PROPERTY_NAME_LIST:
275 if (current->is_name)
276 free (ptr: current->name);
277 break;
278 case CTX_PROPERTY_SIMD:
279 gfc_free_omp_clauses (c: current->clauses);
280 break;
281 default:
282 break;
283 }
284 free (ptr: current);
285 }
286}
287
288static void
289gfc_free_omp_selector_list (gfc_omp_selector *list)
290{
291 while (list)
292 {
293 gfc_omp_selector *current = list;
294 list = list->next;
295 gfc_free_omp_trait_property_list (list: current->properties);
296 free (ptr: current);
297 }
298}
299
300static void
301gfc_free_omp_set_selector_list (gfc_omp_set_selector *list)
302{
303 while (list)
304 {
305 gfc_omp_set_selector *current = list;
306 list = list->next;
307 gfc_free_omp_selector_list (list: current->trait_selectors);
308 free (ptr: current);
309 }
310}
311
312/* Free an !$omp declare variant construct list. */
313
314void
315gfc_free_omp_declare_variant_list (gfc_omp_declare_variant *list)
316{
317 while (list)
318 {
319 gfc_omp_declare_variant *current = list;
320 list = list->next;
321 gfc_free_omp_set_selector_list (list: current->set_selectors);
322 free (ptr: current);
323 }
324}
325
326/* Free an !$omp declare reduction. */
327
328void
329gfc_free_omp_udr (gfc_omp_udr *omp_udr)
330{
331 if (omp_udr)
332 {
333 gfc_free_omp_udr (omp_udr: omp_udr->next);
334 gfc_free_namespace (omp_udr->combiner_ns);
335 if (omp_udr->initializer_ns)
336 gfc_free_namespace (omp_udr->initializer_ns);
337 free (ptr: omp_udr);
338 }
339}
340
341
342static gfc_omp_udr *
343gfc_find_omp_udr (gfc_namespace *ns, const char *name, gfc_typespec *ts)
344{
345 gfc_symtree *st;
346
347 if (ns == NULL)
348 ns = gfc_current_ns;
349 do
350 {
351 gfc_omp_udr *omp_udr;
352
353 st = gfc_find_symtree (ns->omp_udr_root, name);
354 if (st != NULL)
355 {
356 for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
357 if (ts == NULL)
358 return omp_udr;
359 else if (gfc_compare_types (&omp_udr->ts, ts))
360 {
361 if (ts->type == BT_CHARACTER)
362 {
363 if (omp_udr->ts.u.cl->length == NULL)
364 return omp_udr;
365 if (ts->u.cl->length == NULL)
366 continue;
367 if (gfc_compare_expr (omp_udr->ts.u.cl->length,
368 ts->u.cl->length,
369 INTRINSIC_EQ) != 0)
370 continue;
371 }
372 return omp_udr;
373 }
374 }
375
376 /* Don't escape an interface block. */
377 if (ns && !ns->has_import_set
378 && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
379 break;
380
381 ns = ns->parent;
382 }
383 while (ns != NULL);
384
385 return NULL;
386}
387
388
389/* Match a variable/common block list and construct a namelist from it;
390 if has_all_memory != NULL, *has_all_memory is set and omp_all_memory
391 yields a list->sym NULL entry. */
392
393static match
394gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list,
395 bool allow_common, bool *end_colon = NULL,
396 gfc_omp_namelist ***headp = NULL,
397 bool allow_sections = false,
398 bool allow_derived = false,
399 bool *has_all_memory = NULL,
400 bool reject_common_vars = false)
401{
402 gfc_omp_namelist *head, *tail, *p;
403 locus old_loc, cur_loc;
404 char n[GFC_MAX_SYMBOL_LEN+1];
405 gfc_symbol *sym;
406 match m;
407 gfc_symtree *st;
408
409 head = tail = NULL;
410
411 old_loc = gfc_current_locus;
412 if (has_all_memory)
413 *has_all_memory = false;
414 m = gfc_match (str);
415 if (m != MATCH_YES)
416 return m;
417
418 for (;;)
419 {
420 cur_loc = gfc_current_locus;
421
422 m = gfc_match_name (n);
423 if (m == MATCH_YES && strcmp (s1: n, s2: "omp_all_memory") == 0)
424 {
425 if (!has_all_memory)
426 {
427 gfc_error ("%<omp_all_memory%> at %C not permitted in this "
428 "clause");
429 goto cleanup;
430 }
431 *has_all_memory = true;
432 p = gfc_get_omp_namelist ();
433 if (head == NULL)
434 head = tail = p;
435 else
436 {
437 tail->next = p;
438 tail = tail->next;
439 }
440 tail->where = cur_loc;
441 goto next_item;
442 }
443 if (m == MATCH_YES)
444 {
445 gfc_symtree *st;
446 if ((m = gfc_get_ha_sym_tree (n, &st) ? MATCH_ERROR : MATCH_YES)
447 == MATCH_YES)
448 sym = st->n.sym;
449 }
450 switch (m)
451 {
452 case MATCH_YES:
453 gfc_expr *expr;
454 expr = NULL;
455 gfc_gobble_whitespace ();
456 if ((allow_sections && gfc_peek_ascii_char () == '(')
457 || (allow_derived && gfc_peek_ascii_char () == '%'))
458 {
459 gfc_current_locus = cur_loc;
460 m = gfc_match_variable (&expr, 0);
461 switch (m)
462 {
463 case MATCH_ERROR:
464 goto cleanup;
465 case MATCH_NO:
466 goto syntax;
467 default:
468 break;
469 }
470 if (gfc_is_coindexed (expr))
471 {
472 gfc_error ("List item shall not be coindexed at %C");
473 goto cleanup;
474 }
475 }
476 gfc_set_sym_referenced (sym);
477 p = gfc_get_omp_namelist ();
478 if (head == NULL)
479 head = tail = p;
480 else
481 {
482 tail->next = p;
483 tail = tail->next;
484 }
485 tail->sym = sym;
486 tail->expr = expr;
487 tail->where = cur_loc;
488 if (reject_common_vars && sym->attr.in_common)
489 {
490 gcc_assert (allow_common);
491 gfc_error ("%qs at %L is part of the common block %</%s/%> and "
492 "may only be specificed implicitly via the named "
493 "common block", sym->name, &cur_loc,
494 sym->common_head->name);
495 goto cleanup;
496 }
497 goto next_item;
498 case MATCH_NO:
499 break;
500 case MATCH_ERROR:
501 goto cleanup;
502 }
503
504 if (!allow_common)
505 goto syntax;
506
507 m = gfc_match (" / %n /", n);
508 if (m == MATCH_ERROR)
509 goto cleanup;
510 if (m == MATCH_NO)
511 goto syntax;
512
513 st = gfc_find_symtree (gfc_current_ns->common_root, n);
514 if (st == NULL)
515 {
516 gfc_error ("COMMON block /%s/ not found at %C", n);
517 goto cleanup;
518 }
519 for (sym = st->n.common->head; sym; sym = sym->common_next)
520 {
521 gfc_set_sym_referenced (sym);
522 p = gfc_get_omp_namelist ();
523 if (head == NULL)
524 head = tail = p;
525 else
526 {
527 tail->next = p;
528 tail = tail->next;
529 }
530 tail->sym = sym;
531 tail->where = cur_loc;
532 }
533
534 next_item:
535 if (end_colon && gfc_match_char (':') == MATCH_YES)
536 {
537 *end_colon = true;
538 break;
539 }
540 if (gfc_match_char (')') == MATCH_YES)
541 break;
542 if (gfc_match_char (',') != MATCH_YES)
543 goto syntax;
544 }
545
546 while (*list)
547 list = &(*list)->next;
548
549 *list = head;
550 if (headp)
551 *headp = list;
552 return MATCH_YES;
553
554syntax:
555 gfc_error ("Syntax error in OpenMP variable list at %C");
556
557cleanup:
558 gfc_free_omp_namelist (head, false, false, false);
559 gfc_current_locus = old_loc;
560 return MATCH_ERROR;
561}
562
563/* Match a variable/procedure/common block list and construct a namelist
564 from it. */
565
566static match
567gfc_match_omp_to_link (const char *str, gfc_omp_namelist **list)
568{
569 gfc_omp_namelist *head, *tail, *p;
570 locus old_loc, cur_loc;
571 char n[GFC_MAX_SYMBOL_LEN+1];
572 gfc_symbol *sym;
573 match m;
574 gfc_symtree *st;
575
576 head = tail = NULL;
577
578 old_loc = gfc_current_locus;
579
580 m = gfc_match (str);
581 if (m != MATCH_YES)
582 return m;
583
584 for (;;)
585 {
586 cur_loc = gfc_current_locus;
587 m = gfc_match_symbol (&sym, 1);
588 switch (m)
589 {
590 case MATCH_YES:
591 p = gfc_get_omp_namelist ();
592 if (head == NULL)
593 head = tail = p;
594 else
595 {
596 tail->next = p;
597 tail = tail->next;
598 }
599 tail->sym = sym;
600 tail->where = cur_loc;
601 goto next_item;
602 case MATCH_NO:
603 break;
604 case MATCH_ERROR:
605 goto cleanup;
606 }
607
608 m = gfc_match (" / %n /", n);
609 if (m == MATCH_ERROR)
610 goto cleanup;
611 if (m == MATCH_NO)
612 goto syntax;
613
614 st = gfc_find_symtree (gfc_current_ns->common_root, n);
615 if (st == NULL)
616 {
617 gfc_error ("COMMON block /%s/ not found at %C", n);
618 goto cleanup;
619 }
620 p = gfc_get_omp_namelist ();
621 if (head == NULL)
622 head = tail = p;
623 else
624 {
625 tail->next = p;
626 tail = tail->next;
627 }
628 tail->u.common = st->n.common;
629 tail->where = cur_loc;
630
631 next_item:
632 if (gfc_match_char (')') == MATCH_YES)
633 break;
634 if (gfc_match_char (',') != MATCH_YES)
635 goto syntax;
636 }
637
638 while (*list)
639 list = &(*list)->next;
640
641 *list = head;
642 return MATCH_YES;
643
644syntax:
645 gfc_error ("Syntax error in OpenMP variable list at %C");
646
647cleanup:
648 gfc_free_omp_namelist (head, false, false, false);
649 gfc_current_locus = old_loc;
650 return MATCH_ERROR;
651}
652
653/* Match detach(event-handle). */
654
655static match
656gfc_match_omp_detach (gfc_expr **expr)
657{
658 locus old_loc = gfc_current_locus;
659
660 if (gfc_match ("detach ( ") != MATCH_YES)
661 goto syntax_error;
662
663 if (gfc_match_variable (expr, 0) != MATCH_YES)
664 goto syntax_error;
665
666 if (gfc_match_char (')') != MATCH_YES)
667 goto syntax_error;
668
669 return MATCH_YES;
670
671syntax_error:
672 gfc_error ("Syntax error in OpenMP detach clause at %C");
673 gfc_current_locus = old_loc;
674 return MATCH_ERROR;
675
676}
677
678/* Match doacross(sink : ...) construct a namelist from it;
679 if depend is true, match legacy 'depend(sink : ...)'. */
680
681static match
682gfc_match_omp_doacross_sink (gfc_omp_namelist **list, bool depend)
683{
684 char n[GFC_MAX_SYMBOL_LEN+1];
685 gfc_omp_namelist *head, *tail, *p;
686 locus old_loc, cur_loc;
687 gfc_symbol *sym;
688
689 head = tail = NULL;
690
691 old_loc = gfc_current_locus;
692
693 for (;;)
694 {
695 cur_loc = gfc_current_locus;
696
697 if (gfc_match_name (n) != MATCH_YES)
698 goto syntax;
699 if (UNLIKELY (strcmp (n, "omp_all_memory") == 0))
700 {
701 gfc_error ("%<omp_all_memory%> used with dependence-type "
702 "other than OUT or INOUT at %C");
703 goto cleanup;
704 }
705 sym = NULL;
706 if (!(strcmp (s1: n, s2: "omp_cur_iteration") == 0))
707 {
708 gfc_symtree *st;
709 if (gfc_get_ha_sym_tree (n, &st))
710 goto syntax;
711 sym = st->n.sym;
712 gfc_set_sym_referenced (sym);
713 }
714 p = gfc_get_omp_namelist ();
715 if (head == NULL)
716 {
717 head = tail = p;
718 head->u.depend_doacross_op = (depend ? OMP_DEPEND_SINK_FIRST
719 : OMP_DOACROSS_SINK_FIRST);
720 }
721 else
722 {
723 tail->next = p;
724 tail = tail->next;
725 tail->u.depend_doacross_op = OMP_DOACROSS_SINK;
726 }
727 tail->sym = sym;
728 tail->expr = NULL;
729 tail->where = cur_loc;
730 if (gfc_match_char ('+') == MATCH_YES)
731 {
732 if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES)
733 goto syntax;
734 }
735 else if (gfc_match_char ('-') == MATCH_YES)
736 {
737 if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES)
738 goto syntax;
739 tail->expr = gfc_uminus (op: tail->expr);
740 }
741 if (gfc_match_char (')') == MATCH_YES)
742 break;
743 if (gfc_match_char (',') != MATCH_YES)
744 goto syntax;
745 }
746
747 while (*list)
748 list = &(*list)->next;
749
750 *list = head;
751 return MATCH_YES;
752
753syntax:
754 gfc_error ("Syntax error in OpenMP SINK dependence-type list at %C");
755
756cleanup:
757 gfc_free_omp_namelist (head, false, false, false);
758 gfc_current_locus = old_loc;
759 return MATCH_ERROR;
760}
761
762static match
763match_oacc_expr_list (const char *str, gfc_expr_list **list,
764 bool allow_asterisk)
765{
766 gfc_expr_list *head, *tail, *p;
767 locus old_loc;
768 gfc_expr *expr;
769 match m;
770
771 head = tail = NULL;
772
773 old_loc = gfc_current_locus;
774
775 m = gfc_match (str);
776 if (m != MATCH_YES)
777 return m;
778
779 for (;;)
780 {
781 m = gfc_match_expr (&expr);
782 if (m == MATCH_YES || allow_asterisk)
783 {
784 p = gfc_get_expr_list ();
785 if (head == NULL)
786 head = tail = p;
787 else
788 {
789 tail->next = p;
790 tail = tail->next;
791 }
792 if (m == MATCH_YES)
793 tail->expr = expr;
794 else if (gfc_match (" *") != MATCH_YES)
795 goto syntax;
796 goto next_item;
797 }
798 if (m == MATCH_ERROR)
799 goto cleanup;
800 goto syntax;
801
802 next_item:
803 if (gfc_match_char (')') == MATCH_YES)
804 break;
805 if (gfc_match_char (',') != MATCH_YES)
806 goto syntax;
807 }
808
809 while (*list)
810 list = &(*list)->next;
811
812 *list = head;
813 return MATCH_YES;
814
815syntax:
816 gfc_error ("Syntax error in OpenACC expression list at %C");
817
818cleanup:
819 gfc_free_expr_list (list: head);
820 gfc_current_locus = old_loc;
821 return MATCH_ERROR;
822}
823
824static match
825match_oacc_clause_gwv (gfc_omp_clauses *cp, unsigned gwv)
826{
827 match ret = MATCH_YES;
828
829 if (gfc_match (" ( ") != MATCH_YES)
830 return MATCH_NO;
831
832 if (gwv == GOMP_DIM_GANG)
833 {
834 /* The gang clause accepts two optional arguments, num and static.
835 The num argument may either be explicit (num: <val>) or
836 implicit without (<val> without num:). */
837
838 while (ret == MATCH_YES)
839 {
840 if (gfc_match (" static :") == MATCH_YES)
841 {
842 if (cp->gang_static)
843 return MATCH_ERROR;
844 else
845 cp->gang_static = true;
846 if (gfc_match_char ('*') == MATCH_YES)
847 cp->gang_static_expr = NULL;
848 else if (gfc_match (" %e ", &cp->gang_static_expr) != MATCH_YES)
849 return MATCH_ERROR;
850 }
851 else
852 {
853 if (cp->gang_num_expr)
854 return MATCH_ERROR;
855
856 /* The 'num' argument is optional. */
857 gfc_match (" num :");
858
859 if (gfc_match (" %e ", &cp->gang_num_expr) != MATCH_YES)
860 return MATCH_ERROR;
861 }
862
863 ret = gfc_match (" , ");
864 }
865 }
866 else if (gwv == GOMP_DIM_WORKER)
867 {
868 /* The 'num' argument is optional. */
869 gfc_match (" num :");
870
871 if (gfc_match (" %e ", &cp->worker_expr) != MATCH_YES)
872 return MATCH_ERROR;
873 }
874 else if (gwv == GOMP_DIM_VECTOR)
875 {
876 /* The 'length' argument is optional. */
877 gfc_match (" length :");
878
879 if (gfc_match (" %e ", &cp->vector_expr) != MATCH_YES)
880 return MATCH_ERROR;
881 }
882 else
883 gfc_fatal_error ("Unexpected OpenACC parallelism.");
884
885 return gfc_match (" )");
886}
887
888static match
889gfc_match_oacc_clause_link (const char *str, gfc_omp_namelist **list)
890{
891 gfc_omp_namelist *head = NULL;
892 gfc_omp_namelist *tail, *p;
893 locus old_loc;
894 char n[GFC_MAX_SYMBOL_LEN+1];
895 gfc_symbol *sym;
896 match m;
897 gfc_symtree *st;
898
899 old_loc = gfc_current_locus;
900
901 m = gfc_match (str);
902 if (m != MATCH_YES)
903 return m;
904
905 m = gfc_match (" (");
906
907 for (;;)
908 {
909 m = gfc_match_symbol (&sym, 0);
910 switch (m)
911 {
912 case MATCH_YES:
913 if (sym->attr.in_common)
914 {
915 gfc_error_now ("Variable at %C is an element of a COMMON block");
916 goto cleanup;
917 }
918 gfc_set_sym_referenced (sym);
919 p = gfc_get_omp_namelist ();
920 if (head == NULL)
921 head = tail = p;
922 else
923 {
924 tail->next = p;
925 tail = tail->next;
926 }
927 tail->sym = sym;
928 tail->expr = NULL;
929 tail->where = gfc_current_locus;
930 goto next_item;
931 case MATCH_NO:
932 break;
933
934 case MATCH_ERROR:
935 goto cleanup;
936 }
937
938 m = gfc_match (" / %n /", n);
939 if (m == MATCH_ERROR)
940 goto cleanup;
941 if (m == MATCH_NO || n[0] == '\0')
942 goto syntax;
943
944 st = gfc_find_symtree (gfc_current_ns->common_root, n);
945 if (st == NULL)
946 {
947 gfc_error ("COMMON block /%s/ not found at %C", n);
948 goto cleanup;
949 }
950
951 for (sym = st->n.common->head; sym; sym = sym->common_next)
952 {
953 gfc_set_sym_referenced (sym);
954 p = gfc_get_omp_namelist ();
955 if (head == NULL)
956 head = tail = p;
957 else
958 {
959 tail->next = p;
960 tail = tail->next;
961 }
962 tail->sym = sym;
963 tail->where = gfc_current_locus;
964 }
965
966 next_item:
967 if (gfc_match_char (')') == MATCH_YES)
968 break;
969 if (gfc_match_char (',') != MATCH_YES)
970 goto syntax;
971 }
972
973 if (gfc_match_omp_eos () != MATCH_YES)
974 {
975 gfc_error ("Unexpected junk after !$ACC DECLARE at %C");
976 goto cleanup;
977 }
978
979 while (*list)
980 list = &(*list)->next;
981 *list = head;
982 return MATCH_YES;
983
984syntax:
985 gfc_error ("Syntax error in !$ACC DECLARE list at %C");
986
987cleanup:
988 gfc_current_locus = old_loc;
989 return MATCH_ERROR;
990}
991
992/* OpenMP clauses. */
993enum omp_mask1
994{
995 OMP_CLAUSE_PRIVATE,
996 OMP_CLAUSE_FIRSTPRIVATE,
997 OMP_CLAUSE_LASTPRIVATE,
998 OMP_CLAUSE_COPYPRIVATE,
999 OMP_CLAUSE_SHARED,
1000 OMP_CLAUSE_COPYIN,
1001 OMP_CLAUSE_REDUCTION,
1002 OMP_CLAUSE_IN_REDUCTION,
1003 OMP_CLAUSE_TASK_REDUCTION,
1004 OMP_CLAUSE_IF,
1005 OMP_CLAUSE_NUM_THREADS,
1006 OMP_CLAUSE_SCHEDULE,
1007 OMP_CLAUSE_DEFAULT,
1008 OMP_CLAUSE_ORDER,
1009 OMP_CLAUSE_ORDERED,
1010 OMP_CLAUSE_COLLAPSE,
1011 OMP_CLAUSE_UNTIED,
1012 OMP_CLAUSE_FINAL,
1013 OMP_CLAUSE_MERGEABLE,
1014 OMP_CLAUSE_ALIGNED,
1015 OMP_CLAUSE_DEPEND,
1016 OMP_CLAUSE_INBRANCH,
1017 OMP_CLAUSE_LINEAR,
1018 OMP_CLAUSE_NOTINBRANCH,
1019 OMP_CLAUSE_PROC_BIND,
1020 OMP_CLAUSE_SAFELEN,
1021 OMP_CLAUSE_SIMDLEN,
1022 OMP_CLAUSE_UNIFORM,
1023 OMP_CLAUSE_DEVICE,
1024 OMP_CLAUSE_MAP,
1025 OMP_CLAUSE_TO,
1026 OMP_CLAUSE_FROM,
1027 OMP_CLAUSE_NUM_TEAMS,
1028 OMP_CLAUSE_THREAD_LIMIT,
1029 OMP_CLAUSE_DIST_SCHEDULE,
1030 OMP_CLAUSE_DEFAULTMAP,
1031 OMP_CLAUSE_GRAINSIZE,
1032 OMP_CLAUSE_HINT,
1033 OMP_CLAUSE_IS_DEVICE_PTR,
1034 OMP_CLAUSE_LINK,
1035 OMP_CLAUSE_NOGROUP,
1036 OMP_CLAUSE_NOTEMPORAL,
1037 OMP_CLAUSE_NUM_TASKS,
1038 OMP_CLAUSE_PRIORITY,
1039 OMP_CLAUSE_SIMD,
1040 OMP_CLAUSE_THREADS,
1041 OMP_CLAUSE_USE_DEVICE_PTR,
1042 OMP_CLAUSE_USE_DEVICE_ADDR, /* OpenMP 5.0. */
1043 OMP_CLAUSE_DEVICE_TYPE, /* OpenMP 5.0. */
1044 OMP_CLAUSE_ATOMIC, /* OpenMP 5.0. */
1045 OMP_CLAUSE_CAPTURE, /* OpenMP 5.0. */
1046 OMP_CLAUSE_MEMORDER, /* OpenMP 5.0. */
1047 OMP_CLAUSE_DETACH, /* OpenMP 5.0. */
1048 OMP_CLAUSE_AFFINITY, /* OpenMP 5.0. */
1049 OMP_CLAUSE_ALLOCATE, /* OpenMP 5.0. */
1050 OMP_CLAUSE_BIND, /* OpenMP 5.0. */
1051 OMP_CLAUSE_FILTER, /* OpenMP 5.1. */
1052 OMP_CLAUSE_AT, /* OpenMP 5.1. */
1053 OMP_CLAUSE_MESSAGE, /* OpenMP 5.1. */
1054 OMP_CLAUSE_SEVERITY, /* OpenMP 5.1. */
1055 OMP_CLAUSE_COMPARE, /* OpenMP 5.1. */
1056 OMP_CLAUSE_FAIL, /* OpenMP 5.1. */
1057 OMP_CLAUSE_WEAK, /* OpenMP 5.1. */
1058 OMP_CLAUSE_NOWAIT,
1059 /* This must come last. */
1060 OMP_MASK1_LAST
1061};
1062
1063/* More OpenMP clauses and OpenACC 2.0+ specific clauses. */
1064enum omp_mask2
1065{
1066 OMP_CLAUSE_ASYNC,
1067 OMP_CLAUSE_NUM_GANGS,
1068 OMP_CLAUSE_NUM_WORKERS,
1069 OMP_CLAUSE_VECTOR_LENGTH,
1070 OMP_CLAUSE_COPY,
1071 OMP_CLAUSE_COPYOUT,
1072 OMP_CLAUSE_CREATE,
1073 OMP_CLAUSE_NO_CREATE,
1074 OMP_CLAUSE_PRESENT,
1075 OMP_CLAUSE_DEVICEPTR,
1076 OMP_CLAUSE_GANG,
1077 OMP_CLAUSE_WORKER,
1078 OMP_CLAUSE_VECTOR,
1079 OMP_CLAUSE_SEQ,
1080 OMP_CLAUSE_INDEPENDENT,
1081 OMP_CLAUSE_USE_DEVICE,
1082 OMP_CLAUSE_DEVICE_RESIDENT,
1083 OMP_CLAUSE_SELF,
1084 OMP_CLAUSE_HOST,
1085 OMP_CLAUSE_WAIT,
1086 OMP_CLAUSE_DELETE,
1087 OMP_CLAUSE_AUTO,
1088 OMP_CLAUSE_TILE,
1089 OMP_CLAUSE_IF_PRESENT,
1090 OMP_CLAUSE_FINALIZE,
1091 OMP_CLAUSE_ATTACH,
1092 OMP_CLAUSE_NOHOST,
1093 OMP_CLAUSE_HAS_DEVICE_ADDR, /* OpenMP 5.1 */
1094 OMP_CLAUSE_ENTER, /* OpenMP 5.2 */
1095 OMP_CLAUSE_DOACROSS, /* OpenMP 5.2 */
1096 OMP_CLAUSE_ASSUMPTIONS, /* OpenMP 5.1. */
1097 OMP_CLAUSE_USES_ALLOCATORS, /* OpenMP 5.0 */
1098 /* This must come last. */
1099 OMP_MASK2_LAST
1100};
1101
1102struct omp_inv_mask;
1103
1104/* Customized bitset for up to 128-bits.
1105 The two enums above provide bit numbers to use, and which of the
1106 two enums it is determines which of the two mask fields is used.
1107 Supported operations are defining a mask, like:
1108 #define XXX_CLAUSES \
1109 (omp_mask (OMP_CLAUSE_XXX) | OMP_CLAUSE_YYY | OMP_CLAUSE_ZZZ)
1110 oring such bitsets together or removing selected bits:
1111 (XXX_CLAUSES | YYY_CLAUSES) & ~(omp_mask (OMP_CLAUSE_VVV))
1112 and testing individual bits:
1113 if (mask & OMP_CLAUSE_UUU) */
1114
1115struct omp_mask {
1116 const uint64_t mask1;
1117 const uint64_t mask2;
1118 inline omp_mask ();
1119 inline omp_mask (omp_mask1);
1120 inline omp_mask (omp_mask2);
1121 inline omp_mask (uint64_t, uint64_t);
1122 inline omp_mask operator| (omp_mask1) const;
1123 inline omp_mask operator| (omp_mask2) const;
1124 inline omp_mask operator| (omp_mask) const;
1125 inline omp_mask operator& (const omp_inv_mask &) const;
1126 inline bool operator& (omp_mask1) const;
1127 inline bool operator& (omp_mask2) const;
1128 inline omp_inv_mask operator~ () const;
1129};
1130
1131struct omp_inv_mask : public omp_mask {
1132 inline omp_inv_mask (const omp_mask &);
1133};
1134
1135omp_mask::omp_mask () : mask1 (0), mask2 (0)
1136{
1137}
1138
1139omp_mask::omp_mask (omp_mask1 m) : mask1 (((uint64_t) 1) << m), mask2 (0)
1140{
1141}
1142
1143omp_mask::omp_mask (omp_mask2 m) : mask1 (0), mask2 (((uint64_t) 1) << m)
1144{
1145}
1146
1147omp_mask::omp_mask (uint64_t m1, uint64_t m2) : mask1 (m1), mask2 (m2)
1148{
1149}
1150
1151omp_mask
1152omp_mask::operator| (omp_mask1 m) const
1153{
1154 return omp_mask (mask1 | (((uint64_t) 1) << m), mask2);
1155}
1156
1157omp_mask
1158omp_mask::operator| (omp_mask2 m) const
1159{
1160 return omp_mask (mask1, mask2 | (((uint64_t) 1) << m));
1161}
1162
1163omp_mask
1164omp_mask::operator| (omp_mask m) const
1165{
1166 return omp_mask (mask1 | m.mask1, mask2 | m.mask2);
1167}
1168
1169omp_mask
1170omp_mask::operator& (const omp_inv_mask &m) const
1171{
1172 return omp_mask (mask1 & ~m.mask1, mask2 & ~m.mask2);
1173}
1174
1175bool
1176omp_mask::operator& (omp_mask1 m) const
1177{
1178 return (mask1 & (((uint64_t) 1) << m)) != 0;
1179}
1180
1181bool
1182omp_mask::operator& (omp_mask2 m) const
1183{
1184 return (mask2 & (((uint64_t) 1) << m)) != 0;
1185}
1186
1187omp_inv_mask
1188omp_mask::operator~ () const
1189{
1190 return omp_inv_mask (*this);
1191}
1192
1193omp_inv_mask::omp_inv_mask (const omp_mask &m) : omp_mask (m)
1194{
1195}
1196
1197/* Helper function for OpenACC and OpenMP clauses involving memory
1198 mapping. */
1199
1200static bool
1201gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op,
1202 bool allow_common, bool allow_derived)
1203{
1204 gfc_omp_namelist **head = NULL;
1205 if (gfc_match_omp_variable_list (str: "", list, allow_common, NULL, headp: &head, allow_sections: true,
1206 allow_derived)
1207 == MATCH_YES)
1208 {
1209 gfc_omp_namelist *n;
1210 for (n = *head; n; n = n->next)
1211 n->u.map_op = map_op;
1212 return true;
1213 }
1214
1215 return false;
1216}
1217
1218static match
1219gfc_match_iterator (gfc_namespace **ns, bool permit_var)
1220{
1221 locus old_loc = gfc_current_locus;
1222
1223 if (gfc_match ("iterator ( ") != MATCH_YES)
1224 return MATCH_NO;
1225
1226 gfc_typespec ts;
1227 gfc_symbol *last = NULL;
1228 gfc_expr *begin, *end, *step;
1229 *ns = gfc_build_block_ns (gfc_current_ns);
1230 char name[GFC_MAX_SYMBOL_LEN + 1];
1231 while (true)
1232 {
1233 locus prev_loc = gfc_current_locus;
1234 if (gfc_match_type_spec (&ts) == MATCH_YES
1235 && gfc_match (" :: ") == MATCH_YES)
1236 {
1237 if (ts.type != BT_INTEGER)
1238 {
1239 gfc_error ("Expected INTEGER type at %L", &prev_loc);
1240 return MATCH_ERROR;
1241 }
1242 permit_var = false;
1243 }
1244 else
1245 {
1246 ts.type = BT_INTEGER;
1247 ts.kind = gfc_default_integer_kind;
1248 gfc_current_locus = prev_loc;
1249 }
1250 prev_loc = gfc_current_locus;
1251 if (gfc_match_name (name) != MATCH_YES)
1252 {
1253 gfc_error ("Expected identifier at %C");
1254 goto failed;
1255 }
1256 if (gfc_find_symtree ((*ns)->sym_root, name))
1257 {
1258 gfc_error ("Same identifier %qs specified again at %C", name);
1259 goto failed;
1260 }
1261
1262 gfc_symbol *sym = gfc_new_symbol (name, *ns);
1263 if (last)
1264 last->tlink = sym;
1265 else
1266 (*ns)->omp_affinity_iterators = sym;
1267 last = sym;
1268 sym->declared_at = prev_loc;
1269 sym->ts = ts;
1270 sym->attr.flavor = FL_VARIABLE;
1271 sym->attr.artificial = 1;
1272 sym->attr.referenced = 1;
1273 sym->refs++;
1274 gfc_symtree *st = gfc_new_symtree (&(*ns)->sym_root, name);
1275 st->n.sym = sym;
1276
1277 prev_loc = gfc_current_locus;
1278 if (gfc_match (" = ") != MATCH_YES)
1279 goto failed;
1280 permit_var = false;
1281 begin = end = step = NULL;
1282 if (gfc_match ("%e : ", &begin) != MATCH_YES
1283 || gfc_match ("%e ", &end) != MATCH_YES)
1284 {
1285 gfc_error ("Expected range-specification at %C");
1286 gfc_free_expr (begin);
1287 gfc_free_expr (end);
1288 return MATCH_ERROR;
1289 }
1290 if (':' == gfc_peek_ascii_char ())
1291 {
1292 if (gfc_match (": %e ", &step) != MATCH_YES)
1293 {
1294 gfc_free_expr (begin);
1295 gfc_free_expr (end);
1296 gfc_free_expr (step);
1297 goto failed;
1298 }
1299 }
1300
1301 gfc_expr *e = gfc_get_expr ();
1302 e->where = prev_loc;
1303 e->expr_type = EXPR_ARRAY;
1304 e->ts = ts;
1305 e->rank = 1;
1306 e->shape = gfc_get_shape (1);
1307 mpz_init_set_ui (e->shape[0], step ? 3 : 2);
1308 gfc_constructor_append_expr (base: &e->value.constructor, e: begin, where: &begin->where);
1309 gfc_constructor_append_expr (base: &e->value.constructor, e: end, where: &end->where);
1310 if (step)
1311 gfc_constructor_append_expr (base: &e->value.constructor, e: step, where: &step->where);
1312 sym->value = e;
1313
1314 if (gfc_match (") ") == MATCH_YES)
1315 break;
1316 if (gfc_match (", ") != MATCH_YES)
1317 goto failed;
1318 }
1319 return MATCH_YES;
1320
1321failed:
1322 gfc_namespace *prev_ns = NULL;
1323 for (gfc_namespace *it = gfc_current_ns->contained; it; it = it->sibling)
1324 {
1325 if (it == *ns)
1326 {
1327 if (prev_ns)
1328 prev_ns->sibling = it->sibling;
1329 else
1330 gfc_current_ns->contained = it->sibling;
1331 gfc_free_namespace (it);
1332 break;
1333 }
1334 prev_ns = it;
1335 }
1336 *ns = NULL;
1337 if (!permit_var)
1338 return MATCH_ERROR;
1339 gfc_current_locus = old_loc;
1340 return MATCH_NO;
1341}
1342
1343/* Match target update's to/from( [present:] var-list). */
1344
1345static match
1346gfc_match_motion_var_list (const char *str, gfc_omp_namelist **list,
1347 gfc_omp_namelist ***headp)
1348{
1349 match m = gfc_match (str);
1350 if (m != MATCH_YES)
1351 return m;
1352
1353 match m_present = gfc_match (" present : ");
1354
1355 m = gfc_match_omp_variable_list (str: "", list, allow_common: false, NULL, headp, allow_sections: true, allow_derived: true);
1356 if (m != MATCH_YES)
1357 return m;
1358 if (m_present == MATCH_YES)
1359 {
1360 gfc_omp_namelist *n;
1361 for (n = **headp; n; n = n->next)
1362 n->u.present_modifier = true;
1363 }
1364 return MATCH_YES;
1365}
1366
1367/* reduction ( reduction-modifier, reduction-operator : variable-list )
1368 in_reduction ( reduction-operator : variable-list )
1369 task_reduction ( reduction-operator : variable-list ) */
1370
1371static match
1372gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc,
1373 bool allow_derived, bool openmp_target = false)
1374{
1375 if (pc == 'r' && gfc_match ("reduction ( ") != MATCH_YES)
1376 return MATCH_NO;
1377 else if (pc == 'i' && gfc_match ("in_reduction ( ") != MATCH_YES)
1378 return MATCH_NO;
1379 else if (pc == 't' && gfc_match ("task_reduction ( ") != MATCH_YES)
1380 return MATCH_NO;
1381
1382 locus old_loc = gfc_current_locus;
1383 int list_idx = 0;
1384
1385 if (pc == 'r' && !openacc)
1386 {
1387 if (gfc_match ("inscan") == MATCH_YES)
1388 list_idx = OMP_LIST_REDUCTION_INSCAN;
1389 else if (gfc_match ("task") == MATCH_YES)
1390 list_idx = OMP_LIST_REDUCTION_TASK;
1391 else if (gfc_match ("default") == MATCH_YES)
1392 list_idx = OMP_LIST_REDUCTION;
1393 if (list_idx != 0 && gfc_match (", ") != MATCH_YES)
1394 {
1395 gfc_error ("Comma expected at %C");
1396 gfc_current_locus = old_loc;
1397 return MATCH_NO;
1398 }
1399 if (list_idx == 0)
1400 list_idx = OMP_LIST_REDUCTION;
1401 }
1402 else if (pc == 'i')
1403 list_idx = OMP_LIST_IN_REDUCTION;
1404 else if (pc == 't')
1405 list_idx = OMP_LIST_TASK_REDUCTION;
1406 else
1407 list_idx = OMP_LIST_REDUCTION;
1408
1409 gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
1410 char buffer[GFC_MAX_SYMBOL_LEN + 3];
1411 if (gfc_match_char ('+') == MATCH_YES)
1412 rop = OMP_REDUCTION_PLUS;
1413 else if (gfc_match_char ('*') == MATCH_YES)
1414 rop = OMP_REDUCTION_TIMES;
1415 else if (gfc_match_char ('-') == MATCH_YES)
1416 rop = OMP_REDUCTION_MINUS;
1417 else if (gfc_match (".and.") == MATCH_YES)
1418 rop = OMP_REDUCTION_AND;
1419 else if (gfc_match (".or.") == MATCH_YES)
1420 rop = OMP_REDUCTION_OR;
1421 else if (gfc_match (".eqv.") == MATCH_YES)
1422 rop = OMP_REDUCTION_EQV;
1423 else if (gfc_match (".neqv.") == MATCH_YES)
1424 rop = OMP_REDUCTION_NEQV;
1425 if (rop != OMP_REDUCTION_NONE)
1426 snprintf (s: buffer, maxlen: sizeof buffer, format: "operator %s",
1427 gfc_op2string ((gfc_intrinsic_op) rop));
1428 else if (gfc_match_defined_op_name (buffer + 1, 1) == MATCH_YES)
1429 {
1430 buffer[0] = '.';
1431 strcat (dest: buffer, src: ".");
1432 }
1433 else if (gfc_match_name (buffer) == MATCH_YES)
1434 {
1435 gfc_symbol *sym;
1436 const char *n = buffer;
1437
1438 gfc_find_symbol (buffer, NULL, 1, &sym);
1439 if (sym != NULL)
1440 {
1441 if (sym->attr.intrinsic)
1442 n = sym->name;
1443 else if ((sym->attr.flavor != FL_UNKNOWN
1444 && sym->attr.flavor != FL_PROCEDURE)
1445 || sym->attr.external
1446 || sym->attr.generic
1447 || sym->attr.entry
1448 || sym->attr.result
1449 || sym->attr.dummy
1450 || sym->attr.subroutine
1451 || sym->attr.pointer
1452 || sym->attr.target
1453 || sym->attr.cray_pointer
1454 || sym->attr.cray_pointee
1455 || (sym->attr.proc != PROC_UNKNOWN
1456 && sym->attr.proc != PROC_INTRINSIC)
1457 || sym->attr.if_source != IFSRC_UNKNOWN
1458 || sym == sym->ns->proc_name)
1459 {
1460 sym = NULL;
1461 n = NULL;
1462 }
1463 else
1464 n = sym->name;
1465 }
1466 if (n == NULL)
1467 rop = OMP_REDUCTION_NONE;
1468 else if (strcmp (s1: n, s2: "max") == 0)
1469 rop = OMP_REDUCTION_MAX;
1470 else if (strcmp (s1: n, s2: "min") == 0)
1471 rop = OMP_REDUCTION_MIN;
1472 else if (strcmp (s1: n, s2: "iand") == 0)
1473 rop = OMP_REDUCTION_IAND;
1474 else if (strcmp (s1: n, s2: "ior") == 0)
1475 rop = OMP_REDUCTION_IOR;
1476 else if (strcmp (s1: n, s2: "ieor") == 0)
1477 rop = OMP_REDUCTION_IEOR;
1478 if (rop != OMP_REDUCTION_NONE
1479 && sym != NULL
1480 && ! sym->attr.intrinsic
1481 && ! sym->attr.use_assoc
1482 && ((sym->attr.flavor == FL_UNKNOWN
1483 && !gfc_add_flavor (&sym->attr, FL_PROCEDURE,
1484 sym->name, NULL))
1485 || !gfc_add_intrinsic (&sym->attr, NULL)))
1486 rop = OMP_REDUCTION_NONE;
1487 }
1488 else
1489 buffer[0] = '\0';
1490 gfc_omp_udr *udr = (buffer[0] ? gfc_find_omp_udr (ns: gfc_current_ns, name: buffer, NULL)
1491 : NULL);
1492 gfc_omp_namelist **head = NULL;
1493 if (rop == OMP_REDUCTION_NONE && udr)
1494 rop = OMP_REDUCTION_USER;
1495
1496 if (gfc_match_omp_variable_list (str: " :", list: &c->lists[list_idx], allow_common: false, NULL,
1497 headp: &head, allow_sections: openacc, allow_derived) != MATCH_YES)
1498 {
1499 gfc_current_locus = old_loc;
1500 return MATCH_NO;
1501 }
1502 gfc_omp_namelist *n;
1503 if (rop == OMP_REDUCTION_NONE)
1504 {
1505 n = *head;
1506 *head = NULL;
1507 gfc_error_now ("!$OMP DECLARE REDUCTION %s not found at %L",
1508 buffer, &old_loc);
1509 gfc_free_omp_namelist (n, false, false, false);
1510 }
1511 else
1512 for (n = *head; n; n = n->next)
1513 {
1514 n->u.reduction_op = rop;
1515 if (udr)
1516 {
1517 n->u2.udr = gfc_get_omp_namelist_udr ();
1518 n->u2.udr->udr = udr;
1519 }
1520 if (openmp_target && list_idx == OMP_LIST_IN_REDUCTION)
1521 {
1522 gfc_omp_namelist *p = gfc_get_omp_namelist (), **tl;
1523 p->sym = n->sym;
1524 p->where = p->where;
1525 p->u.map_op = OMP_MAP_ALWAYS_TOFROM;
1526
1527 tl = &c->lists[OMP_LIST_MAP];
1528 while (*tl)
1529 tl = &((*tl)->next);
1530 *tl = p;
1531 p->next = NULL;
1532 }
1533 }
1534 return MATCH_YES;
1535}
1536
1537static match
1538gfc_omp_absent_contains_clause (gfc_omp_assumptions **assume, bool is_absent)
1539{
1540 if (*assume == NULL)
1541 *assume = gfc_get_omp_assumptions ();
1542 do
1543 {
1544 gfc_statement st = ST_NONE;
1545 gfc_gobble_whitespace ();
1546 locus old_loc = gfc_current_locus;
1547 char c = gfc_peek_ascii_char ();
1548 enum gfc_omp_directive_kind kind
1549 = GFC_OMP_DIR_DECLARATIVE; /* Silence warning. */
1550 for (size_t i = 0; i < ARRAY_SIZE (gfc_omp_directives); i++)
1551 {
1552 if (gfc_omp_directives[i].name[0] > c)
1553 break;
1554 if (gfc_omp_directives[i].name[0] != c)
1555 continue;
1556 if (gfc_match (gfc_omp_directives[i].name) == MATCH_YES)
1557 {
1558 st = gfc_omp_directives[i].st;
1559 kind = gfc_omp_directives[i].kind;
1560 }
1561 }
1562 gfc_gobble_whitespace ();
1563 c = gfc_peek_ascii_char ();
1564 if (st == ST_NONE || (c != ',' && c != ')'))
1565 {
1566 if (st == ST_NONE)
1567 gfc_error ("Unknown directive at %L", &old_loc);
1568 else
1569 gfc_error ("Invalid combined or composite directive at %L",
1570 &old_loc);
1571 return MATCH_ERROR;
1572 }
1573 if (kind == GFC_OMP_DIR_DECLARATIVE
1574 || kind == GFC_OMP_DIR_INFORMATIONAL
1575 || kind == GFC_OMP_DIR_META)
1576 {
1577 gfc_error ("Invalid %qs directive at %L in %s clause: declarative, "
1578 "informational and meta directives not permitted",
1579 gfc_ascii_statement (st, strip_sentinel: true), &old_loc,
1580 is_absent ? "ABSENT" : "CONTAINS");
1581 return MATCH_ERROR;
1582 }
1583 if (is_absent)
1584 {
1585 /* Use exponential allocation; equivalent to pow2p(x). */
1586 int i = (*assume)->n_absent;
1587 int size = ((i == 0) ? 4
1588 : pow2p_hwi (x: i) == 1 ? i*2 : 0);
1589 if (size != 0)
1590 (*assume)->absent = XRESIZEVEC (gfc_statement,
1591 (*assume)->absent, size);
1592 (*assume)->absent[(*assume)->n_absent++] = st;
1593 }
1594 else
1595 {
1596 int i = (*assume)->n_contains;
1597 int size = ((i == 0) ? 4
1598 : pow2p_hwi (x: i) == 1 ? i*2 : 0);
1599 if (size != 0)
1600 (*assume)->contains = XRESIZEVEC (gfc_statement,
1601 (*assume)->contains, size);
1602 (*assume)->contains[(*assume)->n_contains++] = st;
1603 }
1604 gfc_gobble_whitespace ();
1605 if (gfc_match(",") == MATCH_YES)
1606 continue;
1607 if (gfc_match(")") == MATCH_YES)
1608 break;
1609 gfc_error ("Expected %<,%> or %<)%> at %C");
1610 return MATCH_ERROR;
1611 }
1612 while (true);
1613
1614 return MATCH_YES;
1615}
1616
1617/* Check 'check' argument for duplicated statements in absent and/or contains
1618 clauses. If 'merge', merge them from check to 'merge'. */
1619
1620static match
1621omp_verify_merge_absent_contains (gfc_statement st, gfc_omp_assumptions *check,
1622 gfc_omp_assumptions *merge, locus *loc)
1623{
1624 if (check == NULL)
1625 return MATCH_YES;
1626 bitmap_head absent_head, contains_head;
1627 bitmap_obstack_initialize (NULL);
1628 bitmap_initialize (head: &absent_head, obstack: &bitmap_default_obstack);
1629 bitmap_initialize (head: &contains_head, obstack: &bitmap_default_obstack);
1630
1631 match m = MATCH_YES;
1632 for (int i = 0; i < check->n_absent; i++)
1633 if (!bitmap_set_bit (&absent_head, check->absent[i]))
1634 {
1635 gfc_error ("%qs directive mentioned multiple times in %s clause in %s "
1636 "directive at %L",
1637 gfc_ascii_statement (check->absent[i], strip_sentinel: true),
1638 "ABSENT", gfc_ascii_statement (st), loc);
1639 m = MATCH_ERROR;
1640 }
1641 for (int i = 0; i < check->n_contains; i++)
1642 {
1643 if (!bitmap_set_bit (&contains_head, check->contains[i]))
1644 {
1645 gfc_error ("%qs directive mentioned multiple times in %s clause in %s "
1646 "directive at %L",
1647 gfc_ascii_statement (check->contains[i], strip_sentinel: true),
1648 "CONTAINS", gfc_ascii_statement (st), loc);
1649 m = MATCH_ERROR;
1650 }
1651 if (bitmap_bit_p (&absent_head, check->contains[i]))
1652 {
1653 gfc_error ("%qs directive mentioned both times in ABSENT and CONTAINS "
1654 "clauses in %s directive at %L",
1655 gfc_ascii_statement (check->absent[i], strip_sentinel: true),
1656 gfc_ascii_statement (st), loc);
1657 m = MATCH_ERROR;
1658 }
1659 }
1660
1661 if (m == MATCH_ERROR)
1662 return MATCH_ERROR;
1663 if (merge == NULL)
1664 return MATCH_YES;
1665 if (merge->absent == NULL && check->absent)
1666 {
1667 merge->n_absent = check->n_absent;
1668 merge->absent = check->absent;
1669 check->absent = NULL;
1670 }
1671 else if (merge->absent && check->absent)
1672 {
1673 check->absent = XRESIZEVEC (gfc_statement, check->absent,
1674 merge->n_absent + check->n_absent);
1675 for (int i = 0; i < merge->n_absent; i++)
1676 if (!bitmap_bit_p (&absent_head, merge->absent[i]))
1677 check->absent[check->n_absent++] = merge->absent[i];
1678 free (ptr: merge->absent);
1679 merge->absent = check->absent;
1680 merge->n_absent = check->n_absent;
1681 check->absent = NULL;
1682 }
1683 if (merge->contains == NULL && check->contains)
1684 {
1685 merge->n_contains = check->n_contains;
1686 merge->contains = check->contains;
1687 check->contains = NULL;
1688 }
1689 else if (merge->contains && check->contains)
1690 {
1691 check->contains = XRESIZEVEC (gfc_statement, check->contains,
1692 merge->n_contains + check->n_contains);
1693 for (int i = 0; i < merge->n_contains; i++)
1694 if (!bitmap_bit_p (&contains_head, merge->contains[i]))
1695 check->contains[check->n_contains++] = merge->contains[i];
1696 free (ptr: merge->contains);
1697 merge->contains = check->contains;
1698 merge->n_contains = check->n_contains;
1699 check->contains = NULL;
1700 }
1701 return MATCH_YES;
1702}
1703
1704/* OpenMP 5.0
1705 uses_allocators ( allocator-list )
1706
1707 allocator:
1708 predefined-allocator
1709 variable ( traits-array )
1710
1711 OpenMP 5.2:
1712 uses_allocators ( [modifier-list :] allocator-list )
1713
1714 allocator:
1715 variable or predefined-allocator
1716 modifier:
1717 traits ( traits-array )
1718 memspace ( mem-space-handle ) */
1719
1720static match
1721gfc_match_omp_clause_uses_allocators (gfc_omp_clauses *c)
1722{
1723 gfc_symbol *memspace_sym = NULL;
1724 gfc_symbol *traits_sym = NULL;
1725 gfc_omp_namelist *head = NULL;
1726 gfc_omp_namelist *p, *tail, **list;
1727 int ntraits, nmemspace;
1728 bool has_modifiers;
1729 locus old_loc, cur_loc;
1730
1731 gfc_gobble_whitespace ();
1732 old_loc = gfc_current_locus;
1733 ntraits = nmemspace = 0;
1734 do
1735 {
1736 cur_loc = gfc_current_locus;
1737 if (gfc_match ("traits ( %S ) ", &traits_sym) == MATCH_YES)
1738 ntraits++;
1739 else if (gfc_match ("memspace ( %S ) ", &memspace_sym) == MATCH_YES)
1740 nmemspace++;
1741 if (ntraits > 1 || nmemspace > 1)
1742 {
1743 gfc_error ("Duplicate %s modifier at %L in USES_ALLOCATORS clause",
1744 ntraits > 1 ? "TRAITS" : "MEMSPACE", &cur_loc);
1745 return MATCH_ERROR;
1746 }
1747 if (gfc_match (", ") == MATCH_YES)
1748 continue;
1749 if (gfc_match (": ") != MATCH_YES)
1750 {
1751 /* Assume no modifier. */
1752 memspace_sym = traits_sym = NULL;
1753 gfc_current_locus = old_loc;
1754 break;
1755 }
1756 break;
1757 } while (true);
1758
1759 has_modifiers = traits_sym != NULL || memspace_sym != NULL;
1760 do
1761 {
1762 p = gfc_get_omp_namelist ();
1763 p->where = gfc_current_locus;
1764 if (head == NULL)
1765 head = tail = p;
1766 else
1767 {
1768 tail->next = p;
1769 tail = tail->next;
1770 }
1771 if (gfc_match ("%S ", &p->sym) != MATCH_YES)
1772 goto error;
1773 if (!has_modifiers)
1774 gfc_match ("( %S ) ", &p->u2.traits_sym);
1775 else if (gfc_peek_ascii_char () == '(')
1776 {
1777 gfc_error ("Unexpected %<(%> at %C");
1778 goto error;
1779 }
1780 else
1781 {
1782 p->u.memspace_sym = memspace_sym;
1783 p->u2.traits_sym = traits_sym;
1784 }
1785 if (gfc_match (", ") == MATCH_YES)
1786 continue;
1787 if (gfc_match (") ") == MATCH_YES)
1788 break;
1789 goto error;
1790 } while (true);
1791
1792 list = &c->lists[OMP_LIST_USES_ALLOCATORS];
1793 while (*list)
1794 list = &(*list)->next;
1795 *list = head;
1796
1797 return MATCH_YES;
1798
1799error:
1800 gfc_free_omp_namelist (head, false, false, true);
1801 return MATCH_ERROR;
1802}
1803
1804
1805/* Match with duplicate check. Matches 'name'. If expr != NULL, it
1806 then matches '(expr)', otherwise, if open_parens is true,
1807 it matches a ' ( ' after 'name'.
1808 dupl_message requires '%qs %L' - and is used by
1809 gfc_match_dupl_memorder and gfc_match_dupl_atomic. */
1810
1811static match
1812gfc_match_dupl_check (bool not_dupl, const char *name, bool open_parens = false,
1813 gfc_expr **expr = NULL, const char *dupl_msg = NULL)
1814{
1815 match m;
1816 locus old_loc = gfc_current_locus;
1817 if ((m = gfc_match (name)) != MATCH_YES)
1818 return m;
1819 if (!not_dupl)
1820 {
1821 if (dupl_msg)
1822 gfc_error (dupl_msg, name, &old_loc);
1823 else
1824 gfc_error ("Duplicated %qs clause at %L", name, &old_loc);
1825 return MATCH_ERROR;
1826 }
1827 if (open_parens || expr)
1828 {
1829 if (gfc_match (" ( ") != MATCH_YES)
1830 {
1831 gfc_error ("Expected %<(%> after %qs at %C", name);
1832 return MATCH_ERROR;
1833 }
1834 if (expr)
1835 {
1836 if (gfc_match ("%e )", expr) != MATCH_YES)
1837 {
1838 gfc_error ("Invalid expression after %<%s(%> at %C", name);
1839 return MATCH_ERROR;
1840 }
1841 }
1842 }
1843 return MATCH_YES;
1844}
1845
1846static match
1847gfc_match_dupl_memorder (bool not_dupl, const char *name)
1848{
1849 return gfc_match_dupl_check (not_dupl, name, open_parens: false, NULL,
1850 dupl_msg: "Duplicated memory-order clause: unexpected %s "
1851 "clause at %L");
1852}
1853
1854static match
1855gfc_match_dupl_atomic (bool not_dupl, const char *name)
1856{
1857 return gfc_match_dupl_check (not_dupl, name, open_parens: false, NULL,
1858 dupl_msg: "Duplicated atomic clause: unexpected %s "
1859 "clause at %L");
1860}
1861
1862/* Match OpenMP and OpenACC directive clauses. MASK is a bitmask of
1863 clauses that are allowed for a particular directive. */
1864
1865static match
1866gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
1867 bool first = true, bool needs_space = true,
1868 bool openacc = false, bool context_selector = false,
1869 bool openmp_target = false)
1870{
1871 bool error = false;
1872 gfc_omp_clauses *c = gfc_get_omp_clauses ();
1873 locus old_loc;
1874 /* Determine whether we're dealing with an OpenACC directive that permits
1875 derived type member accesses. This in particular disallows
1876 "!$acc declare" from using such accesses, because it's not clear if/how
1877 that should work. */
1878 bool allow_derived = (openacc
1879 && ((mask & OMP_CLAUSE_ATTACH)
1880 || (mask & OMP_CLAUSE_DETACH)));
1881
1882 gcc_checking_assert (OMP_MASK1_LAST <= 64 && OMP_MASK2_LAST <= 64);
1883 *cp = NULL;
1884 while (1)
1885 {
1886 match m = MATCH_NO;
1887 if ((first || (m = gfc_match_char (',')) != MATCH_YES)
1888 && (needs_space && gfc_match_space () != MATCH_YES))
1889 break;
1890 needs_space = false;
1891 first = false;
1892 gfc_gobble_whitespace ();
1893 bool end_colon;
1894 gfc_omp_namelist **head;
1895 old_loc = gfc_current_locus;
1896 char pc = gfc_peek_ascii_char ();
1897 if (pc == '\n' && m == MATCH_YES)
1898 {
1899 gfc_error ("Clause expected at %C after trailing comma");
1900 goto error;
1901 }
1902 switch (pc)
1903 {
1904 case 'a':
1905 end_colon = false;
1906 head = NULL;
1907 if ((mask & OMP_CLAUSE_ASSUMPTIONS)
1908 && gfc_match ("absent ( ") == MATCH_YES)
1909 {
1910 if (gfc_omp_absent_contains_clause (assume: &c->assume, is_absent: true)
1911 != MATCH_YES)
1912 goto error;
1913 continue;
1914 }
1915 if ((mask & OMP_CLAUSE_ALIGNED)
1916 && gfc_match_omp_variable_list (str: "aligned (",
1917 list: &c->lists[OMP_LIST_ALIGNED],
1918 allow_common: false, end_colon: &end_colon,
1919 headp: &head) == MATCH_YES)
1920 {
1921 gfc_expr *alignment = NULL;
1922 gfc_omp_namelist *n;
1923
1924 if (end_colon && gfc_match (" %e )", &alignment) != MATCH_YES)
1925 {
1926 gfc_free_omp_namelist (*head, false, false, false);
1927 gfc_current_locus = old_loc;
1928 *head = NULL;
1929 break;
1930 }
1931 for (n = *head; n; n = n->next)
1932 if (n->next && alignment)
1933 n->expr = gfc_copy_expr (alignment);
1934 else
1935 n->expr = alignment;
1936 continue;
1937 }
1938 if ((mask & OMP_CLAUSE_MEMORDER)
1939 && (m = gfc_match_dupl_memorder (not_dupl: (c->memorder
1940 == OMP_MEMORDER_UNSET),
1941 name: "acq_rel")) != MATCH_NO)
1942 {
1943 if (m == MATCH_ERROR)
1944 goto error;
1945 c->memorder = OMP_MEMORDER_ACQ_REL;
1946 needs_space = true;
1947 continue;
1948 }
1949 if ((mask & OMP_CLAUSE_MEMORDER)
1950 && (m = gfc_match_dupl_memorder (not_dupl: (c->memorder
1951 == OMP_MEMORDER_UNSET),
1952 name: "acquire")) != MATCH_NO)
1953 {
1954 if (m == MATCH_ERROR)
1955 goto error;
1956 c->memorder = OMP_MEMORDER_ACQUIRE;
1957 needs_space = true;
1958 continue;
1959 }
1960 if ((mask & OMP_CLAUSE_AFFINITY)
1961 && gfc_match ("affinity ( ") == MATCH_YES)
1962 {
1963 gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
1964 m = gfc_match_iterator (ns: &ns_iter, permit_var: true);
1965 if (m == MATCH_ERROR)
1966 break;
1967 if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES)
1968 {
1969 gfc_error ("Expected %<:%> at %C");
1970 break;
1971 }
1972 if (ns_iter)
1973 gfc_current_ns = ns_iter;
1974 head = NULL;
1975 m = gfc_match_omp_variable_list (str: "", list: &c->lists[OMP_LIST_AFFINITY],
1976 allow_common: false, NULL, headp: &head, allow_sections: true);
1977 gfc_current_ns = ns_curr;
1978 if (m == MATCH_ERROR)
1979 break;
1980 if (ns_iter)
1981 {
1982 for (gfc_omp_namelist *n = *head; n; n = n->next)
1983 {
1984 n->u2.ns = ns_iter;
1985 ns_iter->refs++;
1986 }
1987 }
1988 continue;
1989 }
1990 if ((mask & OMP_CLAUSE_ALLOCATE)
1991 && gfc_match ("allocate ( ") == MATCH_YES)
1992 {
1993 gfc_expr *allocator = NULL;
1994 gfc_expr *align = NULL;
1995 old_loc = gfc_current_locus;
1996 if ((m = gfc_match ("allocator ( %e )", &allocator)) == MATCH_YES)
1997 gfc_match (" , align ( %e )", &align);
1998 else if ((m = gfc_match ("align ( %e )", &align)) == MATCH_YES)
1999 gfc_match (" , allocator ( %e )", &allocator);
2000
2001 if (m == MATCH_YES)
2002 {
2003 if (gfc_match (" : ") != MATCH_YES)
2004 {
2005 gfc_error ("Expected %<:%> at %C");
2006 goto error;
2007 }
2008 }
2009 else
2010 {
2011 m = gfc_match_expr (&allocator);
2012 if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES)
2013 {
2014 /* If no ":" then there is no allocator, we backtrack
2015 and read the variable list. */
2016 gfc_free_expr (allocator);
2017 allocator = NULL;
2018 gfc_current_locus = old_loc;
2019 }
2020 }
2021 gfc_omp_namelist **head = NULL;
2022 m = gfc_match_omp_variable_list (str: "", list: &c->lists[OMP_LIST_ALLOCATE],
2023 allow_common: true, NULL, headp: &head);
2024
2025 if (m != MATCH_YES)
2026 {
2027 gfc_free_expr (allocator);
2028 gfc_free_expr (align);
2029 gfc_error ("Expected variable list at %C");
2030 goto error;
2031 }
2032
2033 for (gfc_omp_namelist *n = *head; n; n = n->next)
2034 {
2035 n->u2.allocator = allocator;
2036 n->u.align = (align) ? gfc_copy_expr (align) : NULL;
2037 }
2038 gfc_free_expr (align);
2039 continue;
2040 }
2041 if ((mask & OMP_CLAUSE_AT)
2042 && (m = gfc_match_dupl_check (not_dupl: c->at == OMP_AT_UNSET, name: "at", open_parens: true))
2043 != MATCH_NO)
2044 {
2045 if (m == MATCH_ERROR)
2046 goto error;
2047 if (gfc_match ("compilation )") == MATCH_YES)
2048 c->at = OMP_AT_COMPILATION;
2049 else if (gfc_match ("execution )") == MATCH_YES)
2050 c->at = OMP_AT_EXECUTION;
2051 else
2052 {
2053 gfc_error ("Expected COMPILATION or EXECUTION in AT clause "
2054 "at %C");
2055 goto error;
2056 }
2057 continue;
2058 }
2059 if ((mask & OMP_CLAUSE_ASYNC)
2060 && (m = gfc_match_dupl_check (not_dupl: !c->async, name: "async")) != MATCH_NO)
2061 {
2062 if (m == MATCH_ERROR)
2063 goto error;
2064 c->async = true;
2065 m = gfc_match (" ( %e )", &c->async_expr);
2066 if (m == MATCH_ERROR)
2067 {
2068 gfc_current_locus = old_loc;
2069 break;
2070 }
2071 else if (m == MATCH_NO)
2072 {
2073 c->async_expr
2074 = gfc_get_constant_expr (BT_INTEGER,
2075 gfc_default_integer_kind,
2076 &gfc_current_locus);
2077 mpz_set_si (c->async_expr->value.integer, GOMP_ASYNC_NOVAL);
2078 needs_space = true;
2079 }
2080 continue;
2081 }
2082 if ((mask & OMP_CLAUSE_AUTO)
2083 && (m = gfc_match_dupl_check (not_dupl: !c->par_auto, name: "auto"))
2084 != MATCH_NO)
2085 {
2086 if (m == MATCH_ERROR)
2087 goto error;
2088 c->par_auto = true;
2089 needs_space = true;
2090 continue;
2091 }
2092 if ((mask & OMP_CLAUSE_ATTACH)
2093 && gfc_match ("attach ( ") == MATCH_YES
2094 && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP],
2095 map_op: OMP_MAP_ATTACH, allow_common: false,
2096 allow_derived))
2097 continue;
2098 break;
2099 case 'b':
2100 if ((mask & OMP_CLAUSE_BIND)
2101 && (m = gfc_match_dupl_check (not_dupl: c->bind == OMP_BIND_UNSET, name: "bind",
2102 open_parens: true)) != MATCH_NO)
2103 {
2104 if (m == MATCH_ERROR)
2105 goto error;
2106 if (gfc_match ("teams )") == MATCH_YES)
2107 c->bind = OMP_BIND_TEAMS;
2108 else if (gfc_match ("parallel )") == MATCH_YES)
2109 c->bind = OMP_BIND_PARALLEL;
2110 else if (gfc_match ("thread )") == MATCH_YES)
2111 c->bind = OMP_BIND_THREAD;
2112 else
2113 {
2114 gfc_error ("Expected TEAMS, PARALLEL or THREAD as binding in "
2115 "BIND at %C");
2116 break;
2117 }
2118 continue;
2119 }
2120 break;
2121 case 'c':
2122 if ((mask & OMP_CLAUSE_CAPTURE)
2123 && (m = gfc_match_dupl_check (not_dupl: !c->capture, name: "capture"))
2124 != MATCH_NO)
2125 {
2126 if (m == MATCH_ERROR)
2127 goto error;
2128 c->capture = true;
2129 needs_space = true;
2130 continue;
2131 }
2132 if (mask & OMP_CLAUSE_COLLAPSE)
2133 {
2134 gfc_expr *cexpr = NULL;
2135 if ((m = gfc_match_dupl_check (not_dupl: !c->collapse, name: "collapse", open_parens: true,
2136 expr: &cexpr)) != MATCH_NO)
2137 {
2138 int collapse;
2139 if (m == MATCH_ERROR)
2140 goto error;
2141 if (gfc_extract_int (cexpr, &collapse, -1))
2142 collapse = 1;
2143 else if (collapse <= 0)
2144 {
2145 gfc_error_now ("COLLAPSE clause argument not constant "
2146 "positive integer at %C");
2147 collapse = 1;
2148 }
2149 gfc_free_expr (cexpr);
2150 c->collapse = collapse;
2151 continue;
2152 }
2153 }
2154 if ((mask & OMP_CLAUSE_COMPARE)
2155 && (m = gfc_match_dupl_check (not_dupl: !c->compare, name: "compare"))
2156 != MATCH_NO)
2157 {
2158 if (m == MATCH_ERROR)
2159 goto error;
2160 c->compare = true;
2161 needs_space = true;
2162 continue;
2163 }
2164 if ((mask & OMP_CLAUSE_ASSUMPTIONS)
2165 && gfc_match ("contains ( ") == MATCH_YES)
2166 {
2167 if (gfc_omp_absent_contains_clause (assume: &c->assume, is_absent: false)
2168 != MATCH_YES)
2169 goto error;
2170 continue;
2171 }
2172 if ((mask & OMP_CLAUSE_COPY)
2173 && gfc_match ("copy ( ") == MATCH_YES
2174 && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP],
2175 map_op: OMP_MAP_TOFROM, allow_common: true,
2176 allow_derived))
2177 continue;
2178 if (mask & OMP_CLAUSE_COPYIN)
2179 {
2180 if (openacc)
2181 {
2182 if (gfc_match ("copyin ( ") == MATCH_YES
2183 && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP],
2184 map_op: OMP_MAP_TO, allow_common: true,
2185 allow_derived))
2186 continue;
2187 }
2188 else if (gfc_match_omp_variable_list (str: "copyin (",
2189 list: &c->lists[OMP_LIST_COPYIN],
2190 allow_common: true) == MATCH_YES)
2191 continue;
2192 }
2193 if ((mask & OMP_CLAUSE_COPYOUT)
2194 && gfc_match ("copyout ( ") == MATCH_YES
2195 && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP],
2196 map_op: OMP_MAP_FROM, allow_common: true, allow_derived))
2197 continue;
2198 if ((mask & OMP_CLAUSE_COPYPRIVATE)
2199 && gfc_match_omp_variable_list (str: "copyprivate (",
2200 list: &c->lists[OMP_LIST_COPYPRIVATE],
2201 allow_common: true) == MATCH_YES)
2202 continue;
2203 if ((mask & OMP_CLAUSE_CREATE)
2204 && gfc_match ("create ( ") == MATCH_YES
2205 && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP],
2206 map_op: OMP_MAP_ALLOC, allow_common: true, allow_derived))
2207 continue;
2208 break;
2209 case 'd':
2210 if ((mask & OMP_CLAUSE_DEFAULTMAP)
2211 && gfc_match ("defaultmap ( ") == MATCH_YES)
2212 {
2213 enum gfc_omp_defaultmap behavior;
2214 gfc_omp_defaultmap_category category
2215 = OMP_DEFAULTMAP_CAT_UNCATEGORIZED;
2216 if (gfc_match ("alloc ") == MATCH_YES)
2217 behavior = OMP_DEFAULTMAP_ALLOC;
2218 else if (gfc_match ("tofrom ") == MATCH_YES)
2219 behavior = OMP_DEFAULTMAP_TOFROM;
2220 else if (gfc_match ("to ") == MATCH_YES)
2221 behavior = OMP_DEFAULTMAP_TO;
2222 else if (gfc_match ("from ") == MATCH_YES)
2223 behavior = OMP_DEFAULTMAP_FROM;
2224 else if (gfc_match ("firstprivate ") == MATCH_YES)
2225 behavior = OMP_DEFAULTMAP_FIRSTPRIVATE;
2226 else if (gfc_match ("present ") == MATCH_YES)
2227 behavior = OMP_DEFAULTMAP_PRESENT;
2228 else if (gfc_match ("none ") == MATCH_YES)
2229 behavior = OMP_DEFAULTMAP_NONE;
2230 else if (gfc_match ("default ") == MATCH_YES)
2231 behavior = OMP_DEFAULTMAP_DEFAULT;
2232 else
2233 {
2234 gfc_error ("Expected ALLOC, TO, FROM, TOFROM, FIRSTPRIVATE, "
2235 "PRESENT, NONE or DEFAULT at %C");
2236 break;
2237 }
2238 if (')' == gfc_peek_ascii_char ())
2239 ;
2240 else if (gfc_match (": ") != MATCH_YES)
2241 break;
2242 else
2243 {
2244 if (gfc_match ("scalar ") == MATCH_YES)
2245 category = OMP_DEFAULTMAP_CAT_SCALAR;
2246 else if (gfc_match ("aggregate ") == MATCH_YES)
2247 category = OMP_DEFAULTMAP_CAT_AGGREGATE;
2248 else if (gfc_match ("allocatable ") == MATCH_YES)
2249 category = OMP_DEFAULTMAP_CAT_ALLOCATABLE;
2250 else if (gfc_match ("pointer ") == MATCH_YES)
2251 category = OMP_DEFAULTMAP_CAT_POINTER;
2252 else if (gfc_match ("all ") == MATCH_YES)
2253 category = OMP_DEFAULTMAP_CAT_ALL;
2254 else
2255 {
2256 gfc_error ("Expected SCALAR, AGGREGATE, ALLOCATABLE, "
2257 "POINTER or ALL at %C");
2258 break;
2259 }
2260 }
2261 for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; ++i)
2262 {
2263 if (i != category
2264 && category != OMP_DEFAULTMAP_CAT_UNCATEGORIZED
2265 && category != OMP_DEFAULTMAP_CAT_ALL
2266 && i != OMP_DEFAULTMAP_CAT_UNCATEGORIZED
2267 && i != OMP_DEFAULTMAP_CAT_ALL)
2268 continue;
2269 if (c->defaultmap[i] != OMP_DEFAULTMAP_UNSET)
2270 {
2271 const char *pcategory = NULL;
2272 switch (i)
2273 {
2274 case OMP_DEFAULTMAP_CAT_UNCATEGORIZED: break;
2275 case OMP_DEFAULTMAP_CAT_ALL: pcategory = "ALL"; break;
2276 case OMP_DEFAULTMAP_CAT_SCALAR: pcategory = "SCALAR"; break;
2277 case OMP_DEFAULTMAP_CAT_AGGREGATE:
2278 pcategory = "AGGREGATE";
2279 break;
2280 case OMP_DEFAULTMAP_CAT_ALLOCATABLE:
2281 pcategory = "ALLOCATABLE";
2282 break;
2283 case OMP_DEFAULTMAP_CAT_POINTER:
2284 pcategory = "POINTER";
2285 break;
2286 default: gcc_unreachable ();
2287 }
2288 if (i == OMP_DEFAULTMAP_CAT_UNCATEGORIZED)
2289 gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP with "
2290 "unspecified category");
2291 else
2292 gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP for "
2293 "category %s", pcategory);
2294 goto error;
2295 }
2296 }
2297 c->defaultmap[category] = behavior;
2298 if (gfc_match (")") != MATCH_YES)
2299 break;
2300 continue;
2301 }
2302 if ((mask & OMP_CLAUSE_DEFAULT)
2303 && (m = gfc_match_dupl_check (not_dupl: c->default_sharing
2304 == OMP_DEFAULT_UNKNOWN, name: "default",
2305 open_parens: true)) != MATCH_NO)
2306 {
2307 if (m == MATCH_ERROR)
2308 goto error;
2309 if (gfc_match ("none") == MATCH_YES)
2310 c->default_sharing = OMP_DEFAULT_NONE;
2311 else if (openacc)
2312 {
2313 if (gfc_match ("present") == MATCH_YES)
2314 c->default_sharing = OMP_DEFAULT_PRESENT;
2315 }
2316 else
2317 {
2318 if (gfc_match ("firstprivate") == MATCH_YES)
2319 c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE;
2320 else if (gfc_match ("private") == MATCH_YES)
2321 c->default_sharing = OMP_DEFAULT_PRIVATE;
2322 else if (gfc_match ("shared") == MATCH_YES)
2323 c->default_sharing = OMP_DEFAULT_SHARED;
2324 }
2325 if (c->default_sharing == OMP_DEFAULT_UNKNOWN)
2326 {
2327 if (openacc)
2328 gfc_error ("Expected NONE or PRESENT in DEFAULT clause "
2329 "at %C");
2330 else
2331 gfc_error ("Expected NONE, FIRSTPRIVATE, PRIVATE or SHARED "
2332 "in DEFAULT clause at %C");
2333 goto error;
2334 }
2335 if (gfc_match (" )") != MATCH_YES)
2336 goto error;
2337 continue;
2338 }
2339 if ((mask & OMP_CLAUSE_DELETE)
2340 && gfc_match ("delete ( ") == MATCH_YES
2341 && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP],
2342 map_op: OMP_MAP_RELEASE, allow_common: true,
2343 allow_derived))
2344 continue;
2345 /* DOACROSS: match 'doacross' and 'depend' with sink/source.
2346 DEPEND: match 'depend' but not sink/source. */
2347 m = MATCH_NO;
2348 if (((mask & OMP_CLAUSE_DOACROSS)
2349 && gfc_match ("doacross ( ") == MATCH_YES)
2350 || (((mask & OMP_CLAUSE_DEPEND) || (mask & OMP_CLAUSE_DOACROSS))
2351 && (m = gfc_match ("depend ( ")) == MATCH_YES))
2352 {
2353 bool has_omp_all_memory;
2354 bool is_depend = m == MATCH_YES;
2355 gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
2356 match m_it = MATCH_NO;
2357 if (is_depend)
2358 m_it = gfc_match_iterator (ns: &ns_iter, permit_var: false);
2359 if (m_it == MATCH_ERROR)
2360 break;
2361 if (m_it == MATCH_YES && gfc_match (" , ") != MATCH_YES)
2362 break;
2363 m = MATCH_YES;
2364 gfc_omp_depend_doacross_op depend_op = OMP_DEPEND_OUT;
2365 if (gfc_match ("inoutset") == MATCH_YES)
2366 depend_op = OMP_DEPEND_INOUTSET;
2367 else if (gfc_match ("inout") == MATCH_YES)
2368 depend_op = OMP_DEPEND_INOUT;
2369 else if (gfc_match ("in") == MATCH_YES)
2370 depend_op = OMP_DEPEND_IN;
2371 else if (gfc_match ("out") == MATCH_YES)
2372 depend_op = OMP_DEPEND_OUT;
2373 else if (gfc_match ("mutexinoutset") == MATCH_YES)
2374 depend_op = OMP_DEPEND_MUTEXINOUTSET;
2375 else if (gfc_match ("depobj") == MATCH_YES)
2376 depend_op = OMP_DEPEND_DEPOBJ;
2377 else if (gfc_match ("source") == MATCH_YES)
2378 {
2379 if (m_it == MATCH_YES)
2380 {
2381 gfc_error ("ITERATOR may not be combined with SOURCE "
2382 "at %C");
2383 goto error;
2384 }
2385 if (!(mask & OMP_CLAUSE_DOACROSS))
2386 {
2387 gfc_error ("SOURCE at %C not permitted as dependence-type"
2388 " for this directive");
2389 goto error;
2390 }
2391 if (c->doacross_source)
2392 {
2393 gfc_error ("Duplicated clause with SOURCE dependence-type"
2394 " at %C");
2395 goto error;
2396 }
2397 gfc_gobble_whitespace ();
2398 m = gfc_match (": ");
2399 if (m != MATCH_YES && !is_depend)
2400 {
2401 gfc_error ("Expected %<:%> at %C");
2402 goto error;
2403 }
2404 if (gfc_match (")") != MATCH_YES
2405 && !(m == MATCH_YES
2406 && gfc_match ("omp_cur_iteration )") == MATCH_YES))
2407 {
2408 gfc_error ("Expected %<)%> or %<omp_cur_iteration)%> "
2409 "at %C");
2410 goto error;
2411 }
2412 c->doacross_source = true;
2413 c->depend_source = is_depend;
2414 continue;
2415 }
2416 else if (gfc_match ("sink ") == MATCH_YES)
2417 {
2418 if (!(mask & OMP_CLAUSE_DOACROSS))
2419 {
2420 gfc_error ("SINK at %C not permitted as dependence-type "
2421 "for this directive");
2422 goto error;
2423 }
2424 if (gfc_match (": ") != MATCH_YES)
2425 {
2426 gfc_error ("Expected %<:%> at %C");
2427 goto error;
2428 }
2429 if (m_it == MATCH_YES)
2430 {
2431 gfc_error ("ITERATOR may not be combined with SINK "
2432 "at %C");
2433 goto error;
2434 }
2435 m = gfc_match_omp_doacross_sink (list: &c->lists[OMP_LIST_DEPEND],
2436 depend: is_depend);
2437 if (m == MATCH_YES)
2438 continue;
2439 goto error;
2440 }
2441 else
2442 m = MATCH_NO;
2443 if (!(mask & OMP_CLAUSE_DEPEND))
2444 {
2445 gfc_error ("Expected dependence-type SINK or SOURCE at %C");
2446 goto error;
2447 }
2448 head = NULL;
2449 if (ns_iter)
2450 gfc_current_ns = ns_iter;
2451 if (m == MATCH_YES)
2452 m = gfc_match_omp_variable_list (str: " : ",
2453 list: &c->lists[OMP_LIST_DEPEND],
2454 allow_common: false, NULL, headp: &head, allow_sections: true,
2455 allow_derived: false, has_all_memory: &has_omp_all_memory);
2456 if (m != MATCH_YES)
2457 goto error;
2458 gfc_current_ns = ns_curr;
2459 if (has_omp_all_memory && depend_op != OMP_DEPEND_INOUT
2460 && depend_op != OMP_DEPEND_OUT)
2461 {
2462 gfc_error ("%<omp_all_memory%> used with DEPEND kind "
2463 "other than OUT or INOUT at %C");
2464 goto error;
2465 }
2466 gfc_omp_namelist *n;
2467 for (n = *head; n; n = n->next)
2468 {
2469 n->u.depend_doacross_op = depend_op;
2470 n->u2.ns = ns_iter;
2471 if (ns_iter)
2472 ns_iter->refs++;
2473 }
2474 continue;
2475 }
2476 if ((mask & OMP_CLAUSE_DETACH)
2477 && !openacc
2478 && !c->detach
2479 && gfc_match_omp_detach (expr: &c->detach) == MATCH_YES)
2480 continue;
2481 if ((mask & OMP_CLAUSE_DETACH)
2482 && openacc
2483 && gfc_match ("detach ( ") == MATCH_YES
2484 && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP],
2485 map_op: OMP_MAP_DETACH, allow_common: false,
2486 allow_derived))
2487 continue;
2488 if ((mask & OMP_CLAUSE_DEVICE)
2489 && !openacc
2490 && ((m = gfc_match_dupl_check (not_dupl: !c->device, name: "device", open_parens: true))
2491 != MATCH_NO))
2492 {
2493 if (m == MATCH_ERROR)
2494 goto error;
2495 c->ancestor = false;
2496 if (gfc_match ("device_num : ") == MATCH_YES)
2497 {
2498 if (gfc_match ("%e )", &c->device) != MATCH_YES)
2499 {
2500 gfc_error ("Expected integer expression at %C");
2501 break;
2502 }
2503 }
2504 else if (gfc_match ("ancestor : ") == MATCH_YES)
2505 {
2506 bool has_requires = false;
2507 c->ancestor = true;
2508 for (gfc_namespace *ns = gfc_current_ns; ns; ns = ns->parent)
2509 if (ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD)
2510 {
2511 has_requires = true;
2512 break;
2513 }
2514 if (!has_requires)
2515 {
2516 gfc_error ("%<ancestor%> device modifier not "
2517 "preceded by %<requires%> directive "
2518 "with %<reverse_offload%> clause at %C");
2519 break;
2520 }
2521 locus old_loc2 = gfc_current_locus;
2522 if (gfc_match ("%e )", &c->device) == MATCH_YES)
2523 {
2524 int device = 0;
2525 if (!gfc_extract_int (c->device, &device) && device != 1)
2526 {
2527 gfc_current_locus = old_loc2;
2528 gfc_error ("the %<device%> clause expression must "
2529 "evaluate to %<1%> at %C");
2530 break;
2531 }
2532 }
2533 else
2534 {
2535 gfc_error ("Expected integer expression at %C");
2536 break;
2537 }
2538 }
2539 else if (gfc_match ("%e )", &c->device) != MATCH_YES)
2540 {
2541 gfc_error ("Expected integer expression or a single device-"
2542 "modifier %<device_num%> or %<ancestor%> at %C");
2543 break;
2544 }
2545 continue;
2546 }
2547 if ((mask & OMP_CLAUSE_DEVICE)
2548 && openacc
2549 && gfc_match ("device ( ") == MATCH_YES
2550 && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP],
2551 map_op: OMP_MAP_FORCE_TO, allow_common: true,
2552 /* allow_derived = */ true))
2553 continue;
2554 if ((mask & OMP_CLAUSE_DEVICEPTR)
2555 && gfc_match ("deviceptr ( ") == MATCH_YES
2556 && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP],
2557 map_op: OMP_MAP_FORCE_DEVICEPTR, allow_common: false,
2558 allow_derived))
2559 continue;
2560 if ((mask & OMP_CLAUSE_DEVICE_TYPE)
2561 && gfc_match ("device_type ( ") == MATCH_YES)
2562 {
2563 if (gfc_match ("host") == MATCH_YES)
2564 c->device_type = OMP_DEVICE_TYPE_HOST;
2565 else if (gfc_match ("nohost") == MATCH_YES)
2566 c->device_type = OMP_DEVICE_TYPE_NOHOST;
2567 else if (gfc_match ("any") == MATCH_YES)
2568 c->device_type = OMP_DEVICE_TYPE_ANY;
2569 else
2570 {
2571 gfc_error ("Expected HOST, NOHOST or ANY at %C");
2572 break;
2573 }
2574 if (gfc_match (" )") != MATCH_YES)
2575 break;
2576 continue;
2577 }
2578 if ((mask & OMP_CLAUSE_DEVICE_RESIDENT)
2579 && gfc_match_omp_variable_list
2580 (str: "device_resident (",
2581 list: &c->lists[OMP_LIST_DEVICE_RESIDENT], allow_common: true) == MATCH_YES)
2582 continue;
2583 if ((mask & OMP_CLAUSE_DIST_SCHEDULE)
2584 && c->dist_sched_kind == OMP_SCHED_NONE
2585 && gfc_match ("dist_schedule ( static") == MATCH_YES)
2586 {
2587 m = MATCH_NO;
2588 c->dist_sched_kind = OMP_SCHED_STATIC;
2589 m = gfc_match (" , %e )", &c->dist_chunk_size);
2590 if (m != MATCH_YES)
2591 m = gfc_match_char (')');
2592 if (m != MATCH_YES)
2593 {
2594 c->dist_sched_kind = OMP_SCHED_NONE;
2595 gfc_current_locus = old_loc;
2596 }
2597 else
2598 continue;
2599 }
2600 break;
2601 case 'e':
2602 if ((mask & OMP_CLAUSE_ENTER))
2603 {
2604 m = gfc_match_omp_to_link (str: "enter (", list: &c->lists[OMP_LIST_ENTER]);
2605 if (m == MATCH_ERROR)
2606 goto error;
2607 if (m == MATCH_YES)
2608 continue;
2609 }
2610 break;
2611 case 'f':
2612 if ((mask & OMP_CLAUSE_FAIL)
2613 && (m = gfc_match_dupl_check (not_dupl: c->fail == OMP_MEMORDER_UNSET,
2614 name: "fail", open_parens: true)) != MATCH_NO)
2615 {
2616 if (m == MATCH_ERROR)
2617 goto error;
2618 if (gfc_match ("seq_cst") == MATCH_YES)
2619 c->fail = OMP_MEMORDER_SEQ_CST;
2620 else if (gfc_match ("acquire") == MATCH_YES)
2621 c->fail = OMP_MEMORDER_ACQUIRE;
2622 else if (gfc_match ("relaxed") == MATCH_YES)
2623 c->fail = OMP_MEMORDER_RELAXED;
2624 else
2625 {
2626 gfc_error ("Expected SEQ_CST, ACQUIRE or RELAXED at %C");
2627 break;
2628 }
2629 if (gfc_match (" )") != MATCH_YES)
2630 goto error;
2631 continue;
2632 }
2633 if ((mask & OMP_CLAUSE_FILTER)
2634 && (m = gfc_match_dupl_check (not_dupl: !c->filter, name: "filter", open_parens: true,
2635 expr: &c->filter)) != MATCH_NO)
2636 {
2637 if (m == MATCH_ERROR)
2638 goto error;
2639 continue;
2640 }
2641 if ((mask & OMP_CLAUSE_FINAL)
2642 && (m = gfc_match_dupl_check (not_dupl: !c->final_expr, name: "final", open_parens: true,
2643 expr: &c->final_expr)) != MATCH_NO)
2644 {
2645 if (m == MATCH_ERROR)
2646 goto error;
2647 continue;
2648 }
2649 if ((mask & OMP_CLAUSE_FINALIZE)
2650 && (m = gfc_match_dupl_check (not_dupl: !c->finalize, name: "finalize"))
2651 != MATCH_NO)
2652 {
2653 if (m == MATCH_ERROR)
2654 goto error;
2655 c->finalize = true;
2656 needs_space = true;
2657 continue;
2658 }
2659 if ((mask & OMP_CLAUSE_FIRSTPRIVATE)
2660 && gfc_match_omp_variable_list (str: "firstprivate (",
2661 list: &c->lists[OMP_LIST_FIRSTPRIVATE],
2662 allow_common: true) == MATCH_YES)
2663 continue;
2664 if ((mask & OMP_CLAUSE_FROM)
2665 && gfc_match_motion_var_list (str: "from (", list: &c->lists[OMP_LIST_FROM],
2666 headp: &head) == MATCH_YES)
2667 continue;
2668 break;
2669 case 'g':
2670 if ((mask & OMP_CLAUSE_GANG)
2671 && (m = gfc_match_dupl_check (not_dupl: !c->gang, name: "gang")) != MATCH_NO)
2672 {
2673 if (m == MATCH_ERROR)
2674 goto error;
2675 c->gang = true;
2676 m = match_oacc_clause_gwv (cp: c, GOMP_DIM_GANG);
2677 if (m == MATCH_ERROR)
2678 {
2679 gfc_current_locus = old_loc;
2680 break;
2681 }
2682 else if (m == MATCH_NO)
2683 needs_space = true;
2684 continue;
2685 }
2686 if ((mask & OMP_CLAUSE_GRAINSIZE)
2687 && (m = gfc_match_dupl_check (not_dupl: !c->grainsize, name: "grainsize", open_parens: true))
2688 != MATCH_NO)
2689 {
2690 if (m == MATCH_ERROR)
2691 goto error;
2692 if (gfc_match ("strict : ") == MATCH_YES)
2693 c->grainsize_strict = true;
2694 if (gfc_match (" %e )", &c->grainsize) != MATCH_YES)
2695 goto error;
2696 continue;
2697 }
2698 break;
2699 case 'h':
2700 if ((mask & OMP_CLAUSE_HAS_DEVICE_ADDR)
2701 && gfc_match_omp_variable_list
2702 (str: "has_device_addr (", list: &c->lists[OMP_LIST_HAS_DEVICE_ADDR],
2703 allow_common: false, NULL, NULL, allow_sections: true) == MATCH_YES)
2704 continue;
2705 if ((mask & OMP_CLAUSE_HINT)
2706 && (m = gfc_match_dupl_check (not_dupl: !c->hint, name: "hint", open_parens: true, expr: &c->hint))
2707 != MATCH_NO)
2708 {
2709 if (m == MATCH_ERROR)
2710 goto error;
2711 continue;
2712 }
2713 if ((mask & OMP_CLAUSE_ASSUMPTIONS)
2714 && gfc_match ("holds ( ") == MATCH_YES)
2715 {
2716 gfc_expr *e;
2717 if (gfc_match ("%e )", &e) != MATCH_YES)
2718 goto error;
2719 if (c->assume == NULL)
2720 c->assume = gfc_get_omp_assumptions ();
2721 gfc_expr_list *el = XCNEW (gfc_expr_list);
2722 el->expr = e;
2723 el->next = c->assume->holds;
2724 c->assume->holds = el;
2725 continue;
2726 }
2727 if ((mask & OMP_CLAUSE_HOST)
2728 && gfc_match ("host ( ") == MATCH_YES
2729 && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP],
2730 map_op: OMP_MAP_FORCE_FROM, allow_common: true,
2731 /* allow_derived = */ true))
2732 continue;
2733 break;
2734 case 'i':
2735 if ((mask & OMP_CLAUSE_IF_PRESENT)
2736 && (m = gfc_match_dupl_check (not_dupl: !c->if_present, name: "if_present"))
2737 != MATCH_NO)
2738 {
2739 if (m == MATCH_ERROR)
2740 goto error;
2741 c->if_present = true;
2742 needs_space = true;
2743 continue;
2744 }
2745 if ((mask & OMP_CLAUSE_IF)
2746 && (m = gfc_match_dupl_check (not_dupl: !c->if_expr, name: "if", open_parens: true))
2747 != MATCH_NO)
2748 {
2749 if (m == MATCH_ERROR)
2750 goto error;
2751 if (!openacc)
2752 {
2753 /* This should match the enum gfc_omp_if_kind order. */
2754 static const char *ifs[OMP_IF_LAST] = {
2755 "cancel : %e )",
2756 "parallel : %e )",
2757 "simd : %e )",
2758 "task : %e )",
2759 "taskloop : %e )",
2760 "target : %e )",
2761 "target data : %e )",
2762 "target update : %e )",
2763 "target enter data : %e )",
2764 "target exit data : %e )" };
2765 int i;
2766 for (i = 0; i < OMP_IF_LAST; i++)
2767 if (c->if_exprs[i] == NULL
2768 && gfc_match (ifs[i], &c->if_exprs[i]) == MATCH_YES)
2769 break;
2770 if (i < OMP_IF_LAST)
2771 continue;
2772 }
2773 if (gfc_match (" %e )", &c->if_expr) == MATCH_YES)
2774 continue;
2775 goto error;
2776 }
2777 if ((mask & OMP_CLAUSE_IN_REDUCTION)
2778 && gfc_match_omp_clause_reduction (pc, c, openacc, allow_derived,
2779 openmp_target) == MATCH_YES)
2780 continue;
2781 if ((mask & OMP_CLAUSE_INBRANCH)
2782 && (m = gfc_match_dupl_check (not_dupl: !c->inbranch && !c->notinbranch,
2783 name: "inbranch")) != MATCH_NO)
2784 {
2785 if (m == MATCH_ERROR)
2786 goto error;
2787 c->inbranch = needs_space = true;
2788 continue;
2789 }
2790 if ((mask & OMP_CLAUSE_INDEPENDENT)
2791 && (m = gfc_match_dupl_check (not_dupl: !c->independent, name: "independent"))
2792 != MATCH_NO)
2793 {
2794 if (m == MATCH_ERROR)
2795 goto error;
2796 c->independent = true;
2797 needs_space = true;
2798 continue;
2799 }
2800 if ((mask & OMP_CLAUSE_IS_DEVICE_PTR)
2801 && gfc_match_omp_variable_list
2802 (str: "is_device_ptr (",
2803 list: &c->lists[OMP_LIST_IS_DEVICE_PTR], allow_common: false) == MATCH_YES)
2804 continue;
2805 break;
2806 case 'l':
2807 if ((mask & OMP_CLAUSE_LASTPRIVATE)
2808 && gfc_match ("lastprivate ( ") == MATCH_YES)
2809 {
2810 bool conditional = gfc_match ("conditional : ") == MATCH_YES;
2811 head = NULL;
2812 if (gfc_match_omp_variable_list (str: "",
2813 list: &c->lists[OMP_LIST_LASTPRIVATE],
2814 allow_common: false, NULL, headp: &head) == MATCH_YES)
2815 {
2816 gfc_omp_namelist *n;
2817 for (n = *head; n; n = n->next)
2818 n->u.lastprivate_conditional = conditional;
2819 continue;
2820 }
2821 gfc_current_locus = old_loc;
2822 break;
2823 }
2824 end_colon = false;
2825 head = NULL;
2826 if ((mask & OMP_CLAUSE_LINEAR)
2827 && gfc_match ("linear (") == MATCH_YES)
2828 {
2829 bool old_linear_modifier = false;
2830 gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
2831 gfc_expr *step = NULL;
2832
2833 if (gfc_match_omp_variable_list (str: " ref (",
2834 list: &c->lists[OMP_LIST_LINEAR],
2835 allow_common: false, NULL, headp: &head)
2836 == MATCH_YES)
2837 {
2838 linear_op = OMP_LINEAR_REF;
2839 old_linear_modifier = true;
2840 }
2841 else if (gfc_match_omp_variable_list (str: " val (",
2842 list: &c->lists[OMP_LIST_LINEAR],
2843 allow_common: false, NULL, headp: &head)
2844 == MATCH_YES)
2845 {
2846 linear_op = OMP_LINEAR_VAL;
2847 old_linear_modifier = true;
2848 }
2849 else if (gfc_match_omp_variable_list (str: " uval (",
2850 list: &c->lists[OMP_LIST_LINEAR],
2851 allow_common: false, NULL, headp: &head)
2852 == MATCH_YES)
2853 {
2854 linear_op = OMP_LINEAR_UVAL;
2855 old_linear_modifier = true;
2856 }
2857 else if (gfc_match_omp_variable_list (str: "",
2858 list: &c->lists[OMP_LIST_LINEAR],
2859 allow_common: false, end_colon: &end_colon, headp: &head)
2860 == MATCH_YES)
2861 linear_op = OMP_LINEAR_DEFAULT;
2862 else
2863 {
2864 gfc_current_locus = old_loc;
2865 break;
2866 }
2867 if (linear_op != OMP_LINEAR_DEFAULT)
2868 {
2869 if (gfc_match (" :") == MATCH_YES)
2870 end_colon = true;
2871 else if (gfc_match (" )") != MATCH_YES)
2872 {
2873 gfc_free_omp_namelist (*head, false, false, false);
2874 gfc_current_locus = old_loc;
2875 *head = NULL;
2876 break;
2877 }
2878 }
2879 gfc_gobble_whitespace ();
2880 if (old_linear_modifier && end_colon)
2881 {
2882 if (gfc_match (" %e )", &step) != MATCH_YES)
2883 {
2884 gfc_free_omp_namelist (*head, false, false, false);
2885 gfc_current_locus = old_loc;
2886 *head = NULL;
2887 goto error;
2888 }
2889 }
2890 else if (end_colon)
2891 {
2892 bool has_error = false;
2893 bool has_modifiers = false;
2894 bool has_step = false;
2895 bool duplicate_step = false;
2896 bool duplicate_mod = false;
2897 while (true)
2898 {
2899 old_loc = gfc_current_locus;
2900 bool close_paren = gfc_match ("val )") == MATCH_YES;
2901 if (close_paren || gfc_match ("val , ") == MATCH_YES)
2902 {
2903 if (linear_op != OMP_LINEAR_DEFAULT)
2904 {
2905 duplicate_mod = true;
2906 break;
2907 }
2908 linear_op = OMP_LINEAR_VAL;
2909 has_modifiers = true;
2910 if (close_paren)
2911 break;
2912 continue;
2913 }
2914 close_paren = gfc_match ("uval )") == MATCH_YES;
2915 if (close_paren || gfc_match ("uval , ") == MATCH_YES)
2916 {
2917 if (linear_op != OMP_LINEAR_DEFAULT)
2918 {
2919 duplicate_mod = true;
2920 break;
2921 }
2922 linear_op = OMP_LINEAR_UVAL;
2923 has_modifiers = true;
2924 if (close_paren)
2925 break;
2926 continue;
2927 }
2928 close_paren = gfc_match ("ref )") == MATCH_YES;
2929 if (close_paren || gfc_match ("ref , ") == MATCH_YES)
2930 {
2931 if (linear_op != OMP_LINEAR_DEFAULT)
2932 {
2933 duplicate_mod = true;
2934 break;
2935 }
2936 linear_op = OMP_LINEAR_REF;
2937 has_modifiers = true;
2938 if (close_paren)
2939 break;
2940 continue;
2941 }
2942 close_paren = (gfc_match ("step ( %e ) )", &step)
2943 == MATCH_YES);
2944 if (close_paren
2945 || gfc_match ("step ( %e ) , ", &step) == MATCH_YES)
2946 {
2947 if (has_step)
2948 {
2949 duplicate_step = true;
2950 break;
2951 }
2952 has_modifiers = has_step = true;
2953 if (close_paren)
2954 break;
2955 continue;
2956 }
2957 if (!has_modifiers
2958 && gfc_match ("%e )", &step) == MATCH_YES)
2959 {
2960 if ((step->expr_type == EXPR_FUNCTION
2961 || step->expr_type == EXPR_VARIABLE)
2962 && strcmp (s1: step->symtree->name, s2: "step") == 0)
2963 {
2964 gfc_current_locus = old_loc;
2965 gfc_match ("step (");
2966 has_error = true;
2967 }
2968 break;
2969 }
2970 has_error = true;
2971 break;
2972 }
2973 if (duplicate_mod || duplicate_step)
2974 {
2975 gfc_error ("Multiple %qs modifiers specified at %C",
2976 duplicate_mod ? "linear" : "step");
2977 has_error = true;
2978 }
2979 if (has_error)
2980 {
2981 gfc_free_omp_namelist (*head, false, false, false);
2982 *head = NULL;
2983 goto error;
2984 }
2985 }
2986 if (step == NULL)
2987 {
2988 step = gfc_get_constant_expr (BT_INTEGER,
2989 gfc_default_integer_kind,
2990 &old_loc);
2991 mpz_set_si (step->value.integer, 1);
2992 }
2993 (*head)->expr = step;
2994 if (linear_op != OMP_LINEAR_DEFAULT || old_linear_modifier)
2995 for (gfc_omp_namelist *n = *head; n; n = n->next)
2996 {
2997 n->u.linear.op = linear_op;
2998 n->u.linear.old_modifier = old_linear_modifier;
2999 }
3000 continue;
3001 }
3002 if ((mask & OMP_CLAUSE_LINK)
3003 && openacc
3004 && (gfc_match_oacc_clause_link (str: "link (",
3005 list: &c->lists[OMP_LIST_LINK])
3006 == MATCH_YES))
3007 continue;
3008 else if ((mask & OMP_CLAUSE_LINK)
3009 && !openacc
3010 && (gfc_match_omp_to_link (str: "link (",
3011 list: &c->lists[OMP_LIST_LINK])
3012 == MATCH_YES))
3013 continue;
3014 break;
3015 case 'm':
3016 if ((mask & OMP_CLAUSE_MAP)
3017 && gfc_match ("map ( ") == MATCH_YES)
3018 {
3019 locus old_loc2 = gfc_current_locus;
3020 int always_modifier = 0;
3021 int close_modifier = 0;
3022 int present_modifier = 0;
3023 locus second_always_locus = old_loc2;
3024 locus second_close_locus = old_loc2;
3025 locus second_present_locus = old_loc2;
3026
3027 for (;;)
3028 {
3029 locus current_locus = gfc_current_locus;
3030 if (gfc_match ("always ") == MATCH_YES)
3031 {
3032 if (always_modifier++ == 1)
3033 second_always_locus = current_locus;
3034 }
3035 else if (gfc_match ("close ") == MATCH_YES)
3036 {
3037 if (close_modifier++ == 1)
3038 second_close_locus = current_locus;
3039 }
3040 else if (gfc_match ("present ") == MATCH_YES)
3041 {
3042 if (present_modifier++ == 1)
3043 second_present_locus = current_locus;
3044 }
3045 else
3046 break;
3047 gfc_match (", ");
3048 }
3049
3050 gfc_omp_map_op map_op = OMP_MAP_TOFROM;
3051 int always_present_modifier
3052 = always_modifier && present_modifier;
3053
3054 if (gfc_match ("alloc : ") == MATCH_YES)
3055 map_op = (present_modifier ? OMP_MAP_PRESENT_ALLOC
3056 : OMP_MAP_ALLOC);
3057 else if (gfc_match ("tofrom : ") == MATCH_YES)
3058 map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_TOFROM
3059 : present_modifier ? OMP_MAP_PRESENT_TOFROM
3060 : always_modifier ? OMP_MAP_ALWAYS_TOFROM
3061 : OMP_MAP_TOFROM);
3062 else if (gfc_match ("to : ") == MATCH_YES)
3063 map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_TO
3064 : present_modifier ? OMP_MAP_PRESENT_TO
3065 : always_modifier ? OMP_MAP_ALWAYS_TO
3066 : OMP_MAP_TO);
3067 else if (gfc_match ("from : ") == MATCH_YES)
3068 map_op = (always_present_modifier ? OMP_MAP_ALWAYS_PRESENT_FROM
3069 : present_modifier ? OMP_MAP_PRESENT_FROM
3070 : always_modifier ? OMP_MAP_ALWAYS_FROM
3071 : OMP_MAP_FROM);
3072 else if (gfc_match ("release : ") == MATCH_YES)
3073 map_op = OMP_MAP_RELEASE;
3074 else if (gfc_match ("delete : ") == MATCH_YES)
3075 map_op = OMP_MAP_DELETE;
3076 else
3077 {
3078 gfc_current_locus = old_loc2;
3079 always_modifier = 0;
3080 close_modifier = 0;
3081 }
3082
3083 if (always_modifier > 1)
3084 {
3085 gfc_error ("too many %<always%> modifiers at %L",
3086 &second_always_locus);
3087 break;
3088 }
3089 if (close_modifier > 1)
3090 {
3091 gfc_error ("too many %<close%> modifiers at %L",
3092 &second_close_locus);
3093 break;
3094 }
3095 if (present_modifier > 1)
3096 {
3097 gfc_error ("too many %<present%> modifiers at %L",
3098 &second_present_locus);
3099 break;
3100 }
3101
3102 head = NULL;
3103 if (gfc_match_omp_variable_list (str: "", list: &c->lists[OMP_LIST_MAP],
3104 allow_common: false, NULL, headp: &head,
3105 allow_sections: true, allow_derived: true) == MATCH_YES)
3106 {
3107 gfc_omp_namelist *n;
3108 for (n = *head; n; n = n->next)
3109 n->u.map_op = map_op;
3110 continue;
3111 }
3112 gfc_current_locus = old_loc;
3113 break;
3114 }
3115 if ((mask & OMP_CLAUSE_MERGEABLE)
3116 && (m = gfc_match_dupl_check (not_dupl: !c->mergeable, name: "mergeable"))
3117 != MATCH_NO)
3118 {
3119 if (m == MATCH_ERROR)
3120 goto error;
3121 c->mergeable = needs_space = true;
3122 continue;
3123 }
3124 if ((mask & OMP_CLAUSE_MESSAGE)
3125 && (m = gfc_match_dupl_check (not_dupl: !c->message, name: "message", open_parens: true,
3126 expr: &c->message)) != MATCH_NO)
3127 {
3128 if (m == MATCH_ERROR)
3129 goto error;
3130 continue;
3131 }
3132 break;
3133 case 'n':
3134 if ((mask & OMP_CLAUSE_NO_CREATE)
3135 && gfc_match ("no_create ( ") == MATCH_YES
3136 && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP],
3137 map_op: OMP_MAP_IF_PRESENT, allow_common: true,
3138 allow_derived))
3139 continue;
3140 if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3141 && (m = gfc_match_dupl_check (not_dupl: !c->assume
3142 || !c->assume->no_openmp_routines,
3143 name: "no_openmp_routines")) == MATCH_YES)
3144 {
3145 if (m == MATCH_ERROR)
3146 goto error;
3147 if (c->assume == NULL)
3148 c->assume = gfc_get_omp_assumptions ();
3149 c->assume->no_openmp_routines = needs_space = true;
3150 continue;
3151 }
3152 if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3153 && (m = gfc_match_dupl_check (not_dupl: !c->assume || !c->assume->no_openmp,
3154 name: "no_openmp")) == MATCH_YES)
3155 {
3156 if (m == MATCH_ERROR)
3157 goto error;
3158 if (c->assume == NULL)
3159 c->assume = gfc_get_omp_assumptions ();
3160 c->assume->no_openmp = needs_space = true;
3161 continue;
3162 }
3163 if ((mask & OMP_CLAUSE_ASSUMPTIONS)
3164 && (m = gfc_match_dupl_check (not_dupl: !c->assume
3165 || !c->assume->no_parallelism,
3166 name: "no_parallelism")) == MATCH_YES)
3167 {
3168 if (m == MATCH_ERROR)
3169 goto error;
3170 if (c->assume == NULL)
3171 c->assume = gfc_get_omp_assumptions ();
3172 c->assume->no_parallelism = needs_space = true;
3173 continue;
3174 }
3175 if ((mask & OMP_CLAUSE_NOGROUP)
3176 && (m = gfc_match_dupl_check (not_dupl: !c->nogroup, name: "nogroup"))
3177 != MATCH_NO)
3178 {
3179 if (m == MATCH_ERROR)
3180 goto error;
3181 c->nogroup = needs_space = true;
3182 continue;
3183 }
3184 if ((mask & OMP_CLAUSE_NOHOST)
3185 && (m = gfc_match_dupl_check (not_dupl: !c->nohost, name: "nohost")) != MATCH_NO)
3186 {
3187 if (m == MATCH_ERROR)
3188 goto error;
3189 c->nohost = needs_space = true;
3190 continue;
3191 }
3192 if ((mask & OMP_CLAUSE_NOTEMPORAL)
3193 && gfc_match_omp_variable_list (str: "nontemporal (",
3194 list: &c->lists[OMP_LIST_NONTEMPORAL],
3195 allow_common: true) == MATCH_YES)
3196 continue;
3197 if ((mask & OMP_CLAUSE_NOTINBRANCH)
3198 && (m = gfc_match_dupl_check (not_dupl: !c->notinbranch && !c->inbranch,
3199 name: "notinbranch")) != MATCH_NO)
3200 {
3201 if (m == MATCH_ERROR)
3202 goto error;
3203 c->notinbranch = needs_space = true;
3204 continue;
3205 }
3206 if ((mask & OMP_CLAUSE_NOWAIT)
3207 && (m = gfc_match_dupl_check (not_dupl: !c->nowait, name: "nowait")) != MATCH_NO)
3208 {
3209 if (m == MATCH_ERROR)
3210 goto error;
3211 c->nowait = needs_space = true;
3212 continue;
3213 }
3214 if ((mask & OMP_CLAUSE_NUM_GANGS)
3215 && (m = gfc_match_dupl_check (not_dupl: !c->num_gangs_expr, name: "num_gangs",
3216 open_parens: true)) != MATCH_NO)
3217 {
3218 if (m == MATCH_ERROR)
3219 goto error;
3220 if (gfc_match (" %e )", &c->num_gangs_expr) != MATCH_YES)
3221 goto error;
3222 continue;
3223 }
3224 if ((mask & OMP_CLAUSE_NUM_TASKS)
3225 && (m = gfc_match_dupl_check (not_dupl: !c->num_tasks, name: "num_tasks", open_parens: true))
3226 != MATCH_NO)
3227 {
3228 if (m == MATCH_ERROR)
3229 goto error;
3230 if (gfc_match ("strict : ") == MATCH_YES)
3231 c->num_tasks_strict = true;
3232 if (gfc_match (" %e )", &c->num_tasks) != MATCH_YES)
3233 goto error;
3234 continue;
3235 }
3236 if ((mask & OMP_CLAUSE_NUM_TEAMS)
3237 && (m = gfc_match_dupl_check (not_dupl: !c->num_teams_upper, name: "num_teams",
3238 open_parens: true)) != MATCH_NO)
3239 {
3240 if (m == MATCH_ERROR)
3241 goto error;
3242 if (gfc_match ("%e ", &c->num_teams_upper) != MATCH_YES)
3243 goto error;
3244 if (gfc_peek_ascii_char () == ':')
3245 {
3246 c->num_teams_lower = c->num_teams_upper;
3247 c->num_teams_upper = NULL;
3248 if (gfc_match (": %e ", &c->num_teams_upper) != MATCH_YES)
3249 goto error;
3250 }
3251 if (gfc_match (") ") != MATCH_YES)
3252 goto error;
3253 continue;
3254 }
3255 if ((mask & OMP_CLAUSE_NUM_THREADS)
3256 && (m = gfc_match_dupl_check (not_dupl: !c->num_threads, name: "num_threads", open_parens: true,
3257 expr: &c->num_threads)) != MATCH_NO)
3258 {
3259 if (m == MATCH_ERROR)
3260 goto error;
3261 continue;
3262 }
3263 if ((mask & OMP_CLAUSE_NUM_WORKERS)
3264 && (m = gfc_match_dupl_check (not_dupl: !c->num_workers_expr, name: "num_workers",
3265 open_parens: true, expr: &c->num_workers_expr))
3266 != MATCH_NO)
3267 {
3268 if (m == MATCH_ERROR)
3269 goto error;
3270 continue;
3271 }
3272 break;
3273 case 'o':
3274 if ((mask & OMP_CLAUSE_ORDER)
3275 && (m = gfc_match_dupl_check (not_dupl: !c->order_concurrent, name: "order ("))
3276 != MATCH_NO)
3277 {
3278 if (m == MATCH_ERROR)
3279 goto error;
3280 if (gfc_match (" reproducible : concurrent )") == MATCH_YES)
3281 c->order_reproducible = true;
3282 else if (gfc_match (" concurrent )") == MATCH_YES)
3283 ;
3284 else if (gfc_match (" unconstrained : concurrent )") == MATCH_YES)
3285 c->order_unconstrained = true;
3286 else
3287 {
3288 gfc_error ("Expected ORDER(CONCURRENT) at %C "
3289 "with optional %<reproducible%> or "
3290 "%<unconstrained%> modifier");
3291 goto error;
3292 }
3293 c->order_concurrent = true;
3294 continue;
3295 }
3296 if ((mask & OMP_CLAUSE_ORDERED)
3297 && (m = gfc_match_dupl_check (not_dupl: !c->ordered, name: "ordered"))
3298 != MATCH_NO)
3299 {
3300 if (m == MATCH_ERROR)
3301 goto error;
3302 gfc_expr *cexpr = NULL;
3303 m = gfc_match (" ( %e )", &cexpr);
3304
3305 c->ordered = true;
3306 if (m == MATCH_YES)
3307 {
3308 int ordered = 0;
3309 if (gfc_extract_int (cexpr, &ordered, -1))
3310 ordered = 0;
3311 else if (ordered <= 0)
3312 {
3313 gfc_error_now ("ORDERED clause argument not"
3314 " constant positive integer at %C");
3315 ordered = 0;
3316 }
3317 c->orderedc = ordered;
3318 gfc_free_expr (cexpr);
3319 continue;
3320 }
3321
3322 needs_space = true;
3323 continue;
3324 }
3325 break;
3326 case 'p':
3327 if ((mask & OMP_CLAUSE_COPY)
3328 && gfc_match ("pcopy ( ") == MATCH_YES
3329 && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP],
3330 map_op: OMP_MAP_TOFROM, allow_common: true, allow_derived))
3331 continue;
3332 if ((mask & OMP_CLAUSE_COPYIN)
3333 && gfc_match ("pcopyin ( ") == MATCH_YES
3334 && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP],
3335 map_op: OMP_MAP_TO, allow_common: true, allow_derived))
3336 continue;
3337 if ((mask & OMP_CLAUSE_COPYOUT)
3338 && gfc_match ("pcopyout ( ") == MATCH_YES
3339 && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP],
3340 map_op: OMP_MAP_FROM, allow_common: true, allow_derived))
3341 continue;
3342 if ((mask & OMP_CLAUSE_CREATE)
3343 && gfc_match ("pcreate ( ") == MATCH_YES
3344 && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP],
3345 map_op: OMP_MAP_ALLOC, allow_common: true, allow_derived))
3346 continue;
3347 if ((mask & OMP_CLAUSE_PRESENT)
3348 && gfc_match ("present ( ") == MATCH_YES
3349 && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP],
3350 map_op: OMP_MAP_FORCE_PRESENT, allow_common: false,
3351 allow_derived))
3352 continue;
3353 if ((mask & OMP_CLAUSE_COPY)
3354 && gfc_match ("present_or_copy ( ") == MATCH_YES
3355 && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP],
3356 map_op: OMP_MAP_TOFROM, allow_common: true,
3357 allow_derived))
3358 continue;
3359 if ((mask & OMP_CLAUSE_COPYIN)
3360 && gfc_match ("present_or_copyin ( ") == MATCH_YES
3361 && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP],
3362 map_op: OMP_MAP_TO, allow_common: true, allow_derived))
3363 continue;
3364 if ((mask & OMP_CLAUSE_COPYOUT)
3365 && gfc_match ("present_or_copyout ( ") == MATCH_YES
3366 && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP],
3367 map_op: OMP_MAP_FROM, allow_common: true, allow_derived))
3368 continue;
3369 if ((mask & OMP_CLAUSE_CREATE)
3370 && gfc_match ("present_or_create ( ") == MATCH_YES
3371 && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP],
3372 map_op: OMP_MAP_ALLOC, allow_common: true, allow_derived))
3373 continue;
3374 if ((mask & OMP_CLAUSE_PRIORITY)
3375 && (m = gfc_match_dupl_check (not_dupl: !c->priority, name: "priority", open_parens: true,
3376 expr: &c->priority)) != MATCH_NO)
3377 {
3378 if (m == MATCH_ERROR)
3379 goto error;
3380 continue;
3381 }
3382 if ((mask & OMP_CLAUSE_PRIVATE)
3383 && gfc_match_omp_variable_list (str: "private (",
3384 list: &c->lists[OMP_LIST_PRIVATE],
3385 allow_common: true) == MATCH_YES)
3386 continue;
3387 if ((mask & OMP_CLAUSE_PROC_BIND)
3388 && (m = gfc_match_dupl_check (not_dupl: (c->proc_bind
3389 == OMP_PROC_BIND_UNKNOWN),
3390 name: "proc_bind", open_parens: true)) != MATCH_NO)
3391 {
3392 if (m == MATCH_ERROR)
3393 goto error;
3394 if (gfc_match ("primary )") == MATCH_YES)
3395 c->proc_bind = OMP_PROC_BIND_PRIMARY;
3396 else if (gfc_match ("master )") == MATCH_YES)
3397 c->proc_bind = OMP_PROC_BIND_MASTER;
3398 else if (gfc_match ("spread )") == MATCH_YES)
3399 c->proc_bind = OMP_PROC_BIND_SPREAD;
3400 else if (gfc_match ("close )") == MATCH_YES)
3401 c->proc_bind = OMP_PROC_BIND_CLOSE;
3402 else
3403 goto error;
3404 continue;
3405 }
3406 break;
3407 case 'r':
3408 if ((mask & OMP_CLAUSE_ATOMIC)
3409 && (m = gfc_match_dupl_atomic (not_dupl: (c->atomic_op
3410 == GFC_OMP_ATOMIC_UNSET),
3411 name: "read")) != MATCH_NO)
3412 {
3413 if (m == MATCH_ERROR)
3414 goto error;
3415 c->atomic_op = GFC_OMP_ATOMIC_READ;
3416 needs_space = true;
3417 continue;
3418 }
3419 if ((mask & OMP_CLAUSE_REDUCTION)
3420 && gfc_match_omp_clause_reduction (pc, c, openacc,
3421 allow_derived) == MATCH_YES)
3422 continue;
3423 if ((mask & OMP_CLAUSE_MEMORDER)
3424 && (m = gfc_match_dupl_memorder (not_dupl: (c->memorder
3425 == OMP_MEMORDER_UNSET),
3426 name: "relaxed")) != MATCH_NO)
3427 {
3428 if (m == MATCH_ERROR)
3429 goto error;
3430 c->memorder = OMP_MEMORDER_RELAXED;
3431 needs_space = true;
3432 continue;
3433 }
3434 if ((mask & OMP_CLAUSE_MEMORDER)
3435 && (m = gfc_match_dupl_memorder (not_dupl: (c->memorder
3436 == OMP_MEMORDER_UNSET),
3437 name: "release")) != MATCH_NO)
3438 {
3439 if (m == MATCH_ERROR)
3440 goto error;
3441 c->memorder = OMP_MEMORDER_RELEASE;
3442 needs_space = true;
3443 continue;
3444 }
3445 break;
3446 case 's':
3447 if ((mask & OMP_CLAUSE_SAFELEN)
3448 && (m = gfc_match_dupl_check (not_dupl: !c->safelen_expr, name: "safelen",
3449 open_parens: true, expr: &c->safelen_expr))
3450 != MATCH_NO)
3451 {
3452 if (m == MATCH_ERROR)
3453 goto error;
3454 continue;
3455 }
3456 if ((mask & OMP_CLAUSE_SCHEDULE)
3457 && (m = gfc_match_dupl_check (not_dupl: c->sched_kind == OMP_SCHED_NONE,
3458 name: "schedule", open_parens: true)) != MATCH_NO)
3459 {
3460 if (m == MATCH_ERROR)
3461 goto error;
3462 int nmodifiers = 0;
3463 locus old_loc2 = gfc_current_locus;
3464 do
3465 {
3466 if (gfc_match ("simd") == MATCH_YES)
3467 {
3468 c->sched_simd = true;
3469 nmodifiers++;
3470 }
3471 else if (gfc_match ("monotonic") == MATCH_YES)
3472 {
3473 c->sched_monotonic = true;
3474 nmodifiers++;
3475 }
3476 else if (gfc_match ("nonmonotonic") == MATCH_YES)
3477 {
3478 c->sched_nonmonotonic = true;
3479 nmodifiers++;
3480 }
3481 else
3482 {
3483 if (nmodifiers)
3484 gfc_current_locus = old_loc2;
3485 break;
3486 }
3487 if (nmodifiers == 1
3488 && gfc_match (" , ") == MATCH_YES)
3489 continue;
3490 else if (gfc_match (" : ") == MATCH_YES)
3491 break;
3492 gfc_current_locus = old_loc2;
3493 break;
3494 }
3495 while (1);
3496 if (gfc_match ("static") == MATCH_YES)
3497 c->sched_kind = OMP_SCHED_STATIC;
3498 else if (gfc_match ("dynamic") == MATCH_YES)
3499 c->sched_kind = OMP_SCHED_DYNAMIC;
3500 else if (gfc_match ("guided") == MATCH_YES)
3501 c->sched_kind = OMP_SCHED_GUIDED;
3502 else if (gfc_match ("runtime") == MATCH_YES)
3503 c->sched_kind = OMP_SCHED_RUNTIME;
3504 else if (gfc_match ("auto") == MATCH_YES)
3505 c->sched_kind = OMP_SCHED_AUTO;
3506 if (c->sched_kind != OMP_SCHED_NONE)
3507 {
3508 m = MATCH_NO;
3509 if (c->sched_kind != OMP_SCHED_RUNTIME
3510 && c->sched_kind != OMP_SCHED_AUTO)
3511 m = gfc_match (" , %e )", &c->chunk_size);
3512 if (m != MATCH_YES)
3513 m = gfc_match_char (')');
3514 if (m != MATCH_YES)
3515 c->sched_kind = OMP_SCHED_NONE;
3516 }
3517 if (c->sched_kind != OMP_SCHED_NONE)
3518 continue;
3519 else
3520 gfc_current_locus = old_loc;
3521 }
3522 if ((mask & OMP_CLAUSE_SELF)
3523 && !(mask & OMP_CLAUSE_HOST) /* OpenACC compute construct */
3524 && (m = gfc_match_dupl_check (not_dupl: !c->self_expr, name: "self"))
3525 != MATCH_NO)
3526 {
3527 if (m == MATCH_ERROR)
3528 goto error;
3529 m = gfc_match (" ( %e )", &c->self_expr);
3530 if (m == MATCH_ERROR)
3531 {
3532 gfc_current_locus = old_loc;
3533 break;
3534 }
3535 else if (m == MATCH_NO)
3536 {
3537 c->self_expr = gfc_get_logical_expr (gfc_default_logical_kind,
3538 NULL, true);
3539 needs_space = true;
3540 }
3541 continue;
3542 }
3543 if ((mask & OMP_CLAUSE_SELF)
3544 && (mask & OMP_CLAUSE_HOST) /* OpenACC 'update' directive */
3545 && gfc_match ("self ( ") == MATCH_YES
3546 && gfc_match_omp_map_clause (list: &c->lists[OMP_LIST_MAP],
3547 map_op: OMP_MAP_FORCE_FROM, allow_common: true,
3548 /* allow_derived = */ true))
3549 continue;
3550 if ((mask & OMP_CLAUSE_SEQ)
3551 && (m = gfc_match_dupl_check (not_dupl: !c->seq, name: "seq")) != MATCH_NO)
3552 {
3553 if (m == MATCH_ERROR)
3554 goto error;
3555 c->seq = true;
3556 needs_space = true;
3557 continue;
3558 }
3559 if ((mask & OMP_CLAUSE_MEMORDER)
3560 && (m = gfc_match_dupl_memorder (not_dupl: (c->memorder
3561 == OMP_MEMORDER_UNSET),
3562 name: "seq_cst")) != MATCH_NO)
3563 {
3564 if (m == MATCH_ERROR)
3565 goto error;
3566 c->memorder = OMP_MEMORDER_SEQ_CST;
3567 needs_space = true;
3568 continue;
3569 }
3570 if ((mask & OMP_CLAUSE_SHARED)
3571 && gfc_match_omp_variable_list (str: "shared (",
3572 list: &c->lists[OMP_LIST_SHARED],
3573 allow_common: true) == MATCH_YES)
3574 continue;
3575 if ((mask & OMP_CLAUSE_SIMDLEN)
3576 && (m = gfc_match_dupl_check (not_dupl: !c->simdlen_expr, name: "simdlen", open_parens: true,
3577 expr: &c->simdlen_expr)) != MATCH_NO)
3578 {
3579 if (m == MATCH_ERROR)
3580 goto error;
3581 continue;
3582 }
3583 if ((mask & OMP_CLAUSE_SIMD)
3584 && (m = gfc_match_dupl_check (not_dupl: !c->simd, name: "simd")) != MATCH_NO)
3585 {
3586 if (m == MATCH_ERROR)
3587 goto error;
3588 c->simd = needs_space = true;
3589 continue;
3590 }
3591 if ((mask & OMP_CLAUSE_SEVERITY)
3592 && (m = gfc_match_dupl_check (not_dupl: !c->severity, name: "severity", open_parens: true))
3593 != MATCH_NO)
3594 {
3595 if (m == MATCH_ERROR)
3596 goto error;
3597 if (gfc_match ("fatal )") == MATCH_YES)
3598 c->severity = OMP_SEVERITY_FATAL;
3599 else if (gfc_match ("warning )") == MATCH_YES)
3600 c->severity = OMP_SEVERITY_WARNING;
3601 else
3602 {
3603 gfc_error ("Expected FATAL or WARNING in SEVERITY clause "
3604 "at %C");
3605 goto error;
3606 }
3607 continue;
3608 }
3609 break;
3610 case 't':
3611 if ((mask & OMP_CLAUSE_TASK_REDUCTION)
3612 && gfc_match_omp_clause_reduction (pc, c, openacc,
3613 allow_derived) == MATCH_YES)
3614 continue;
3615 if ((mask & OMP_CLAUSE_THREAD_LIMIT)
3616 && (m = gfc_match_dupl_check (not_dupl: !c->thread_limit, name: "thread_limit",
3617 open_parens: true, expr: &c->thread_limit))
3618 != MATCH_NO)
3619 {
3620 if (m == MATCH_ERROR)
3621 goto error;
3622 continue;
3623 }
3624 if ((mask & OMP_CLAUSE_THREADS)
3625 && (m = gfc_match_dupl_check (not_dupl: !c->threads, name: "threads"))
3626 != MATCH_NO)
3627 {
3628 if (m == MATCH_ERROR)
3629 goto error;
3630 c->threads = needs_space = true;
3631 continue;
3632 }
3633 if ((mask & OMP_CLAUSE_TILE)
3634 && !c->tile_list
3635 && match_oacc_expr_list (str: "tile (", list: &c->tile_list,
3636 allow_asterisk: true) == MATCH_YES)
3637 continue;
3638 if ((mask & OMP_CLAUSE_TO) && (mask & OMP_CLAUSE_LINK))
3639 {
3640 /* Declare target: 'to' is an alias for 'enter';
3641 'to' is deprecated since 5.2. */
3642 m = gfc_match_omp_to_link (str: "to (", list: &c->lists[OMP_LIST_TO]);
3643 if (m == MATCH_ERROR)
3644 goto error;
3645 if (m == MATCH_YES)
3646 continue;
3647 }
3648 else if ((mask & OMP_CLAUSE_TO)
3649 && gfc_match_motion_var_list (str: "to (", list: &c->lists[OMP_LIST_TO],
3650 headp: &head) == MATCH_YES)
3651 continue;
3652 break;
3653 case 'u':
3654 if ((mask & OMP_CLAUSE_UNIFORM)
3655 && gfc_match_omp_variable_list (str: "uniform (",
3656 list: &c->lists[OMP_LIST_UNIFORM],
3657 allow_common: false) == MATCH_YES)
3658 continue;
3659 if ((mask & OMP_CLAUSE_UNTIED)
3660 && (m = gfc_match_dupl_check (not_dupl: !c->untied, name: "untied")) != MATCH_NO)
3661 {
3662 if (m == MATCH_ERROR)
3663 goto error;
3664 c->untied = needs_space = true;
3665 continue;
3666 }
3667 if ((mask & OMP_CLAUSE_ATOMIC)
3668 && (m = gfc_match_dupl_atomic (not_dupl: (c->atomic_op
3669 == GFC_OMP_ATOMIC_UNSET),
3670 name: "update")) != MATCH_NO)
3671 {
3672 if (m == MATCH_ERROR)
3673 goto error;
3674 c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
3675 needs_space = true;
3676 continue;
3677 }
3678 if ((mask & OMP_CLAUSE_USE_DEVICE)
3679 && gfc_match_omp_variable_list (str: "use_device (",
3680 list: &c->lists[OMP_LIST_USE_DEVICE],
3681 allow_common: true) == MATCH_YES)
3682 continue;
3683 if ((mask & OMP_CLAUSE_USE_DEVICE_PTR)
3684 && gfc_match_omp_variable_list
3685 (str: "use_device_ptr (",
3686 list: &c->lists[OMP_LIST_USE_DEVICE_PTR], allow_common: false) == MATCH_YES)
3687 continue;
3688 if ((mask & OMP_CLAUSE_USE_DEVICE_ADDR)
3689 && gfc_match_omp_variable_list
3690 (str: "use_device_addr (", list: &c->lists[OMP_LIST_USE_DEVICE_ADDR],
3691 allow_common: false, NULL, NULL, allow_sections: true) == MATCH_YES)
3692 continue;
3693 if ((mask & OMP_CLAUSE_USES_ALLOCATORS)
3694 && (gfc_match ("uses_allocators ( ") == MATCH_YES))
3695 {
3696 if (gfc_match_omp_clause_uses_allocators (c) != MATCH_YES)
3697 goto error;
3698 continue;
3699 }
3700 break;
3701 case 'v':
3702 /* VECTOR_LENGTH must be matched before VECTOR, because the latter
3703 doesn't unconditionally match '('. */
3704 if ((mask & OMP_CLAUSE_VECTOR_LENGTH)
3705 && (m = gfc_match_dupl_check (not_dupl: !c->vector_length_expr,
3706 name: "vector_length", open_parens: true,
3707 expr: &c->vector_length_expr))
3708 != MATCH_NO)
3709 {
3710 if (m == MATCH_ERROR)
3711 goto error;
3712 continue;
3713 }
3714 if ((mask & OMP_CLAUSE_VECTOR)
3715 && (m = gfc_match_dupl_check (not_dupl: !c->vector, name: "vector")) != MATCH_NO)
3716 {
3717 if (m == MATCH_ERROR)
3718 goto error;
3719 c->vector = true;
3720 m = match_oacc_clause_gwv (cp: c, GOMP_DIM_VECTOR);
3721 if (m == MATCH_ERROR)
3722 goto error;
3723 if (m == MATCH_NO)
3724 needs_space = true;
3725 continue;
3726 }
3727 break;
3728 case 'w':
3729 if ((mask & OMP_CLAUSE_WAIT)
3730 && gfc_match ("wait") == MATCH_YES)
3731 {
3732 m = match_oacc_expr_list (str: " (", list: &c->wait_list, allow_asterisk: false);
3733 if (m == MATCH_ERROR)
3734 goto error;
3735 else if (m == MATCH_NO)
3736 {
3737 gfc_expr *expr
3738 = gfc_get_constant_expr (BT_INTEGER,
3739 gfc_default_integer_kind,
3740 &gfc_current_locus);
3741 mpz_set_si (expr->value.integer, GOMP_ASYNC_NOVAL);
3742 gfc_expr_list **expr_list = &c->wait_list;
3743 while (*expr_list)
3744 expr_list = &(*expr_list)->next;
3745 *expr_list = gfc_get_expr_list ();
3746 (*expr_list)->expr = expr;
3747 needs_space = true;
3748 }
3749 continue;
3750 }
3751 if ((mask & OMP_CLAUSE_WEAK)
3752 && (m = gfc_match_dupl_check (not_dupl: !c->weak, name: "weak"))
3753 != MATCH_NO)
3754 {
3755 if (m == MATCH_ERROR)
3756 goto error;
3757 c->weak = true;
3758 needs_space = true;
3759 continue;
3760 }
3761 if ((mask & OMP_CLAUSE_WORKER)
3762 && (m = gfc_match_dupl_check (not_dupl: !c->worker, name: "worker")) != MATCH_NO)
3763 {
3764 if (m == MATCH_ERROR)
3765 goto error;
3766 c->worker = true;
3767 m = match_oacc_clause_gwv (cp: c, GOMP_DIM_WORKER);
3768 if (m == MATCH_ERROR)
3769 goto error;
3770 else if (m == MATCH_NO)
3771 needs_space = true;
3772 continue;
3773 }
3774 if ((mask & OMP_CLAUSE_ATOMIC)
3775 && (m = gfc_match_dupl_atomic (not_dupl: (c->atomic_op
3776 == GFC_OMP_ATOMIC_UNSET),
3777 name: "write")) != MATCH_NO)
3778 {
3779 if (m == MATCH_ERROR)
3780 goto error;
3781 c->atomic_op = GFC_OMP_ATOMIC_WRITE;
3782 needs_space = true;
3783 continue;
3784 }
3785 break;
3786 }
3787 break;
3788 }
3789
3790end:
3791 if (error
3792 || (context_selector && gfc_peek_ascii_char () != ')')
3793 || (!context_selector && gfc_match_omp_eos () != MATCH_YES))
3794 {
3795 if (!gfc_error_flag_test ())
3796 gfc_error ("Failed to match clause at %C");
3797 gfc_free_omp_clauses (c);
3798 return MATCH_ERROR;
3799 }
3800
3801 *cp = c;
3802 return MATCH_YES;
3803
3804error:
3805 error = true;
3806 goto end;
3807}
3808
3809
3810#define OACC_PARALLEL_CLAUSES \
3811 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
3812 | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_REDUCTION \
3813 | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
3814 | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
3815 | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
3816 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \
3817 | OMP_CLAUSE_SELF)
3818#define OACC_KERNELS_CLAUSES \
3819 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
3820 | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_DEVICEPTR \
3821 | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
3822 | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
3823 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \
3824 | OMP_CLAUSE_SELF)
3825#define OACC_SERIAL_CLAUSES \
3826 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_REDUCTION \
3827 | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
3828 | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
3829 | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
3830 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH \
3831 | OMP_CLAUSE_SELF)
3832#define OACC_DATA_CLAUSES \
3833 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_COPY \
3834 | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_CREATE \
3835 | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_ATTACH \
3836 | OMP_CLAUSE_DEFAULT)
3837#define OACC_LOOP_CLAUSES \
3838 (omp_mask (OMP_CLAUSE_COLLAPSE) | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER \
3839 | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ | OMP_CLAUSE_INDEPENDENT \
3840 | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_AUTO \
3841 | OMP_CLAUSE_TILE)
3842#define OACC_PARALLEL_LOOP_CLAUSES \
3843 (OACC_LOOP_CLAUSES | OACC_PARALLEL_CLAUSES)
3844#define OACC_KERNELS_LOOP_CLAUSES \
3845 (OACC_LOOP_CLAUSES | OACC_KERNELS_CLAUSES)
3846#define OACC_SERIAL_LOOP_CLAUSES \
3847 (OACC_LOOP_CLAUSES | OACC_SERIAL_CLAUSES)
3848#define OACC_HOST_DATA_CLAUSES \
3849 (omp_mask (OMP_CLAUSE_USE_DEVICE) \
3850 | OMP_CLAUSE_IF \
3851 | OMP_CLAUSE_IF_PRESENT)
3852#define OACC_DECLARE_CLAUSES \
3853 (omp_mask (OMP_CLAUSE_COPY) | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
3854 | OMP_CLAUSE_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_DEVICE_RESIDENT \
3855 | OMP_CLAUSE_PRESENT \
3856 | OMP_CLAUSE_LINK)
3857#define OACC_UPDATE_CLAUSES \
3858 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_HOST \
3859 | OMP_CLAUSE_DEVICE | OMP_CLAUSE_WAIT | OMP_CLAUSE_IF_PRESENT \
3860 | OMP_CLAUSE_SELF)
3861#define OACC_ENTER_DATA_CLAUSES \
3862 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
3863 | OMP_CLAUSE_COPYIN | OMP_CLAUSE_CREATE | OMP_CLAUSE_ATTACH)
3864#define OACC_EXIT_DATA_CLAUSES \
3865 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
3866 | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE | OMP_CLAUSE_FINALIZE \
3867 | OMP_CLAUSE_DETACH)
3868#define OACC_WAIT_CLAUSES \
3869 omp_mask (OMP_CLAUSE_ASYNC)
3870#define OACC_ROUTINE_CLAUSES \
3871 (omp_mask (OMP_CLAUSE_GANG) | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR \
3872 | OMP_CLAUSE_SEQ \
3873 | OMP_CLAUSE_NOHOST)
3874
3875
3876static match
3877match_acc (gfc_exec_op op, const omp_mask mask)
3878{
3879 gfc_omp_clauses *c;
3880 if (gfc_match_omp_clauses (cp: &c, mask, first: false, needs_space: false, openacc: true) != MATCH_YES)
3881 return MATCH_ERROR;
3882 new_st.op = op;
3883 new_st.ext.omp_clauses = c;
3884 return MATCH_YES;
3885}
3886
3887match
3888gfc_match_oacc_parallel_loop (void)
3889{
3890 return match_acc (op: EXEC_OACC_PARALLEL_LOOP, OACC_PARALLEL_LOOP_CLAUSES);
3891}
3892
3893
3894match
3895gfc_match_oacc_parallel (void)
3896{
3897 return match_acc (op: EXEC_OACC_PARALLEL, OACC_PARALLEL_CLAUSES);
3898}
3899
3900
3901match
3902gfc_match_oacc_kernels_loop (void)
3903{
3904 return match_acc (op: EXEC_OACC_KERNELS_LOOP, OACC_KERNELS_LOOP_CLAUSES);
3905}
3906
3907
3908match
3909gfc_match_oacc_kernels (void)
3910{
3911 return match_acc (op: EXEC_OACC_KERNELS, OACC_KERNELS_CLAUSES);
3912}
3913
3914
3915match
3916gfc_match_oacc_serial_loop (void)
3917{
3918 return match_acc (op: EXEC_OACC_SERIAL_LOOP, OACC_SERIAL_LOOP_CLAUSES);
3919}
3920
3921
3922match
3923gfc_match_oacc_serial (void)
3924{
3925 return match_acc (op: EXEC_OACC_SERIAL, OACC_SERIAL_CLAUSES);
3926}
3927
3928
3929match
3930gfc_match_oacc_data (void)
3931{
3932 return match_acc (op: EXEC_OACC_DATA, OACC_DATA_CLAUSES);
3933}
3934
3935
3936match
3937gfc_match_oacc_host_data (void)
3938{
3939 return match_acc (op: EXEC_OACC_HOST_DATA, OACC_HOST_DATA_CLAUSES);
3940}
3941
3942
3943match
3944gfc_match_oacc_loop (void)
3945{
3946 return match_acc (op: EXEC_OACC_LOOP, OACC_LOOP_CLAUSES);
3947}
3948
3949
3950match
3951gfc_match_oacc_declare (void)
3952{
3953 gfc_omp_clauses *c;
3954 gfc_omp_namelist *n;
3955 gfc_namespace *ns = gfc_current_ns;
3956 gfc_oacc_declare *new_oc;
3957 bool module_var = false;
3958 locus where = gfc_current_locus;
3959
3960 if (gfc_match_omp_clauses (cp: &c, OACC_DECLARE_CLAUSES, first: false, needs_space: false, openacc: true)
3961 != MATCH_YES)
3962 return MATCH_ERROR;
3963
3964 for (n = c->lists[OMP_LIST_DEVICE_RESIDENT]; n != NULL; n = n->next)
3965 n->sym->attr.oacc_declare_device_resident = 1;
3966
3967 for (n = c->lists[OMP_LIST_LINK]; n != NULL; n = n->next)
3968 n->sym->attr.oacc_declare_link = 1;
3969
3970 for (n = c->lists[OMP_LIST_MAP]; n != NULL; n = n->next)
3971 {
3972 gfc_symbol *s = n->sym;
3973
3974 if (gfc_current_ns->proc_name
3975 && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
3976 {
3977 if (n->u.map_op != OMP_MAP_ALLOC && n->u.map_op != OMP_MAP_TO)
3978 {
3979 gfc_error ("Invalid clause in module with !$ACC DECLARE at %L",
3980 &where);
3981 return MATCH_ERROR;
3982 }
3983
3984 module_var = true;
3985 }
3986
3987 if (s->attr.use_assoc)
3988 {
3989 gfc_error ("Variable is USE-associated with !$ACC DECLARE at %L",
3990 &where);
3991 return MATCH_ERROR;
3992 }
3993
3994 if ((s->result == s && s->ns->contained != gfc_current_ns)
3995 || ((s->attr.flavor == FL_UNKNOWN || s->attr.flavor == FL_VARIABLE)
3996 && s->ns != gfc_current_ns))
3997 {
3998 gfc_error ("Variable %qs shall be declared in the same scoping unit "
3999 "as !$ACC DECLARE at %L", s->name, &where);
4000 return MATCH_ERROR;
4001 }
4002
4003 if ((s->attr.dimension || s->attr.codimension)
4004 && s->attr.dummy && s->as->type != AS_EXPLICIT)
4005 {
4006 gfc_error ("Assumed-size dummy array with !$ACC DECLARE at %L",
4007 &where);
4008 return MATCH_ERROR;
4009 }
4010
4011 switch (n->u.map_op)
4012 {
4013 case OMP_MAP_FORCE_ALLOC:
4014 case OMP_MAP_ALLOC:
4015 s->attr.oacc_declare_create = 1;
4016 break;
4017
4018 case OMP_MAP_FORCE_TO:
4019 case OMP_MAP_TO:
4020 s->attr.oacc_declare_copyin = 1;
4021 break;
4022
4023 case OMP_MAP_FORCE_DEVICEPTR:
4024 s->attr.oacc_declare_deviceptr = 1;
4025 break;
4026
4027 default:
4028 break;
4029 }
4030 }
4031
4032 new_oc = gfc_get_oacc_declare ();
4033 new_oc->next = ns->oacc_declare;
4034 new_oc->module_var = module_var;
4035 new_oc->clauses = c;
4036 new_oc->loc = gfc_current_locus;
4037 ns->oacc_declare = new_oc;
4038
4039 return MATCH_YES;
4040}
4041
4042
4043match
4044gfc_match_oacc_update (void)
4045{
4046 gfc_omp_clauses *c;
4047 locus here = gfc_current_locus;
4048
4049 if (gfc_match_omp_clauses (cp: &c, OACC_UPDATE_CLAUSES, first: false, needs_space: false, openacc: true)
4050 != MATCH_YES)
4051 return MATCH_ERROR;
4052
4053 if (!c->lists[OMP_LIST_MAP])
4054 {
4055 gfc_error ("%<acc update%> must contain at least one "
4056 "%<device%> or %<host%> or %<self%> clause at %L", &here);
4057 return MATCH_ERROR;
4058 }
4059
4060 new_st.op = EXEC_OACC_UPDATE;
4061 new_st.ext.omp_clauses = c;
4062 return MATCH_YES;
4063}
4064
4065
4066match
4067gfc_match_oacc_enter_data (void)
4068{
4069 return match_acc (op: EXEC_OACC_ENTER_DATA, OACC_ENTER_DATA_CLAUSES);
4070}
4071
4072
4073match
4074gfc_match_oacc_exit_data (void)
4075{
4076 return match_acc (op: EXEC_OACC_EXIT_DATA, OACC_EXIT_DATA_CLAUSES);
4077}
4078
4079
4080match
4081gfc_match_oacc_wait (void)
4082{
4083 gfc_omp_clauses *c = gfc_get_omp_clauses ();
4084 gfc_expr_list *wait_list = NULL, *el;
4085 bool space = true;
4086 match m;
4087
4088 m = match_oacc_expr_list (str: " (", list: &wait_list, allow_asterisk: true);
4089 if (m == MATCH_ERROR)
4090 return m;
4091 else if (m == MATCH_YES)
4092 space = false;
4093
4094 if (gfc_match_omp_clauses (cp: &c, OACC_WAIT_CLAUSES, first: space, needs_space: space, openacc: true)
4095 == MATCH_ERROR)
4096 return MATCH_ERROR;
4097
4098 if (wait_list)
4099 for (el = wait_list; el; el = el->next)
4100 {
4101 if (el->expr == NULL)
4102 {
4103 gfc_error ("Invalid argument to !$ACC WAIT at %C");
4104 return MATCH_ERROR;
4105 }
4106
4107 if (!gfc_resolve_expr (el->expr)
4108 || el->expr->ts.type != BT_INTEGER || el->expr->rank != 0)
4109 {
4110 gfc_error ("WAIT clause at %L requires a scalar INTEGER expression",
4111 &el->expr->where);
4112
4113 return MATCH_ERROR;
4114 }
4115 }
4116 c->wait_list = wait_list;
4117 new_st.op = EXEC_OACC_WAIT;
4118 new_st.ext.omp_clauses = c;
4119 return MATCH_YES;
4120}
4121
4122
4123match
4124gfc_match_oacc_cache (void)
4125{
4126 gfc_omp_clauses *c = gfc_get_omp_clauses ();
4127 /* The OpenACC cache directive explicitly only allows "array elements or
4128 subarrays", which we're currently not checking here. Either check this
4129 after the call of gfc_match_omp_variable_list, or add something like a
4130 only_sections variant next to its allow_sections parameter. */
4131 match m = gfc_match_omp_variable_list (str: " (",
4132 list: &c->lists[OMP_LIST_CACHE], allow_common: true,
4133 NULL, NULL, allow_sections: true);
4134 if (m != MATCH_YES)
4135 {
4136 gfc_free_omp_clauses(c);
4137 return m;
4138 }
4139
4140 if (gfc_current_state() != COMP_DO
4141 && gfc_current_state() != COMP_DO_CONCURRENT)
4142 {
4143 gfc_error ("ACC CACHE directive must be inside of loop %C");
4144 gfc_free_omp_clauses(c);
4145 return MATCH_ERROR;
4146 }
4147
4148 new_st.op = EXEC_OACC_CACHE;
4149 new_st.ext.omp_clauses = c;
4150 return MATCH_YES;
4151}
4152
4153/* Determine the OpenACC 'routine' directive's level of parallelism. */
4154
4155static oacc_routine_lop
4156gfc_oacc_routine_lop (gfc_omp_clauses *clauses)
4157{
4158 oacc_routine_lop ret = OACC_ROUTINE_LOP_SEQ;
4159
4160 if (clauses)
4161 {
4162 unsigned n_lop_clauses = 0;
4163
4164 if (clauses->gang)
4165 {
4166 ++n_lop_clauses;
4167 ret = OACC_ROUTINE_LOP_GANG;
4168 }
4169 if (clauses->worker)
4170 {
4171 ++n_lop_clauses;
4172 ret = OACC_ROUTINE_LOP_WORKER;
4173 }
4174 if (clauses->vector)
4175 {
4176 ++n_lop_clauses;
4177 ret = OACC_ROUTINE_LOP_VECTOR;
4178 }
4179 if (clauses->seq)
4180 {
4181 ++n_lop_clauses;
4182 ret = OACC_ROUTINE_LOP_SEQ;
4183 }
4184
4185 if (n_lop_clauses > 1)
4186 ret = OACC_ROUTINE_LOP_ERROR;
4187 }
4188
4189 return ret;
4190}
4191
4192match
4193gfc_match_oacc_routine (void)
4194{
4195 locus old_loc;
4196 match m;
4197 gfc_intrinsic_sym *isym = NULL;
4198 gfc_symbol *sym = NULL;
4199 gfc_omp_clauses *c = NULL;
4200 gfc_oacc_routine_name *n = NULL;
4201 oacc_routine_lop lop = OACC_ROUTINE_LOP_NONE;
4202 bool nohost;
4203
4204 old_loc = gfc_current_locus;
4205
4206 m = gfc_match (" (");
4207
4208 if (gfc_current_ns->proc_name
4209 && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
4210 && m == MATCH_YES)
4211 {
4212 gfc_error ("Only the !$ACC ROUTINE form without "
4213 "list is allowed in interface block at %C");
4214 goto cleanup;
4215 }
4216
4217 if (m == MATCH_YES)
4218 {
4219 char buffer[GFC_MAX_SYMBOL_LEN + 1];
4220
4221 m = gfc_match_name (buffer);
4222 if (m == MATCH_YES)
4223 {
4224 gfc_symtree *st = NULL;
4225
4226 /* First look for an intrinsic symbol. */
4227 isym = gfc_find_function (buffer);
4228 if (!isym)
4229 isym = gfc_find_subroutine (buffer);
4230 /* If no intrinsic symbol found, search the current namespace. */
4231 if (!isym)
4232 st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);
4233 if (st)
4234 {
4235 sym = st->n.sym;
4236 /* If the name in a 'routine' directive refers to the containing
4237 subroutine or function, then make sure that we'll later handle
4238 this accordingly. */
4239 if (gfc_current_ns->proc_name != NULL
4240 && strcmp (s1: sym->name, s2: gfc_current_ns->proc_name->name) == 0)
4241 sym = NULL;
4242 }
4243
4244 if (isym == NULL && st == NULL)
4245 {
4246 gfc_error ("Invalid NAME %qs in !$ACC ROUTINE ( NAME ) at %C",
4247 buffer);
4248 gfc_current_locus = old_loc;
4249 return MATCH_ERROR;
4250 }
4251 }
4252 else
4253 {
4254 gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C");
4255 gfc_current_locus = old_loc;
4256 return MATCH_ERROR;
4257 }
4258
4259 if (gfc_match_char (')') != MATCH_YES)
4260 {
4261 gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting"
4262 " %<)%> after NAME");
4263 gfc_current_locus = old_loc;
4264 return MATCH_ERROR;
4265 }
4266 }
4267
4268 if (gfc_match_omp_eos () != MATCH_YES
4269 && (gfc_match_omp_clauses (cp: &c, OACC_ROUTINE_CLAUSES, first: false, needs_space: false, openacc: true)
4270 != MATCH_YES))
4271 return MATCH_ERROR;
4272
4273 lop = gfc_oacc_routine_lop (clauses: c);
4274 if (lop == OACC_ROUTINE_LOP_ERROR)
4275 {
4276 gfc_error ("Multiple loop axes specified for routine at %C");
4277 goto cleanup;
4278 }
4279 nohost = c ? c->nohost : false;
4280
4281 if (isym != NULL)
4282 {
4283 /* Diagnose any OpenACC 'routine' directive that doesn't match the
4284 (implicit) one with a 'seq' clause. */
4285 if (c && (c->gang || c->worker || c->vector))
4286 {
4287 gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )"
4288 " at %C marked with incompatible GANG, WORKER, or VECTOR"
4289 " clause");
4290 goto cleanup;
4291 }
4292 /* ..., and no 'nohost' clause. */
4293 if (nohost)
4294 {
4295 gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )"
4296 " at %C marked with incompatible NOHOST clause");
4297 goto cleanup;
4298 }
4299 }
4300 else if (sym != NULL)
4301 {
4302 bool add = true;
4303
4304 /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
4305 match the first one. */
4306 for (gfc_oacc_routine_name *n_p = gfc_current_ns->oacc_routine_names;
4307 n_p;
4308 n_p = n_p->next)
4309 if (n_p->sym == sym)
4310 {
4311 add = false;
4312 bool nohost_p = n_p->clauses ? n_p->clauses->nohost : false;
4313 if (lop != gfc_oacc_routine_lop (clauses: n_p->clauses)
4314 || nohost != nohost_p)
4315 {
4316 gfc_error ("!$ACC ROUTINE already applied at %C");
4317 goto cleanup;
4318 }
4319 }
4320
4321 if (add)
4322 {
4323 sym->attr.oacc_routine_lop = lop;
4324 sym->attr.oacc_routine_nohost = nohost;
4325
4326 n = gfc_get_oacc_routine_name ();
4327 n->sym = sym;
4328 n->clauses = c;
4329 n->next = gfc_current_ns->oacc_routine_names;
4330 n->loc = old_loc;
4331 gfc_current_ns->oacc_routine_names = n;
4332 }
4333 }
4334 else if (gfc_current_ns->proc_name)
4335 {
4336 /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
4337 match the first one. */
4338 oacc_routine_lop lop_p = gfc_current_ns->proc_name->attr.oacc_routine_lop;
4339 bool nohost_p = gfc_current_ns->proc_name->attr.oacc_routine_nohost;
4340 if (lop_p != OACC_ROUTINE_LOP_NONE
4341 && (lop != lop_p
4342 || nohost != nohost_p))
4343 {
4344 gfc_error ("!$ACC ROUTINE already applied at %C");
4345 goto cleanup;
4346 }
4347
4348 if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
4349 gfc_current_ns->proc_name->name,
4350 &old_loc))
4351 goto cleanup;
4352 gfc_current_ns->proc_name->attr.oacc_routine_lop = lop;
4353 gfc_current_ns->proc_name->attr.oacc_routine_nohost = nohost;
4354 }
4355 else
4356 /* Something has gone wrong, possibly a syntax error. */
4357 goto cleanup;
4358
4359 if (gfc_pure (NULL) && c && (c->gang || c->worker || c->vector))
4360 {
4361 gfc_error ("!$ACC ROUTINE with GANG, WORKER, or VECTOR clause is not "
4362 "permitted in PURE procedure at %C");
4363 goto cleanup;
4364 }
4365
4366
4367 if (n)
4368 n->clauses = c;
4369 else if (gfc_current_ns->oacc_routine)
4370 gfc_current_ns->oacc_routine_clauses = c;
4371
4372 new_st.op = EXEC_OACC_ROUTINE;
4373 new_st.ext.omp_clauses = c;
4374 return MATCH_YES;
4375
4376cleanup:
4377 gfc_current_locus = old_loc;
4378 return MATCH_ERROR;
4379}
4380
4381
4382#define OMP_PARALLEL_CLAUSES \
4383 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
4384 | OMP_CLAUSE_SHARED | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION \
4385 | OMP_CLAUSE_IF | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT \
4386 | OMP_CLAUSE_PROC_BIND | OMP_CLAUSE_ALLOCATE)
4387#define OMP_DECLARE_SIMD_CLAUSES \
4388 (omp_mask (OMP_CLAUSE_SIMDLEN) | OMP_CLAUSE_LINEAR \
4389 | OMP_CLAUSE_UNIFORM | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_INBRANCH \
4390 | OMP_CLAUSE_NOTINBRANCH)
4391#define OMP_DO_CLAUSES \
4392 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
4393 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
4394 | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE \
4395 | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ORDER | OMP_CLAUSE_ALLOCATE \
4396 | OMP_CLAUSE_NOWAIT)
4397#define OMP_LOOP_CLAUSES \
4398 (omp_mask (OMP_CLAUSE_BIND) | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_ORDER \
4399 | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
4400
4401#define OMP_SCOPE_CLAUSES \
4402 (omp_mask (OMP_CLAUSE_PRIVATE) |OMP_CLAUSE_FIRSTPRIVATE \
4403 | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT)
4404#define OMP_SECTIONS_CLAUSES \
4405 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
4406 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
4407 | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT)
4408#define OMP_SIMD_CLAUSES \
4409 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_LASTPRIVATE \
4410 | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_SAFELEN \
4411 | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_SIMDLEN \
4412 | OMP_CLAUSE_IF | OMP_CLAUSE_ORDER | OMP_CLAUSE_NOTEMPORAL)
4413#define OMP_TASK_CLAUSES \
4414 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
4415 | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT \
4416 | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE \
4417 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_IN_REDUCTION \
4418 | OMP_CLAUSE_DETACH | OMP_CLAUSE_AFFINITY | OMP_CLAUSE_ALLOCATE)
4419#define OMP_TASKLOOP_CLAUSES \
4420 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
4421 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF \
4422 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL \
4423 | OMP_CLAUSE_MERGEABLE | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_GRAINSIZE \
4424 | OMP_CLAUSE_NUM_TASKS | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_NOGROUP \
4425 | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IN_REDUCTION | OMP_CLAUSE_ALLOCATE)
4426#define OMP_TASKGROUP_CLAUSES \
4427 (omp_mask (OMP_CLAUSE_TASK_REDUCTION) | OMP_CLAUSE_ALLOCATE)
4428#define OMP_TARGET_CLAUSES \
4429 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
4430 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_PRIVATE \
4431 | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULTMAP \
4432 | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_IN_REDUCTION \
4433 | OMP_CLAUSE_THREAD_LIMIT | OMP_CLAUSE_ALLOCATE \
4434 | OMP_CLAUSE_HAS_DEVICE_ADDR | OMP_CLAUSE_USES_ALLOCATORS)
4435#define OMP_TARGET_DATA_CLAUSES \
4436 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
4437 | OMP_CLAUSE_USE_DEVICE_PTR | OMP_CLAUSE_USE_DEVICE_ADDR)
4438#define OMP_TARGET_ENTER_DATA_CLAUSES \
4439 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
4440 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
4441#define OMP_TARGET_EXIT_DATA_CLAUSES \
4442 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
4443 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
4444#define OMP_TARGET_UPDATE_CLAUSES \
4445 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_IF | OMP_CLAUSE_TO \
4446 | OMP_CLAUSE_FROM | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
4447#define OMP_TEAMS_CLAUSES \
4448 (omp_mask (OMP_CLAUSE_NUM_TEAMS) | OMP_CLAUSE_THREAD_LIMIT \
4449 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
4450 | OMP_CLAUSE_SHARED | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_ALLOCATE)
4451#define OMP_DISTRIBUTE_CLAUSES \
4452 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
4453 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_DIST_SCHEDULE \
4454 | OMP_CLAUSE_ORDER | OMP_CLAUSE_ALLOCATE)
4455#define OMP_SINGLE_CLAUSES \
4456 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
4457 | OMP_CLAUSE_ALLOCATE | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_COPYPRIVATE)
4458#define OMP_ORDERED_CLAUSES \
4459 (omp_mask (OMP_CLAUSE_THREADS) | OMP_CLAUSE_SIMD)
4460#define OMP_DECLARE_TARGET_CLAUSES \
4461 (omp_mask (OMP_CLAUSE_ENTER) | OMP_CLAUSE_LINK | OMP_CLAUSE_DEVICE_TYPE \
4462 | OMP_CLAUSE_TO)
4463#define OMP_ATOMIC_CLAUSES \
4464 (omp_mask (OMP_CLAUSE_ATOMIC) | OMP_CLAUSE_CAPTURE | OMP_CLAUSE_HINT \
4465 | OMP_CLAUSE_MEMORDER | OMP_CLAUSE_COMPARE | OMP_CLAUSE_FAIL \
4466 | OMP_CLAUSE_WEAK)
4467#define OMP_MASKED_CLAUSES \
4468 (omp_mask (OMP_CLAUSE_FILTER))
4469#define OMP_ERROR_CLAUSES \
4470 (omp_mask (OMP_CLAUSE_AT) | OMP_CLAUSE_MESSAGE | OMP_CLAUSE_SEVERITY)
4471#define OMP_WORKSHARE_CLAUSES \
4472 omp_mask (OMP_CLAUSE_NOWAIT)
4473#define OMP_ALLOCATORS_CLAUSES \
4474 omp_mask (OMP_CLAUSE_ALLOCATE)
4475
4476
4477static match
4478match_omp (gfc_exec_op op, const omp_mask mask)
4479{
4480 gfc_omp_clauses *c;
4481 if (gfc_match_omp_clauses (cp: &c, mask, first: true, needs_space: true, openacc: false, context_selector: false,
4482 openmp_target: op == EXEC_OMP_TARGET) != MATCH_YES)
4483 return MATCH_ERROR;
4484 new_st.op = op;
4485 new_st.ext.omp_clauses = c;
4486 return MATCH_YES;
4487}
4488
4489/* Handles both declarative and (deprecated) executable ALLOCATE directive;
4490 accepts optional list (for executable) and common blocks.
4491 If no variables have been provided, the single omp namelist has sym == NULL.
4492
4493 Note that the executable ALLOCATE directive permits structure elements only
4494 in OpenMP 5.0 and 5.1 but not longer in 5.2. See also the comment on the
4495 'omp allocators' directive below. The accidental change was reverted for
4496 OpenMP TR12, permitting them again. See also gfc_match_omp_allocators.
4497
4498 Hence, structure elements are rejected for now, also to make resolving
4499 OMP_LIST_ALLOCATE simpler (check for duplicates, same symbol in
4500 Fortran allocate stmt). TODO: Permit structure elements. */
4501
4502match
4503gfc_match_omp_allocate (void)
4504{
4505 match m;
4506 bool first = true;
4507 gfc_omp_namelist *vars = NULL;
4508 gfc_expr *align = NULL;
4509 gfc_expr *allocator = NULL;
4510 locus loc = gfc_current_locus;
4511
4512 m = gfc_match_omp_variable_list (str: " (", list: &vars, allow_common: true, NULL, NULL, allow_sections: true, allow_derived: true,
4513 NULL, reject_common_vars: true);
4514
4515 if (m == MATCH_ERROR)
4516 return m;
4517
4518 while (true)
4519 {
4520 gfc_gobble_whitespace ();
4521 if (gfc_match_omp_eos () == MATCH_YES)
4522 break;
4523 if (!first)
4524 gfc_match (", ");
4525 first = false;
4526 if ((m = gfc_match_dupl_check (not_dupl: !align, name: "align", open_parens: true, expr: &align))
4527 != MATCH_NO)
4528 {
4529 if (m == MATCH_ERROR)
4530 goto error;
4531 continue;
4532 }
4533 if ((m = gfc_match_dupl_check (not_dupl: !allocator, name: "allocator",
4534 open_parens: true, expr: &allocator)) != MATCH_NO)
4535 {
4536 if (m == MATCH_ERROR)
4537 goto error;
4538 continue;
4539 }
4540 gfc_error ("Expected ALIGN or ALLOCATOR clause at %C");
4541 return MATCH_ERROR;
4542 }
4543 for (gfc_omp_namelist *n = vars; n; n = n->next)
4544 if (n->expr)
4545 {
4546 if ((n->expr->ref && n->expr->ref->type == REF_COMPONENT)
4547 || (n->expr->ref->next && n->expr->ref->type == REF_COMPONENT))
4548 gfc_error ("Sorry, structure-element list item at %L in ALLOCATE "
4549 "directive is not yet supported", &n->expr->where);
4550 else
4551 gfc_error ("Unexpected expression as list item at %L in ALLOCATE "
4552 "directive", &n->expr->where);
4553
4554 gfc_free_omp_namelist (vars, false, true, false);
4555 goto error;
4556 }
4557
4558 new_st.op = EXEC_OMP_ALLOCATE;
4559 new_st.ext.omp_clauses = gfc_get_omp_clauses ();
4560 if (vars == NULL)
4561 {
4562 vars = gfc_get_omp_namelist ();
4563 vars->where = loc;
4564 vars->u.align = align;
4565 vars->u2.allocator = allocator;
4566 new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = vars;
4567 }
4568 else
4569 {
4570 new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = vars;
4571 for (; vars; vars = vars->next)
4572 {
4573 vars->u.align = (align) ? gfc_copy_expr (align) : NULL;
4574 vars->u2.allocator = allocator;
4575 }
4576 gfc_free_expr (align);
4577 }
4578 return MATCH_YES;
4579
4580error:
4581 gfc_free_expr (align);
4582 gfc_free_expr (allocator);
4583 return MATCH_ERROR;
4584}
4585
4586/* In line with OpenMP 5.2 derived-type components are rejected.
4587 See also comment before gfc_match_omp_allocate. */
4588
4589match
4590gfc_match_omp_allocators (void)
4591{
4592 return match_omp (op: EXEC_OMP_ALLOCATORS, OMP_ALLOCATORS_CLAUSES);
4593}
4594
4595
4596match
4597gfc_match_omp_assume (void)
4598{
4599 gfc_omp_clauses *c;
4600 locus loc = gfc_current_locus;
4601 if ((gfc_match_omp_clauses (cp: &c, mask: omp_mask (OMP_CLAUSE_ASSUMPTIONS))
4602 != MATCH_YES)
4603 || (omp_verify_merge_absent_contains (st: ST_OMP_ASSUME, check: c->assume, NULL,
4604 loc: &loc) != MATCH_YES))
4605 return MATCH_ERROR;
4606 new_st.op = EXEC_OMP_ASSUME;
4607 new_st.ext.omp_clauses = c;
4608 return MATCH_YES;
4609}
4610
4611
4612match
4613gfc_match_omp_assumes (void)
4614{
4615 gfc_omp_clauses *c;
4616 locus loc = gfc_current_locus;
4617 if (!gfc_current_ns->proc_name
4618 || (gfc_current_ns->proc_name->attr.flavor != FL_MODULE
4619 && !gfc_current_ns->proc_name->attr.subroutine
4620 && !gfc_current_ns->proc_name->attr.function))
4621 {
4622 gfc_error ("!$OMP ASSUMES at %C must be in the specification part of a "
4623 "subprogram or module");
4624 return MATCH_ERROR;
4625 }
4626 if ((gfc_match_omp_clauses (cp: &c, mask: omp_mask (OMP_CLAUSE_ASSUMPTIONS))
4627 != MATCH_YES)
4628 || (omp_verify_merge_absent_contains (st: ST_OMP_ASSUMES, check: c->assume,
4629 merge: gfc_current_ns->omp_assumes, loc: &loc)
4630 != MATCH_YES))
4631 return MATCH_ERROR;
4632 if (gfc_current_ns->omp_assumes == NULL)
4633 {
4634 gfc_current_ns->omp_assumes = c->assume;
4635 c->assume = NULL;
4636 }
4637 else if (gfc_current_ns->omp_assumes && c->assume)
4638 {
4639 gfc_current_ns->omp_assumes->no_openmp |= c->assume->no_openmp;
4640 gfc_current_ns->omp_assumes->no_openmp_routines
4641 |= c->assume->no_openmp_routines;
4642 gfc_current_ns->omp_assumes->no_parallelism |= c->assume->no_parallelism;
4643 if (gfc_current_ns->omp_assumes->holds && c->assume->holds)
4644 {
4645 gfc_expr_list *el = gfc_current_ns->omp_assumes->holds;
4646 for ( ; el->next ; el = el->next)
4647 ;
4648 el->next = c->assume->holds;
4649 }
4650 else if (c->assume->holds)
4651 gfc_current_ns->omp_assumes->holds = c->assume->holds;
4652 c->assume->holds = NULL;
4653 }
4654 gfc_free_omp_clauses (c);
4655 return MATCH_YES;
4656}
4657
4658
4659match
4660gfc_match_omp_critical (void)
4661{
4662 char n[GFC_MAX_SYMBOL_LEN+1];
4663 gfc_omp_clauses *c = NULL;
4664
4665 if (gfc_match (" ( %n )", n) != MATCH_YES)
4666 n[0] = '\0';
4667
4668 if (gfc_match_omp_clauses (cp: &c, mask: omp_mask (OMP_CLAUSE_HINT),
4669 /* first = */ n[0] == '\0') != MATCH_YES)
4670 return MATCH_ERROR;
4671
4672 new_st.op = EXEC_OMP_CRITICAL;
4673 new_st.ext.omp_clauses = c;
4674 if (n[0])
4675 c->critical_name = xstrdup (n);
4676 return MATCH_YES;
4677}
4678
4679
4680match
4681gfc_match_omp_end_critical (void)
4682{
4683 char n[GFC_MAX_SYMBOL_LEN+1];
4684
4685 if (gfc_match (" ( %n )", n) != MATCH_YES)
4686 n[0] = '\0';
4687 if (gfc_match_omp_eos () != MATCH_YES)
4688 {
4689 gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
4690 return MATCH_ERROR;
4691 }
4692
4693 new_st.op = EXEC_OMP_END_CRITICAL;
4694 new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
4695 return MATCH_YES;
4696}
4697
4698/* depobj(depobj) depend(dep-type:loc)|destroy|update(dep-type)
4699 dep-type = in/out/inout/mutexinoutset/depobj/source/sink
4700 depend: !source, !sink
4701 update: !source, !sink, !depobj
4702 locator = exactly one list item .*/
4703match
4704gfc_match_omp_depobj (void)
4705{
4706 gfc_omp_clauses *c = NULL;
4707 gfc_expr *depobj;
4708
4709 if (gfc_match (" ( %v ) ", &depobj) != MATCH_YES)
4710 {
4711 gfc_error ("Expected %<( depobj )%> at %C");
4712 return MATCH_ERROR;
4713 }
4714 if (gfc_match ("update ( ") == MATCH_YES)
4715 {
4716 c = gfc_get_omp_clauses ();
4717 if (gfc_match ("inoutset )") == MATCH_YES)
4718 c->depobj_update = OMP_DEPEND_INOUTSET;
4719 else if (gfc_match ("inout )") == MATCH_YES)
4720 c->depobj_update = OMP_DEPEND_INOUT;
4721 else if (gfc_match ("in )") == MATCH_YES)
4722 c->depobj_update = OMP_DEPEND_IN;
4723 else if (gfc_match ("out )") == MATCH_YES)
4724 c->depobj_update = OMP_DEPEND_OUT;
4725 else if (gfc_match ("mutexinoutset )") == MATCH_YES)
4726 c->depobj_update = OMP_DEPEND_MUTEXINOUTSET;
4727 else
4728 {
4729 gfc_error ("Expected IN, OUT, INOUT, INOUTSET or MUTEXINOUTSET "
4730 "followed by %<)%> at %C");
4731 goto error;
4732 }
4733 }
4734 else if (gfc_match ("destroy") == MATCH_YES)
4735 {
4736 c = gfc_get_omp_clauses ();
4737 c->destroy = true;
4738 }
4739 else if (gfc_match_omp_clauses (cp: &c, mask: omp_mask (OMP_CLAUSE_DEPEND), first: true, needs_space: false)
4740 != MATCH_YES)
4741 goto error;
4742
4743 if (c->depobj_update == OMP_DEPEND_UNSET && !c->destroy)
4744 {
4745 if (!c->doacross_source && !c->lists[OMP_LIST_DEPEND])
4746 {
4747 gfc_error ("Expected DEPEND, UPDATE, or DESTROY clause at %C");
4748 goto error;
4749 }
4750 if (c->lists[OMP_LIST_DEPEND]->u.depend_doacross_op == OMP_DEPEND_DEPOBJ)
4751 {
4752 gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall not "
4753 "have dependence-type DEPOBJ",
4754 c->lists[OMP_LIST_DEPEND]
4755 ? &c->lists[OMP_LIST_DEPEND]->where : &gfc_current_locus);
4756 goto error;
4757 }
4758 if (c->lists[OMP_LIST_DEPEND]->next)
4759 {
4760 gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall have "
4761 "only a single locator",
4762 &c->lists[OMP_LIST_DEPEND]->next->where);
4763 goto error;
4764 }
4765 }
4766
4767 c->depobj = depobj;
4768 new_st.op = EXEC_OMP_DEPOBJ;
4769 new_st.ext.omp_clauses = c;
4770 return MATCH_YES;
4771
4772error:
4773 gfc_free_expr (depobj);
4774 gfc_free_omp_clauses (c);
4775 return MATCH_ERROR;
4776}
4777
4778match
4779gfc_match_omp_distribute (void)
4780{
4781 return match_omp (op: EXEC_OMP_DISTRIBUTE, OMP_DISTRIBUTE_CLAUSES);
4782}
4783
4784
4785match
4786gfc_match_omp_distribute_parallel_do (void)
4787{
4788 return match_omp (op: EXEC_OMP_DISTRIBUTE_PARALLEL_DO,
4789 mask: (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
4790 | OMP_DO_CLAUSES)
4791 & ~(omp_mask (OMP_CLAUSE_ORDERED)
4792 | OMP_CLAUSE_LINEAR | OMP_CLAUSE_NOWAIT));
4793}
4794
4795
4796match
4797gfc_match_omp_distribute_parallel_do_simd (void)
4798{
4799 return match_omp (op: EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD,
4800 mask: (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
4801 | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
4802 & ~(omp_mask (OMP_CLAUSE_ORDERED) | OMP_CLAUSE_NOWAIT));
4803}
4804
4805
4806match
4807gfc_match_omp_distribute_simd (void)
4808{
4809 return match_omp (op: EXEC_OMP_DISTRIBUTE_SIMD,
4810 OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
4811}
4812
4813
4814match
4815gfc_match_omp_do (void)
4816{
4817 return match_omp (op: EXEC_OMP_DO, OMP_DO_CLAUSES);
4818}
4819
4820
4821match
4822gfc_match_omp_do_simd (void)
4823{
4824 return match_omp (op: EXEC_OMP_DO_SIMD, OMP_DO_CLAUSES | OMP_SIMD_CLAUSES);
4825}
4826
4827
4828match
4829gfc_match_omp_loop (void)
4830{
4831 return match_omp (op: EXEC_OMP_LOOP, OMP_LOOP_CLAUSES);
4832}
4833
4834
4835match
4836gfc_match_omp_teams_loop (void)
4837{
4838 return match_omp (op: EXEC_OMP_TEAMS_LOOP, OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES);
4839}
4840
4841
4842match
4843gfc_match_omp_target_teams_loop (void)
4844{
4845 return match_omp (op: EXEC_OMP_TARGET_TEAMS_LOOP,
4846 OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES);
4847}
4848
4849
4850match
4851gfc_match_omp_parallel_loop (void)
4852{
4853 return match_omp (op: EXEC_OMP_PARALLEL_LOOP,
4854 OMP_PARALLEL_CLAUSES | OMP_LOOP_CLAUSES);
4855}
4856
4857
4858match
4859gfc_match_omp_target_parallel_loop (void)
4860{
4861 return match_omp (op: EXEC_OMP_TARGET_PARALLEL_LOOP,
4862 mask: (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES
4863 | OMP_LOOP_CLAUSES));
4864}
4865
4866
4867match
4868gfc_match_omp_error (void)
4869{
4870 locus loc = gfc_current_locus;
4871 match m = match_omp (op: EXEC_OMP_ERROR, OMP_ERROR_CLAUSES);
4872 if (m != MATCH_YES)
4873 return m;
4874
4875 gfc_omp_clauses *c = new_st.ext.omp_clauses;
4876 if (c->severity == OMP_SEVERITY_UNSET)
4877 c->severity = OMP_SEVERITY_FATAL;
4878 if (new_st.ext.omp_clauses->at == OMP_AT_EXECUTION)
4879 return MATCH_YES;
4880 if (c->message
4881 && (!gfc_resolve_expr (c->message)
4882 || c->message->ts.type != BT_CHARACTER
4883 || c->message->ts.kind != gfc_default_character_kind
4884 || c->message->rank != 0))
4885 {
4886 gfc_error ("MESSAGE clause at %L requires a scalar default-kind "
4887 "CHARACTER expression",
4888 &new_st.ext.omp_clauses->message->where);
4889 return MATCH_ERROR;
4890 }
4891 if (c->message && !gfc_is_constant_expr (c->message))
4892 {
4893 gfc_error ("Constant character expression required in MESSAGE clause "
4894 "at %L", &new_st.ext.omp_clauses->message->where);
4895 return MATCH_ERROR;
4896 }
4897 if (c->message)
4898 {
4899 const char *msg = G_("$OMP ERROR encountered at %L: %s");
4900 gcc_assert (c->message->expr_type == EXPR_CONSTANT);
4901 gfc_charlen_t slen = c->message->value.character.length;
4902 int i = gfc_validate_kind (BT_CHARACTER, gfc_default_character_kind,
4903 false);
4904 size_t size = slen * gfc_character_kinds[i].bit_size / 8;
4905 unsigned char *s = XCNEWVAR (unsigned char, size + 1);
4906 gfc_encode_character (gfc_default_character_kind, slen,
4907 c->message->value.character.string,
4908 (unsigned char *) s, size);
4909 s[size] = '\0';
4910 if (c->severity == OMP_SEVERITY_WARNING)
4911 gfc_warning_now (opt: 0, msg, &loc, s);
4912 else
4913 gfc_error_now (msg, &loc, s);
4914 free (ptr: s);
4915 }
4916 else
4917 {
4918 const char *msg = G_("$OMP ERROR encountered at %L");
4919 if (c->severity == OMP_SEVERITY_WARNING)
4920 gfc_warning_now (opt: 0, msg, &loc);
4921 else
4922 gfc_error_now (msg, &loc);
4923 }
4924 return MATCH_YES;
4925}
4926
4927match
4928gfc_match_omp_flush (void)
4929{
4930 gfc_omp_namelist *list = NULL;
4931 gfc_omp_clauses *c = NULL;
4932 gfc_gobble_whitespace ();
4933 enum gfc_omp_memorder mo = OMP_MEMORDER_UNSET;
4934 if (gfc_match_omp_eos () == MATCH_NO && gfc_peek_ascii_char () != '(')
4935 {
4936 if (gfc_match ("seq_cst") == MATCH_YES)
4937 mo = OMP_MEMORDER_SEQ_CST;
4938 else if (gfc_match ("acq_rel") == MATCH_YES)
4939 mo = OMP_MEMORDER_ACQ_REL;
4940 else if (gfc_match ("release") == MATCH_YES)
4941 mo = OMP_MEMORDER_RELEASE;
4942 else if (gfc_match ("acquire") == MATCH_YES)
4943 mo = OMP_MEMORDER_ACQUIRE;
4944 else
4945 {
4946 gfc_error ("Expected SEQ_CST, AQC_REL, RELEASE, or ACQUIRE at %C");
4947 return MATCH_ERROR;
4948 }
4949 c = gfc_get_omp_clauses ();
4950 c->memorder = mo;
4951 }
4952 gfc_match_omp_variable_list (str: " (", list: &list, allow_common: true);
4953 if (list && mo != OMP_MEMORDER_UNSET)
4954 {
4955 gfc_error ("List specified together with memory order clause in FLUSH "
4956 "directive at %C");
4957 gfc_free_omp_namelist (list, false, false, false);
4958 gfc_free_omp_clauses (c);
4959 return MATCH_ERROR;
4960 }
4961 if (gfc_match_omp_eos () != MATCH_YES)
4962 {
4963 gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
4964 gfc_free_omp_namelist (list, false, false, false);
4965 gfc_free_omp_clauses (c);
4966 return MATCH_ERROR;
4967 }
4968 new_st.op = EXEC_OMP_FLUSH;
4969 new_st.ext.omp_namelist = list;
4970 new_st.ext.omp_clauses = c;
4971 return MATCH_YES;
4972}
4973
4974
4975match
4976gfc_match_omp_declare_simd (void)
4977{
4978 locus where = gfc_current_locus;
4979 gfc_symbol *proc_name;
4980 gfc_omp_clauses *c;
4981 gfc_omp_declare_simd *ods;
4982 bool needs_space = false;
4983
4984 switch (gfc_match (" ( "))
4985 {
4986 case MATCH_YES:
4987 if (gfc_match_symbol (&proc_name, /* host assoc = */ true) != MATCH_YES
4988 || gfc_match (" ) ") != MATCH_YES)
4989 return MATCH_ERROR;
4990 break;
4991 case MATCH_NO: proc_name = NULL; needs_space = true; break;
4992 case MATCH_ERROR: return MATCH_ERROR;
4993 }
4994
4995 if (gfc_match_omp_clauses (cp: &c, OMP_DECLARE_SIMD_CLAUSES, first: true,
4996 needs_space) != MATCH_YES)
4997 return MATCH_ERROR;
4998
4999 if (gfc_current_ns->is_block_data)
5000 {
5001 gfc_free_omp_clauses (c);
5002 return MATCH_YES;
5003 }
5004
5005 ods = gfc_get_omp_declare_simd ();
5006 ods->where = where;
5007 ods->proc_name = proc_name;
5008 ods->clauses = c;
5009 ods->next = gfc_current_ns->omp_declare_simd;
5010 gfc_current_ns->omp_declare_simd = ods;
5011 return MATCH_YES;
5012}
5013
5014
5015static bool
5016match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2)
5017{
5018 match m;
5019 locus old_loc = gfc_current_locus;
5020 char sname[GFC_MAX_SYMBOL_LEN + 1];
5021 gfc_symbol *sym;
5022 gfc_namespace *ns = gfc_current_ns;
5023 gfc_expr *lvalue = NULL, *rvalue = NULL;
5024 gfc_symtree *st;
5025 gfc_actual_arglist *arglist;
5026
5027 m = gfc_match (" %v =", &lvalue);
5028 if (m != MATCH_YES)
5029 gfc_current_locus = old_loc;
5030 else
5031 {
5032 m = gfc_match (" %e )", &rvalue);
5033 if (m == MATCH_YES)
5034 {
5035 ns->code = gfc_get_code (EXEC_ASSIGN);
5036 ns->code->expr1 = lvalue;
5037 ns->code->expr2 = rvalue;
5038 ns->code->loc = old_loc;
5039 return true;
5040 }
5041
5042 gfc_current_locus = old_loc;
5043 gfc_free_expr (lvalue);
5044 }
5045
5046 m = gfc_match (" %n", sname);
5047 if (m != MATCH_YES)
5048 return false;
5049
5050 if (strcmp (s1: sname, s2: omp_sym1->name) == 0
5051 || strcmp (s1: sname, s2: omp_sym2->name) == 0)
5052 return false;
5053
5054 gfc_current_ns = ns->parent;
5055 if (gfc_get_ha_sym_tree (sname, &st))
5056 return false;
5057
5058 sym = st->n.sym;
5059 if (sym->attr.flavor != FL_PROCEDURE
5060 && sym->attr.flavor != FL_UNKNOWN)
5061 return false;
5062
5063 if (!sym->attr.generic
5064 && !sym->attr.subroutine
5065 && !sym->attr.function)
5066 {
5067 if (!(sym->attr.external && !sym->attr.referenced))
5068 {
5069 /* ...create a symbol in this scope... */
5070 if (sym->ns != gfc_current_ns
5071 && gfc_get_sym_tree (sname, NULL, &st, false) == 1)
5072 return false;
5073
5074 if (sym != st->n.sym)
5075 sym = st->n.sym;
5076 }
5077
5078 /* ...and then to try to make the symbol into a subroutine. */
5079 if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
5080 return false;
5081 }
5082
5083 gfc_set_sym_referenced (sym);
5084 gfc_gobble_whitespace ();
5085 if (gfc_peek_ascii_char () != '(')
5086 return false;
5087
5088 gfc_current_ns = ns;
5089 m = gfc_match_actual_arglist (1, &arglist);
5090 if (m != MATCH_YES)
5091 return false;
5092
5093 if (gfc_match_char (')') != MATCH_YES)
5094 return false;
5095
5096 ns->code = gfc_get_code (EXEC_CALL);
5097 ns->code->symtree = st;
5098 ns->code->ext.actual = arglist;
5099 ns->code->loc = old_loc;
5100 return true;
5101}
5102
5103static bool
5104gfc_omp_udr_predef (gfc_omp_reduction_op rop, const char *name,
5105 gfc_typespec *ts, const char **n)
5106{
5107 if (!gfc_numeric_ts (ts) && ts->type != BT_LOGICAL)
5108 return false;
5109
5110 switch (rop)
5111 {
5112 case OMP_REDUCTION_PLUS:
5113 case OMP_REDUCTION_MINUS:
5114 case OMP_REDUCTION_TIMES:
5115 return ts->type != BT_LOGICAL;
5116 case OMP_REDUCTION_AND:
5117 case OMP_REDUCTION_OR:
5118 case OMP_REDUCTION_EQV:
5119 case OMP_REDUCTION_NEQV:
5120 return ts->type == BT_LOGICAL;
5121 case OMP_REDUCTION_USER:
5122 if (name[0] != '.' && (ts->type == BT_INTEGER || ts->type == BT_REAL))
5123 {
5124 gfc_symbol *sym;
5125
5126 gfc_find_symbol (name, NULL, 1, &sym);
5127 if (sym != NULL)
5128 {
5129 if (sym->attr.intrinsic)
5130 *n = sym->name;
5131 else if ((sym->attr.flavor != FL_UNKNOWN
5132 && sym->attr.flavor != FL_PROCEDURE)
5133 || sym->attr.external
5134 || sym->attr.generic
5135 || sym->attr.entry
5136 || sym->attr.result
5137 || sym->attr.dummy
5138 || sym->attr.subroutine
5139 || sym->attr.pointer
5140 || sym->attr.target
5141 || sym->attr.cray_pointer
5142 || sym->attr.cray_pointee
5143 || (sym->attr.proc != PROC_UNKNOWN
5144 && sym->attr.proc != PROC_INTRINSIC)
5145 || sym->attr.if_source != IFSRC_UNKNOWN
5146 || sym == sym->ns->proc_name)
5147 *n = NULL;
5148 else
5149 *n = sym->name;
5150 }
5151 else
5152 *n = name;
5153 if (*n
5154 && (strcmp (s1: *n, s2: "max") == 0 || strcmp (s1: *n, s2: "min") == 0))
5155 return true;
5156 else if (*n
5157 && ts->type == BT_INTEGER
5158 && (strcmp (s1: *n, s2: "iand") == 0
5159 || strcmp (s1: *n, s2: "ior") == 0
5160 || strcmp (s1: *n, s2: "ieor") == 0))
5161 return true;
5162 }
5163 break;
5164 default:
5165 break;
5166 }
5167 return false;
5168}
5169
5170gfc_omp_udr *
5171gfc_omp_udr_find (gfc_symtree *st, gfc_typespec *ts)
5172{
5173 gfc_omp_udr *omp_udr;
5174
5175 if (st == NULL)
5176 return NULL;
5177
5178 for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
5179 if (omp_udr->ts.type == ts->type
5180 || ((omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
5181 && (ts->type == BT_DERIVED || ts->type == BT_CLASS)))
5182 {
5183 if (omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
5184 {
5185 if (strcmp (s1: omp_udr->ts.u.derived->name, s2: ts->u.derived->name) == 0)
5186 return omp_udr;
5187 }
5188 else if (omp_udr->ts.kind == ts->kind)
5189 {
5190 if (omp_udr->ts.type == BT_CHARACTER)
5191 {
5192 if (omp_udr->ts.u.cl->length == NULL
5193 || ts->u.cl->length == NULL)
5194 return omp_udr;
5195 if (omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5196 return omp_udr;
5197 if (ts->u.cl->length->expr_type != EXPR_CONSTANT)
5198 return omp_udr;
5199 if (omp_udr->ts.u.cl->length->ts.type != BT_INTEGER)
5200 return omp_udr;
5201 if (ts->u.cl->length->ts.type != BT_INTEGER)
5202 return omp_udr;
5203 if (gfc_compare_expr (omp_udr->ts.u.cl->length,
5204 ts->u.cl->length, INTRINSIC_EQ) != 0)
5205 continue;
5206 }
5207 return omp_udr;
5208 }
5209 }
5210 return NULL;
5211}
5212
5213match
5214gfc_match_omp_declare_reduction (void)
5215{
5216 match m;
5217 gfc_intrinsic_op op;
5218 char name[GFC_MAX_SYMBOL_LEN + 3];
5219 auto_vec<gfc_typespec, 5> tss;
5220 gfc_typespec ts;
5221 unsigned int i;
5222 gfc_symtree *st;
5223 locus where = gfc_current_locus;
5224 locus end_loc = gfc_current_locus;
5225 bool end_loc_set = false;
5226 gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
5227
5228 if (gfc_match_char ('(') != MATCH_YES)
5229 return MATCH_ERROR;
5230
5231 m = gfc_match (" %o : ", &op);
5232 if (m == MATCH_ERROR)
5233 return MATCH_ERROR;
5234 if (m == MATCH_YES)
5235 {
5236 snprintf (s: name, maxlen: sizeof name, format: "operator %s", gfc_op2string (op));
5237 rop = (gfc_omp_reduction_op) op;
5238 }
5239 else
5240 {
5241 m = gfc_match_defined_op_name (name + 1, 1);
5242 if (m == MATCH_ERROR)
5243 return MATCH_ERROR;
5244 if (m == MATCH_YES)
5245 {
5246 name[0] = '.';
5247 strcat (dest: name, src: ".");
5248 if (gfc_match (" : ") != MATCH_YES)
5249 return MATCH_ERROR;
5250 }
5251 else
5252 {
5253 if (gfc_match (" %n : ", name) != MATCH_YES)
5254 return MATCH_ERROR;
5255 }
5256 rop = OMP_REDUCTION_USER;
5257 }
5258
5259 m = gfc_match_type_spec (&ts);
5260 if (m != MATCH_YES)
5261 return MATCH_ERROR;
5262 /* Treat len=: the same as len=*. */
5263 if (ts.type == BT_CHARACTER)
5264 ts.deferred = false;
5265 tss.safe_push (obj: ts);
5266
5267 while (gfc_match_char (',') == MATCH_YES)
5268 {
5269 m = gfc_match_type_spec (&ts);
5270 if (m != MATCH_YES)
5271 return MATCH_ERROR;
5272 tss.safe_push (obj: ts);
5273 }
5274 if (gfc_match_char (':') != MATCH_YES)
5275 return MATCH_ERROR;
5276
5277 st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
5278 for (i = 0; i < tss.length (); i++)
5279 {
5280 gfc_symtree *omp_out, *omp_in;
5281 gfc_symtree *omp_priv = NULL, *omp_orig = NULL;
5282 gfc_namespace *combiner_ns, *initializer_ns = NULL;
5283 gfc_omp_udr *prev_udr, *omp_udr;
5284 const char *predef_name = NULL;
5285
5286 omp_udr = gfc_get_omp_udr ();
5287 omp_udr->name = gfc_get_string ("%s", name);
5288 omp_udr->rop = rop;
5289 omp_udr->ts = tss[i];
5290 omp_udr->where = where;
5291
5292 gfc_current_ns = combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
5293 combiner_ns->proc_name = combiner_ns->parent->proc_name;
5294
5295 gfc_get_sym_tree ("omp_out", combiner_ns, &omp_out, false);
5296 gfc_get_sym_tree ("omp_in", combiner_ns, &omp_in, false);
5297 combiner_ns->omp_udr_ns = 1;
5298 omp_out->n.sym->ts = tss[i];
5299 omp_in->n.sym->ts = tss[i];
5300 omp_out->n.sym->attr.omp_udr_artificial_var = 1;
5301 omp_in->n.sym->attr.omp_udr_artificial_var = 1;
5302 omp_out->n.sym->attr.flavor = FL_VARIABLE;
5303 omp_in->n.sym->attr.flavor = FL_VARIABLE;
5304 gfc_commit_symbols ();
5305 omp_udr->combiner_ns = combiner_ns;
5306 omp_udr->omp_out = omp_out->n.sym;
5307 omp_udr->omp_in = omp_in->n.sym;
5308
5309 locus old_loc = gfc_current_locus;
5310
5311 if (!match_udr_expr (omp_sym1: omp_out, omp_sym2: omp_in))
5312 {
5313 syntax:
5314 gfc_current_locus = old_loc;
5315 gfc_current_ns = combiner_ns->parent;
5316 gfc_undo_symbols ();
5317 gfc_free_omp_udr (omp_udr);
5318 return MATCH_ERROR;
5319 }
5320
5321 if (gfc_match (" initializer ( ") == MATCH_YES)
5322 {
5323 gfc_current_ns = combiner_ns->parent;
5324 initializer_ns = gfc_get_namespace (gfc_current_ns, 1);
5325 gfc_current_ns = initializer_ns;
5326 initializer_ns->proc_name = initializer_ns->parent->proc_name;
5327
5328 gfc_get_sym_tree ("omp_priv", initializer_ns, &omp_priv, false);
5329 gfc_get_sym_tree ("omp_orig", initializer_ns, &omp_orig, false);
5330 initializer_ns->omp_udr_ns = 1;
5331 omp_priv->n.sym->ts = tss[i];
5332 omp_orig->n.sym->ts = tss[i];
5333 omp_priv->n.sym->attr.omp_udr_artificial_var = 1;
5334 omp_orig->n.sym->attr.omp_udr_artificial_var = 1;
5335 omp_priv->n.sym->attr.flavor = FL_VARIABLE;
5336 omp_orig->n.sym->attr.flavor = FL_VARIABLE;
5337 gfc_commit_symbols ();
5338 omp_udr->initializer_ns = initializer_ns;
5339 omp_udr->omp_priv = omp_priv->n.sym;
5340 omp_udr->omp_orig = omp_orig->n.sym;
5341
5342 if (!match_udr_expr (omp_sym1: omp_priv, omp_sym2: omp_orig))
5343 goto syntax;
5344 }
5345
5346 gfc_current_ns = combiner_ns->parent;
5347 if (!end_loc_set)
5348 {
5349 end_loc_set = true;
5350 end_loc = gfc_current_locus;
5351 }
5352 gfc_current_locus = old_loc;
5353
5354 prev_udr = gfc_omp_udr_find (st, ts: &tss[i]);
5355 if (gfc_omp_udr_predef (rop, name, ts: &tss[i], n: &predef_name)
5356 /* Don't error on !$omp declare reduction (min : integer : ...)
5357 just yet, there could be integer :: min afterwards,
5358 making it valid. When the UDR is resolved, we'll get
5359 to it again. */
5360 && (rop != OMP_REDUCTION_USER || name[0] == '.'))
5361 {
5362 if (predef_name)
5363 gfc_error_now ("Redefinition of predefined %s "
5364 "!$OMP DECLARE REDUCTION at %L",
5365 predef_name, &where);
5366 else
5367 gfc_error_now ("Redefinition of predefined "
5368 "!$OMP DECLARE REDUCTION at %L", &where);
5369 }
5370 else if (prev_udr)
5371 {
5372 gfc_error_now ("Redefinition of !$OMP DECLARE REDUCTION at %L",
5373 &where);
5374 gfc_error_now ("Previous !$OMP DECLARE REDUCTION at %L",
5375 &prev_udr->where);
5376 }
5377 else if (st)
5378 {
5379 omp_udr->next = st->n.omp_udr;
5380 st->n.omp_udr = omp_udr;
5381 }
5382 else
5383 {
5384 st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name);
5385 st->n.omp_udr = omp_udr;
5386 }
5387 }
5388
5389 if (end_loc_set)
5390 {
5391 gfc_current_locus = end_loc;
5392 if (gfc_match_omp_eos () != MATCH_YES)
5393 {
5394 gfc_error ("Unexpected junk after !$OMP DECLARE REDUCTION at %C");
5395 gfc_current_locus = where;
5396 return MATCH_ERROR;
5397 }
5398
5399 return MATCH_YES;
5400 }
5401 gfc_clear_error ();
5402 return MATCH_ERROR;
5403}
5404
5405
5406match
5407gfc_match_omp_declare_target (void)
5408{
5409 locus old_loc;
5410 match m;
5411 gfc_omp_clauses *c = NULL;
5412 int list;
5413 gfc_omp_namelist *n;
5414 gfc_symbol *s;
5415
5416 old_loc = gfc_current_locus;
5417
5418 if (gfc_current_ns->proc_name
5419 && gfc_match_omp_eos () == MATCH_YES)
5420 {
5421 if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
5422 gfc_current_ns->proc_name->name,
5423 &old_loc))
5424 goto cleanup;
5425 return MATCH_YES;
5426 }
5427
5428 if (gfc_current_ns->proc_name
5429 && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY)
5430 {
5431 gfc_error ("Only the !$OMP DECLARE TARGET form without "
5432 "clauses is allowed in interface block at %C");
5433 goto cleanup;
5434 }
5435
5436 m = gfc_match (" (");
5437 if (m == MATCH_YES)
5438 {
5439 c = gfc_get_omp_clauses ();
5440 gfc_current_locus = old_loc;
5441 m = gfc_match_omp_to_link (str: " (", list: &c->lists[OMP_LIST_ENTER]);
5442 if (m != MATCH_YES)
5443 goto syntax;
5444 if (gfc_match_omp_eos () != MATCH_YES)
5445 {
5446 gfc_error ("Unexpected junk after !$OMP DECLARE TARGET at %C");
5447 goto cleanup;
5448 }
5449 }
5450 else if (gfc_match_omp_clauses (cp: &c, OMP_DECLARE_TARGET_CLAUSES) != MATCH_YES)
5451 return MATCH_ERROR;
5452
5453 gfc_buffer_error (false);
5454
5455 static const int to_enter_link_lists[]
5456 = { OMP_LIST_TO, OMP_LIST_ENTER, OMP_LIST_LINK };
5457 for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists)
5458 && (list = to_enter_link_lists[listn], true); ++listn)
5459 for (n = c->lists[list]; n; n = n->next)
5460 if (n->sym)
5461 n->sym->mark = 0;
5462 else if (n->u.common->head)
5463 n->u.common->head->mark = 0;
5464
5465 for (size_t listn = 0; listn < ARRAY_SIZE (to_enter_link_lists)
5466 && (list = to_enter_link_lists[listn], true); ++listn)
5467 for (n = c->lists[list]; n; n = n->next)
5468 if (n->sym)
5469 {
5470 if (n->sym->attr.in_common)
5471 gfc_error_now ("OMP DECLARE TARGET variable at %L is an "
5472 "element of a COMMON block", &n->where);
5473 else if (n->sym->mark)
5474 gfc_error_now ("Variable at %L mentioned multiple times in "
5475 "clauses of the same OMP DECLARE TARGET directive",
5476 &n->where);
5477 else if (n->sym->attr.omp_declare_target
5478 && n->sym->attr.omp_declare_target_link
5479 && list != OMP_LIST_LINK)
5480 gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
5481 "mentioned in LINK clause and later in %s clause",
5482 &n->where, list == OMP_LIST_TO ? "TO" : "ENTER");
5483 else if (n->sym->attr.omp_declare_target
5484 && !n->sym->attr.omp_declare_target_link
5485 && list == OMP_LIST_LINK)
5486 gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
5487 "mentioned in TO or ENTER clause and later in "
5488 "LINK clause", &n->where);
5489 else if (gfc_add_omp_declare_target (&n->sym->attr, n->sym->name,
5490 &n->sym->declared_at))
5491 {
5492 if (list == OMP_LIST_LINK)
5493 gfc_add_omp_declare_target_link (&n->sym->attr, n->sym->name,
5494 &n->sym->declared_at);
5495 }
5496 if (c->device_type != OMP_DEVICE_TYPE_UNSET)
5497 {
5498 if (n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
5499 && n->sym->attr.omp_device_type != c->device_type)
5500 gfc_error_now ("List item %qs at %L set in previous OMP DECLARE "
5501 "TARGET directive to a different DEVICE_TYPE",
5502 n->sym->name, &n->where);
5503 n->sym->attr.omp_device_type = c->device_type;
5504 }
5505 n->sym->mark = 1;
5506 }
5507 else if (n->u.common->omp_declare_target
5508 && n->u.common->omp_declare_target_link
5509 && list != OMP_LIST_LINK)
5510 gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously "
5511 "mentioned in LINK clause and later in %s clause",
5512 &n->where, list == OMP_LIST_TO ? "TO" : "ENTER");
5513 else if (n->u.common->omp_declare_target
5514 && !n->u.common->omp_declare_target_link
5515 && list == OMP_LIST_LINK)
5516 gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously "
5517 "mentioned in TO or ENTER clause and later in "
5518 "LINK clause", &n->where);
5519 else if (n->u.common->head && n->u.common->head->mark)
5520 gfc_error_now ("COMMON at %L mentioned multiple times in "
5521 "clauses of the same OMP DECLARE TARGET directive",
5522 &n->where);
5523 else
5524 {
5525 n->u.common->omp_declare_target = 1;
5526 n->u.common->omp_declare_target_link = (list == OMP_LIST_LINK);
5527 if (n->u.common->omp_device_type != OMP_DEVICE_TYPE_UNSET
5528 && n->u.common->omp_device_type != c->device_type)
5529 gfc_error_now ("COMMON at %L set in previous OMP DECLARE "
5530 "TARGET directive to a different DEVICE_TYPE",
5531 &n->where);
5532 n->u.common->omp_device_type = c->device_type;
5533
5534 for (s = n->u.common->head; s; s = s->common_next)
5535 {
5536 s->mark = 1;
5537 if (gfc_add_omp_declare_target (&s->attr, s->name,
5538 &s->declared_at))
5539 {
5540 if (list == OMP_LIST_LINK)
5541 gfc_add_omp_declare_target_link (&s->attr, s->name,
5542 &s->declared_at);
5543 }
5544 if (s->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
5545 && s->attr.omp_device_type != c->device_type)
5546 gfc_error_now ("List item %qs at %L set in previous OMP DECLARE"
5547 " TARGET directive to a different DEVICE_TYPE",
5548 s->name, &n->where);
5549 s->attr.omp_device_type = c->device_type;
5550 }
5551 }
5552 if (c->device_type
5553 && !c->lists[OMP_LIST_ENTER]
5554 && !c->lists[OMP_LIST_TO]
5555 && !c->lists[OMP_LIST_LINK])
5556 gfc_warning_now (opt: 0, "OMP DECLARE TARGET directive at %L with only "
5557 "DEVICE_TYPE clause is ignored", &old_loc);
5558
5559 gfc_buffer_error (true);
5560
5561 if (c)
5562 gfc_free_omp_clauses (c);
5563 return MATCH_YES;
5564
5565syntax:
5566 gfc_error ("Syntax error in !$OMP DECLARE TARGET list at %C");
5567
5568cleanup:
5569 gfc_current_locus = old_loc;
5570 if (c)
5571 gfc_free_omp_clauses (c);
5572 return MATCH_ERROR;
5573}
5574
5575
5576static const char *const omp_construct_selectors[] = {
5577 "simd", "target", "teams", "parallel", "do", NULL };
5578static const char *const omp_device_selectors[] = {
5579 "kind", "isa", "arch", NULL };
5580static const char *const omp_implementation_selectors[] = {
5581 "vendor", "extension", "atomic_default_mem_order", "unified_address",
5582 "unified_shared_memory", "dynamic_allocators", "reverse_offload", NULL };
5583static const char *const omp_user_selectors[] = {
5584 "condition", NULL };
5585
5586
5587/* OpenMP 5.0:
5588
5589 trait-selector:
5590 trait-selector-name[([trait-score:]trait-property[,trait-property[,...]])]
5591
5592 trait-score:
5593 score(score-expression) */
5594
5595match
5596gfc_match_omp_context_selector (gfc_omp_set_selector *oss)
5597{
5598 do
5599 {
5600 char selector[GFC_MAX_SYMBOL_LEN + 1];
5601
5602 if (gfc_match_name (selector) != MATCH_YES)
5603 {
5604 gfc_error ("expected trait selector name at %C");
5605 return MATCH_ERROR;
5606 }
5607
5608 gfc_omp_selector *os = gfc_get_omp_selector ();
5609 os->trait_selector_name = XNEWVEC (char, strlen (selector) + 1);
5610 strcpy (dest: os->trait_selector_name, src: selector);
5611 os->next = oss->trait_selectors;
5612 oss->trait_selectors = os;
5613
5614 const char *const *selectors = NULL;
5615 bool allow_score = true;
5616 bool allow_user = false;
5617 int property_limit = 0;
5618 enum gfc_omp_trait_property_kind property_kind = CTX_PROPERTY_NONE;
5619 switch (oss->trait_set_selector_name[0])
5620 {
5621 case 'c': /* construct */
5622 selectors = omp_construct_selectors;
5623 allow_score = false;
5624 property_limit = 1;
5625 property_kind = CTX_PROPERTY_SIMD;
5626 break;
5627 case 'd': /* device */
5628 selectors = omp_device_selectors;
5629 allow_score = false;
5630 allow_user = true;
5631 property_limit = 3;
5632 property_kind = CTX_PROPERTY_NAME_LIST;
5633 break;
5634 case 'i': /* implementation */
5635 selectors = omp_implementation_selectors;
5636 allow_user = true;
5637 property_limit = 3;
5638 property_kind = CTX_PROPERTY_NAME_LIST;
5639 break;
5640 case 'u': /* user */
5641 selectors = omp_user_selectors;
5642 property_limit = 1;
5643 property_kind = CTX_PROPERTY_EXPR;
5644 break;
5645 default:
5646 gcc_unreachable ();
5647 }
5648 for (int i = 0; ; i++)
5649 {
5650 if (selectors[i] == NULL)
5651 {
5652 if (allow_user)
5653 {
5654 property_kind = CTX_PROPERTY_USER;
5655 break;
5656 }
5657 else
5658 {
5659 gfc_error ("selector %qs not allowed for context selector "
5660 "set %qs at %C",
5661 selector, oss->trait_set_selector_name);
5662 return MATCH_ERROR;
5663 }
5664 }
5665 if (i == property_limit)
5666 property_kind = CTX_PROPERTY_NONE;
5667 if (strcmp (s1: selectors[i], s2: selector) == 0)
5668 break;
5669 }
5670 if (property_kind == CTX_PROPERTY_NAME_LIST
5671 && oss->trait_set_selector_name[0] == 'i'
5672 && strcmp (s1: selector, s2: "atomic_default_mem_order") == 0)
5673 property_kind = CTX_PROPERTY_ID;
5674
5675 if (gfc_match (" (") == MATCH_YES)
5676 {
5677 if (property_kind == CTX_PROPERTY_NONE)
5678 {
5679 gfc_error ("selector %qs does not accept any properties at %C",
5680 selector);
5681 return MATCH_ERROR;
5682 }
5683
5684 if (allow_score && gfc_match (" score") == MATCH_YES)
5685 {
5686 if (gfc_match (" (") != MATCH_YES)
5687 {
5688 gfc_error ("expected %<(%> at %C");
5689 return MATCH_ERROR;
5690 }
5691 if (gfc_match_expr (&os->score) != MATCH_YES
5692 || !gfc_resolve_expr (os->score)
5693 || os->score->ts.type != BT_INTEGER
5694 || os->score->rank != 0)
5695 {
5696 gfc_error ("score argument must be constant integer "
5697 "expression at %C");
5698 return MATCH_ERROR;
5699 }
5700
5701 if (os->score->expr_type == EXPR_CONSTANT
5702 && mpz_sgn (os->score->value.integer) < 0)
5703 {
5704 gfc_error ("score argument must be non-negative at %C");
5705 return MATCH_ERROR;
5706 }
5707
5708 if (gfc_match (" )") != MATCH_YES)
5709 {
5710 gfc_error ("expected %<)%> at %C");
5711 return MATCH_ERROR;
5712 }
5713
5714 if (gfc_match (" :") != MATCH_YES)
5715 {
5716 gfc_error ("expected : at %C");
5717 return MATCH_ERROR;
5718 }
5719 }
5720
5721 gfc_omp_trait_property *otp = gfc_get_omp_trait_property ();
5722 otp->property_kind = property_kind;
5723 otp->next = os->properties;
5724 os->properties = otp;
5725
5726 switch (property_kind)
5727 {
5728 case CTX_PROPERTY_USER:
5729 do
5730 {
5731 if (gfc_match_expr (&otp->expr) != MATCH_YES)
5732 {
5733 gfc_error ("property must be constant integer "
5734 "expression or string literal at %C");
5735 return MATCH_ERROR;
5736 }
5737
5738 if (gfc_match (" ,") != MATCH_YES)
5739 break;
5740 }
5741 while (1);
5742 break;
5743 case CTX_PROPERTY_ID:
5744 {
5745 char buf[GFC_MAX_SYMBOL_LEN + 1];
5746 if (gfc_match_name (buf) == MATCH_YES)
5747 {
5748 otp->name = XNEWVEC (char, strlen (buf) + 1);
5749 strcpy (dest: otp->name, src: buf);
5750 }
5751 else
5752 {
5753 gfc_error ("expected identifier at %C");
5754 return MATCH_ERROR;
5755 }
5756 }
5757 break;
5758 case CTX_PROPERTY_NAME_LIST:
5759 do
5760 {
5761 char buf[GFC_MAX_SYMBOL_LEN + 1];
5762 if (gfc_match_name (buf) == MATCH_YES)
5763 {
5764 otp->name = XNEWVEC (char, strlen (buf) + 1);
5765 strcpy (dest: otp->name, src: buf);
5766 otp->is_name = true;
5767 }
5768 else if (gfc_match_literal_constant (&otp->expr, 0)
5769 != MATCH_YES
5770 || otp->expr->ts.type != BT_CHARACTER)
5771 {
5772 gfc_error ("expected identifier or string literal "
5773 "at %C");
5774 return MATCH_ERROR;
5775 }
5776
5777 if (gfc_match (" ,") == MATCH_YES)
5778 {
5779 otp = gfc_get_omp_trait_property ();
5780 otp->property_kind = property_kind;
5781 otp->next = os->properties;
5782 os->properties = otp;
5783 }
5784 else
5785 break;
5786 }
5787 while (1);
5788 break;
5789 case CTX_PROPERTY_EXPR:
5790 if (gfc_match_expr (&otp->expr) != MATCH_YES)
5791 {
5792 gfc_error ("expected expression at %C");
5793 return MATCH_ERROR;
5794 }
5795 if (!gfc_resolve_expr (otp->expr)
5796 || (otp->expr->ts.type != BT_LOGICAL
5797 && otp->expr->ts.type != BT_INTEGER)
5798 || otp->expr->rank != 0)
5799 {
5800 gfc_error ("property must be constant integer or logical "
5801 "expression at %C");
5802 return MATCH_ERROR;
5803 }
5804 break;
5805 case CTX_PROPERTY_SIMD:
5806 {
5807 if (gfc_match_omp_clauses (cp: &otp->clauses,
5808 OMP_DECLARE_SIMD_CLAUSES,
5809 first: true, needs_space: false, openacc: false, context_selector: true)
5810 != MATCH_YES)
5811 {
5812 gfc_error ("expected simd clause at %C");
5813 return MATCH_ERROR;
5814 }
5815 break;
5816 }
5817 default:
5818 gcc_unreachable ();
5819 }
5820
5821 if (gfc_match (" )") != MATCH_YES)
5822 {
5823 gfc_error ("expected %<)%> at %C");
5824 return MATCH_ERROR;
5825 }
5826 }
5827 else if (property_kind == CTX_PROPERTY_NAME_LIST
5828 || property_kind == CTX_PROPERTY_ID
5829 || property_kind == CTX_PROPERTY_EXPR)
5830 {
5831 if (gfc_match (" (") != MATCH_YES)
5832 {
5833 gfc_error ("expected %<(%> at %C");
5834 return MATCH_ERROR;
5835 }
5836 }
5837
5838 if (gfc_match (" ,") != MATCH_YES)
5839 break;
5840 }
5841 while (1);
5842
5843 return MATCH_YES;
5844}
5845
5846/* OpenMP 5.0:
5847
5848 trait-set-selector[,trait-set-selector[,...]]
5849
5850 trait-set-selector:
5851 trait-set-selector-name = { trait-selector[, trait-selector[, ...]] }
5852
5853 trait-set-selector-name:
5854 constructor
5855 device
5856 implementation
5857 user */
5858
5859match
5860gfc_match_omp_context_selector_specification (gfc_omp_declare_variant *odv)
5861{
5862 do
5863 {
5864 match m;
5865 const char *selector_sets[] = { "construct", "device",
5866 "implementation", "user" };
5867 const int selector_set_count = ARRAY_SIZE (selector_sets);
5868 int i;
5869 char buf[GFC_MAX_SYMBOL_LEN + 1];
5870
5871 m = gfc_match_name (buf);
5872 if (m == MATCH_YES)
5873 for (i = 0; i < selector_set_count; i++)
5874 if (strcmp (s1: buf, s2: selector_sets[i]) == 0)
5875 break;
5876
5877 if (m != MATCH_YES || i == selector_set_count)
5878 {
5879 gfc_error ("expected %<construct%>, %<device%>, %<implementation%> "
5880 "or %<user%> at %C");
5881 return MATCH_ERROR;
5882 }
5883
5884 m = gfc_match (" =");
5885 if (m != MATCH_YES)
5886 {
5887 gfc_error ("expected %<=%> at %C");
5888 return MATCH_ERROR;
5889 }
5890
5891 m = gfc_match (" {");
5892 if (m != MATCH_YES)
5893 {
5894 gfc_error ("expected %<{%> at %C");
5895 return MATCH_ERROR;
5896 }
5897
5898 gfc_omp_set_selector *oss = gfc_get_omp_set_selector ();
5899 oss->next = odv->set_selectors;
5900 oss->trait_set_selector_name = selector_sets[i];
5901 odv->set_selectors = oss;
5902
5903 if (gfc_match_omp_context_selector (oss) != MATCH_YES)
5904 return MATCH_ERROR;
5905
5906 m = gfc_match (" }");
5907 if (m != MATCH_YES)
5908 {
5909 gfc_error ("expected %<}%> at %C");
5910 return MATCH_ERROR;
5911 }
5912
5913 m = gfc_match (" ,");
5914 if (m != MATCH_YES)
5915 break;
5916 }
5917 while (1);
5918
5919 return MATCH_YES;
5920}
5921
5922
5923match
5924gfc_match_omp_declare_variant (void)
5925{
5926 bool first_p = true;
5927 char buf[GFC_MAX_SYMBOL_LEN + 1];
5928
5929 if (gfc_match (" (") != MATCH_YES)
5930 {
5931 gfc_error ("expected %<(%> at %C");
5932 return MATCH_ERROR;
5933 }
5934
5935 gfc_symtree *base_proc_st, *variant_proc_st;
5936 if (gfc_match_name (buf) != MATCH_YES)
5937 {
5938 gfc_error ("expected name at %C");
5939 return MATCH_ERROR;
5940 }
5941
5942 if (gfc_get_ha_sym_tree (buf, &base_proc_st))
5943 return MATCH_ERROR;
5944
5945 if (gfc_match (" :") == MATCH_YES)
5946 {
5947 if (gfc_match_name (buf) != MATCH_YES)
5948 {
5949 gfc_error ("expected variant name at %C");
5950 return MATCH_ERROR;
5951 }
5952
5953 if (gfc_get_ha_sym_tree (buf, &variant_proc_st))
5954 return MATCH_ERROR;
5955 }
5956 else
5957 {
5958 /* Base procedure not specified. */
5959 variant_proc_st = base_proc_st;
5960 base_proc_st = NULL;
5961 }
5962
5963 gfc_omp_declare_variant *odv;
5964 odv = gfc_get_omp_declare_variant ();
5965 odv->where = gfc_current_locus;
5966 odv->variant_proc_symtree = variant_proc_st;
5967 odv->base_proc_symtree = base_proc_st;
5968 odv->next = NULL;
5969 odv->error_p = false;
5970
5971 /* Add the new declare variant to the end of the list. */
5972 gfc_omp_declare_variant **prev_next = &gfc_current_ns->omp_declare_variant;
5973 while (*prev_next)
5974 prev_next = &((*prev_next)->next);
5975 *prev_next = odv;
5976
5977 if (gfc_match (" )") != MATCH_YES)
5978 {
5979 gfc_error ("expected %<)%> at %C");
5980 return MATCH_ERROR;
5981 }
5982
5983 for (;;)
5984 {
5985 if (gfc_match (" match") != MATCH_YES)
5986 {
5987 if (first_p)
5988 {
5989 gfc_error ("expected %<match%> at %C");
5990 return MATCH_ERROR;
5991 }
5992 else
5993 break;
5994 }
5995
5996 if (gfc_match (" (") != MATCH_YES)
5997 {
5998 gfc_error ("expected %<(%> at %C");
5999 return MATCH_ERROR;
6000 }
6001
6002 if (gfc_match_omp_context_selector_specification (odv) != MATCH_YES)
6003 return MATCH_ERROR;
6004
6005 if (gfc_match (" )") != MATCH_YES)
6006 {
6007 gfc_error ("expected %<)%> at %C");
6008 return MATCH_ERROR;
6009 }
6010
6011 first_p = false;
6012 }
6013
6014 return MATCH_YES;
6015}
6016
6017
6018match
6019gfc_match_omp_threadprivate (void)
6020{
6021 locus old_loc;
6022 char n[GFC_MAX_SYMBOL_LEN+1];
6023 gfc_symbol *sym;
6024 match m;
6025 gfc_symtree *st;
6026
6027 old_loc = gfc_current_locus;
6028
6029 m = gfc_match (" (");
6030 if (m != MATCH_YES)
6031 return m;
6032
6033 for (;;)
6034 {
6035 m = gfc_match_symbol (&sym, 0);
6036 switch (m)
6037 {
6038 case MATCH_YES:
6039 if (sym->attr.in_common)
6040 gfc_error_now ("Threadprivate variable at %C is an element of "
6041 "a COMMON block");
6042 else if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at))
6043 goto cleanup;
6044 goto next_item;
6045 case MATCH_NO:
6046 break;
6047 case MATCH_ERROR:
6048 goto cleanup;
6049 }
6050
6051 m = gfc_match (" / %n /", n);
6052 if (m == MATCH_ERROR)
6053 goto cleanup;
6054 if (m == MATCH_NO || n[0] == '\0')
6055 goto syntax;
6056
6057 st = gfc_find_symtree (gfc_current_ns->common_root, n);
6058 if (st == NULL)
6059 {
6060 gfc_error ("COMMON block /%s/ not found at %C", n);
6061 goto cleanup;
6062 }
6063 st->n.common->threadprivate = 1;
6064 for (sym = st->n.common->head; sym; sym = sym->common_next)
6065 if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at))
6066 goto cleanup;
6067
6068 next_item:
6069 if (gfc_match_char (')') == MATCH_YES)
6070 break;
6071 if (gfc_match_char (',') != MATCH_YES)
6072 goto syntax;
6073 }
6074
6075 if (gfc_match_omp_eos () != MATCH_YES)
6076 {
6077 gfc_error ("Unexpected junk after OMP THREADPRIVATE at %C");
6078 goto cleanup;
6079 }
6080
6081 return MATCH_YES;
6082
6083syntax:
6084 gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C");
6085
6086cleanup:
6087 gfc_current_locus = old_loc;
6088 return MATCH_ERROR;
6089}
6090
6091
6092match
6093gfc_match_omp_parallel (void)
6094{
6095 return match_omp (op: EXEC_OMP_PARALLEL, OMP_PARALLEL_CLAUSES);
6096}
6097
6098
6099match
6100gfc_match_omp_parallel_do (void)
6101{
6102 return match_omp (op: EXEC_OMP_PARALLEL_DO,
6103 mask: (OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
6104 & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
6105}
6106
6107
6108match
6109gfc_match_omp_parallel_do_simd (void)
6110{
6111 return match_omp (op: EXEC_OMP_PARALLEL_DO_SIMD,
6112 mask: (OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
6113 & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
6114}
6115
6116
6117match
6118gfc_match_omp_parallel_masked (void)
6119{
6120 return match_omp (op: EXEC_OMP_PARALLEL_MASKED,
6121 OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES);
6122}
6123
6124match
6125gfc_match_omp_parallel_masked_taskloop (void)
6126{
6127 return match_omp (op: EXEC_OMP_PARALLEL_MASKED_TASKLOOP,
6128 mask: (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES
6129 | OMP_TASKLOOP_CLAUSES)
6130 & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
6131}
6132
6133match
6134gfc_match_omp_parallel_masked_taskloop_simd (void)
6135{
6136 return match_omp (op: EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD,
6137 mask: (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES
6138 | OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES)
6139 & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
6140}
6141
6142match
6143gfc_match_omp_parallel_master (void)
6144{
6145 return match_omp (op: EXEC_OMP_PARALLEL_MASTER, OMP_PARALLEL_CLAUSES);
6146}
6147
6148match
6149gfc_match_omp_parallel_master_taskloop (void)
6150{
6151 return match_omp (op: EXEC_OMP_PARALLEL_MASTER_TASKLOOP,
6152 mask: (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES)
6153 & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
6154}
6155
6156match
6157gfc_match_omp_parallel_master_taskloop_simd (void)
6158{
6159 return match_omp (op: EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD,
6160 mask: (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES
6161 | OMP_SIMD_CLAUSES)
6162 & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
6163}
6164
6165match
6166gfc_match_omp_parallel_sections (void)
6167{
6168 return match_omp (op: EXEC_OMP_PARALLEL_SECTIONS,
6169 mask: (OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES)
6170 & ~(omp_mask (OMP_CLAUSE_NOWAIT)));
6171}
6172
6173
6174match
6175gfc_match_omp_parallel_workshare (void)
6176{
6177 return match_omp (op: EXEC_OMP_PARALLEL_WORKSHARE, OMP_PARALLEL_CLAUSES);
6178}
6179
6180void
6181gfc_check_omp_requires (gfc_namespace *ns, int ref_omp_requires)
6182{
6183 if (ns->omp_target_seen
6184 && (ns->omp_requires & OMP_REQ_TARGET_MASK)
6185 != (ref_omp_requires & OMP_REQ_TARGET_MASK))
6186 {
6187 gcc_assert (ns->proc_name);
6188 if ((ref_omp_requires & OMP_REQ_REVERSE_OFFLOAD)
6189 && !(ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD))
6190 gfc_error ("Program unit at %L has OpenMP device constructs/routines "
6191 "but does not set !$OMP REQUIRES REVERSE_OFFLOAD but other "
6192 "program units do", &ns->proc_name->declared_at);
6193 if ((ref_omp_requires & OMP_REQ_UNIFIED_ADDRESS)
6194 && !(ns->omp_requires & OMP_REQ_UNIFIED_ADDRESS))
6195 gfc_error ("Program unit at %L has OpenMP device constructs/routines "
6196 "but does not set !$OMP REQUIRES UNIFIED_ADDRESS but other "
6197 "program units do", &ns->proc_name->declared_at);
6198 if ((ref_omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY)
6199 && !(ns->omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY))
6200 gfc_error ("Program unit at %L has OpenMP device constructs/routines "
6201 "but does not set !$OMP REQUIRES UNIFIED_SHARED_MEMORY but "
6202 "other program units do", &ns->proc_name->declared_at);
6203 }
6204}
6205
6206bool
6207gfc_omp_requires_add_clause (gfc_omp_requires_kind clause,
6208 const char *clause_name, locus *loc,
6209 const char *module_name)
6210{
6211 gfc_namespace *prog_unit = gfc_current_ns;
6212 while (prog_unit->parent)
6213 {
6214 if (gfc_state_stack->previous
6215 && gfc_state_stack->previous->state == COMP_INTERFACE)
6216 break;
6217 prog_unit = prog_unit->parent;
6218 }
6219
6220 /* Requires added after use. */
6221 if (prog_unit->omp_target_seen
6222 && (clause & OMP_REQ_TARGET_MASK)
6223 && !(prog_unit->omp_requires & clause))
6224 {
6225 if (module_name)
6226 gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use "
6227 "at %L comes after using a device construct/routine",
6228 clause_name, module_name, loc);
6229 else
6230 gfc_error ("!$OMP REQUIRES clause %qs specified at %L comes after "
6231 "using a device construct/routine", clause_name, loc);
6232 return false;
6233 }
6234
6235 /* Overriding atomic_default_mem_order clause value. */
6236 if ((clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
6237 && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
6238 && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
6239 != (int) clause)
6240 {
6241 const char *other;
6242 if (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST)
6243 other = "seq_cst";
6244 else if (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL)
6245 other = "acq_rel";
6246 else if (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_RELAXED)
6247 other = "relaxed";
6248 else
6249 gcc_unreachable ();
6250
6251 if (module_name)
6252 gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
6253 "specified via module %qs use at %L overrides a previous "
6254 "%<atomic_default_mem_order(%s)%> (which might be through "
6255 "using a module)", clause_name, module_name, loc, other);
6256 else
6257 gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
6258 "specified at %L overrides a previous "
6259 "%<atomic_default_mem_order(%s)%> (which might be through "
6260 "using a module)", clause_name, loc, other);
6261 return false;
6262 }
6263
6264 /* Requires via module not at program-unit level and not repeating clause. */
6265 if (prog_unit != gfc_current_ns && !(prog_unit->omp_requires & clause))
6266 {
6267 if (clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
6268 gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
6269 "specified via module %qs use at %L but same clause is "
6270 "not specified for the program unit", clause_name,
6271 module_name, loc);
6272 else
6273 gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use at "
6274 "%L but same clause is not specified for the program unit",
6275 clause_name, module_name, loc);
6276 return false;
6277 }
6278
6279 if (!gfc_state_stack->previous
6280 || gfc_state_stack->previous->state != COMP_INTERFACE)
6281 prog_unit->omp_requires |= clause;
6282 return true;
6283}
6284
6285match
6286gfc_match_omp_requires (void)
6287{
6288 static const char *clauses[] = {"reverse_offload",
6289 "unified_address",
6290 "unified_shared_memory",
6291 "dynamic_allocators",
6292 "atomic_default"};
6293 const char *clause = NULL;
6294 int requires_clauses = 0;
6295 bool first = true;
6296 locus old_loc;
6297
6298 if (gfc_current_ns->parent
6299 && (!gfc_state_stack->previous
6300 || gfc_state_stack->previous->state != COMP_INTERFACE))
6301 {
6302 gfc_error ("!$OMP REQUIRES at %C must appear in the specification part "
6303 "of a program unit");
6304 return MATCH_ERROR;
6305 }
6306
6307 while (true)
6308 {
6309 old_loc = gfc_current_locus;
6310 gfc_omp_requires_kind requires_clause;
6311 if ((first || gfc_match_char (',') != MATCH_YES)
6312 && (first && gfc_match_space () != MATCH_YES))
6313 goto error;
6314 first = false;
6315 gfc_gobble_whitespace ();
6316 old_loc = gfc_current_locus;
6317
6318 if (gfc_match_omp_eos () != MATCH_NO)
6319 break;
6320 if (gfc_match (clauses[0]) == MATCH_YES)
6321 {
6322 clause = clauses[0];
6323 requires_clause = OMP_REQ_REVERSE_OFFLOAD;
6324 if (requires_clauses & OMP_REQ_REVERSE_OFFLOAD)
6325 goto duplicate_clause;
6326 }
6327 else if (gfc_match (clauses[1]) == MATCH_YES)
6328 {
6329 clause = clauses[1];
6330 requires_clause = OMP_REQ_UNIFIED_ADDRESS;
6331 if (requires_clauses & OMP_REQ_UNIFIED_ADDRESS)
6332 goto duplicate_clause;
6333 }
6334 else if (gfc_match (clauses[2]) == MATCH_YES)
6335 {
6336 clause = clauses[2];
6337 requires_clause = OMP_REQ_UNIFIED_SHARED_MEMORY;
6338 if (requires_clauses & OMP_REQ_UNIFIED_SHARED_MEMORY)
6339 goto duplicate_clause;
6340 }
6341 else if (gfc_match (clauses[3]) == MATCH_YES)
6342 {
6343 clause = clauses[3];
6344 requires_clause = OMP_REQ_DYNAMIC_ALLOCATORS;
6345 if (requires_clauses & OMP_REQ_DYNAMIC_ALLOCATORS)
6346 goto duplicate_clause;
6347 }
6348 else if (gfc_match ("atomic_default_mem_order (") == MATCH_YES)
6349 {
6350 clause = clauses[4];
6351 if (requires_clauses & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
6352 goto duplicate_clause;
6353 if (gfc_match (" seq_cst )") == MATCH_YES)
6354 {
6355 clause = "seq_cst";
6356 requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST;
6357 }
6358 else if (gfc_match (" acq_rel )") == MATCH_YES)
6359 {
6360 clause = "acq_rel";
6361 requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL;
6362 }
6363 else if (gfc_match (" relaxed )") == MATCH_YES)
6364 {
6365 clause = "relaxed";
6366 requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_RELAXED;
6367 }
6368 else
6369 {
6370 gfc_error ("Expected SEQ_CST, ACQ_REL or RELAXED for "
6371 "ATOMIC_DEFAULT_MEM_ORDER clause at %C");
6372 goto error;
6373 }
6374 }
6375 else
6376 goto error;
6377
6378 if (!gfc_omp_requires_add_clause (clause: requires_clause, clause_name: clause, loc: &old_loc, NULL))
6379 goto error;
6380 requires_clauses |= requires_clause;
6381 }
6382
6383 if (requires_clauses == 0)
6384 {
6385 if (!gfc_error_flag_test ())
6386 gfc_error ("Clause expected at %C");
6387 goto error;
6388 }
6389 return MATCH_YES;
6390
6391duplicate_clause:
6392 gfc_error ("%qs clause at %L specified more than once", clause, &old_loc);
6393error:
6394 if (!gfc_error_flag_test ())
6395 gfc_error ("Expected UNIFIED_ADDRESS, UNIFIED_SHARED_MEMORY, "
6396 "DYNAMIC_ALLOCATORS, REVERSE_OFFLOAD, or "
6397 "ATOMIC_DEFAULT_MEM_ORDER clause at %L", &old_loc);
6398 return MATCH_ERROR;
6399}
6400
6401
6402match
6403gfc_match_omp_scan (void)
6404{
6405 bool incl;
6406 gfc_omp_clauses *c = gfc_get_omp_clauses ();
6407 gfc_gobble_whitespace ();
6408 if ((incl = (gfc_match ("inclusive") == MATCH_YES))
6409 || gfc_match ("exclusive") == MATCH_YES)
6410 {
6411 if (gfc_match_omp_variable_list (str: " (", list: &c->lists[incl ? OMP_LIST_SCAN_IN
6412 : OMP_LIST_SCAN_EX],
6413 allow_common: false) != MATCH_YES)
6414 {
6415 gfc_free_omp_clauses (c);
6416 return MATCH_ERROR;
6417 }
6418 }
6419 else
6420 {
6421 gfc_error ("Expected INCLUSIVE or EXCLUSIVE clause at %C");
6422 gfc_free_omp_clauses (c);
6423 return MATCH_ERROR;
6424 }
6425 if (gfc_match_omp_eos () != MATCH_YES)
6426 {
6427 gfc_error ("Unexpected junk after !$OMP SCAN at %C");
6428 gfc_free_omp_clauses (c);
6429 return MATCH_ERROR;
6430 }
6431
6432 new_st.op = EXEC_OMP_SCAN;
6433 new_st.ext.omp_clauses = c;
6434 return MATCH_YES;
6435}
6436
6437
6438match
6439gfc_match_omp_scope (void)
6440{
6441 return match_omp (op: EXEC_OMP_SCOPE, OMP_SCOPE_CLAUSES);
6442}
6443
6444
6445match
6446gfc_match_omp_sections (void)
6447{
6448 return match_omp (op: EXEC_OMP_SECTIONS, OMP_SECTIONS_CLAUSES);
6449}
6450
6451
6452match
6453gfc_match_omp_simd (void)
6454{
6455 return match_omp (op: EXEC_OMP_SIMD, OMP_SIMD_CLAUSES);
6456}
6457
6458
6459match
6460gfc_match_omp_single (void)
6461{
6462 return match_omp (op: EXEC_OMP_SINGLE, OMP_SINGLE_CLAUSES);
6463}
6464
6465
6466match
6467gfc_match_omp_target (void)
6468{
6469 return match_omp (op: EXEC_OMP_TARGET, OMP_TARGET_CLAUSES);
6470}
6471
6472
6473match
6474gfc_match_omp_target_data (void)
6475{
6476 return match_omp (op: EXEC_OMP_TARGET_DATA, OMP_TARGET_DATA_CLAUSES);
6477}
6478
6479
6480match
6481gfc_match_omp_target_enter_data (void)
6482{
6483 return match_omp (op: EXEC_OMP_TARGET_ENTER_DATA, OMP_TARGET_ENTER_DATA_CLAUSES);
6484}
6485
6486
6487match
6488gfc_match_omp_target_exit_data (void)
6489{
6490 return match_omp (op: EXEC_OMP_TARGET_EXIT_DATA, OMP_TARGET_EXIT_DATA_CLAUSES);
6491}
6492
6493
6494match
6495gfc_match_omp_target_parallel (void)
6496{
6497 return match_omp (op: EXEC_OMP_TARGET_PARALLEL,
6498 mask: (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES)
6499 & ~(omp_mask (OMP_CLAUSE_COPYIN)));
6500}
6501
6502
6503match
6504gfc_match_omp_target_parallel_do (void)
6505{
6506 return match_omp (op: EXEC_OMP_TARGET_PARALLEL_DO,
6507 mask: (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES
6508 | OMP_DO_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN)));
6509}
6510
6511
6512match
6513gfc_match_omp_target_parallel_do_simd (void)
6514{
6515 return match_omp (op: EXEC_OMP_TARGET_PARALLEL_DO_SIMD,
6516 mask: (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
6517 | OMP_SIMD_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN)));
6518}
6519
6520
6521match
6522gfc_match_omp_target_simd (void)
6523{
6524 return match_omp (op: EXEC_OMP_TARGET_SIMD,
6525 OMP_TARGET_CLAUSES | OMP_SIMD_CLAUSES);
6526}
6527
6528
6529match
6530gfc_match_omp_target_teams (void)
6531{
6532 return match_omp (op: EXEC_OMP_TARGET_TEAMS,
6533 OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES);
6534}
6535
6536
6537match
6538gfc_match_omp_target_teams_distribute (void)
6539{
6540 return match_omp (op: EXEC_OMP_TARGET_TEAMS_DISTRIBUTE,
6541 OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
6542 | OMP_DISTRIBUTE_CLAUSES);
6543}
6544
6545
6546match
6547gfc_match_omp_target_teams_distribute_parallel_do (void)
6548{
6549 return match_omp (op: EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO,
6550 mask: (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
6551 | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
6552 | OMP_DO_CLAUSES)
6553 & ~(omp_mask (OMP_CLAUSE_ORDERED))
6554 & ~(omp_mask (OMP_CLAUSE_LINEAR)));
6555}
6556
6557
6558match
6559gfc_match_omp_target_teams_distribute_parallel_do_simd (void)
6560{
6561 return match_omp (op: EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
6562 mask: (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
6563 | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
6564 | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
6565 & ~(omp_mask (OMP_CLAUSE_ORDERED)));
6566}
6567
6568
6569match
6570gfc_match_omp_target_teams_distribute_simd (void)
6571{
6572 return match_omp (op: EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD,
6573 OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
6574 | OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
6575}
6576
6577
6578match
6579gfc_match_omp_target_update (void)
6580{
6581 return match_omp (op: EXEC_OMP_TARGET_UPDATE, OMP_TARGET_UPDATE_CLAUSES);
6582}
6583
6584
6585match
6586gfc_match_omp_task (void)
6587{
6588 return match_omp (op: EXEC_OMP_TASK, OMP_TASK_CLAUSES);
6589}
6590
6591
6592match
6593gfc_match_omp_taskloop (void)
6594{
6595 return match_omp (op: EXEC_OMP_TASKLOOP, OMP_TASKLOOP_CLAUSES);
6596}
6597
6598
6599match
6600gfc_match_omp_taskloop_simd (void)
6601{
6602 return match_omp (op: EXEC_OMP_TASKLOOP_SIMD,
6603 OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES);
6604}
6605
6606
6607match
6608gfc_match_omp_taskwait (void)
6609{
6610 if (gfc_match_omp_eos () == MATCH_YES)
6611 {
6612 new_st.op = EXEC_OMP_TASKWAIT;
6613 new_st.ext.omp_clauses = NULL;
6614 return MATCH_YES;
6615 }
6616 return match_omp (op: EXEC_OMP_TASKWAIT,
6617 mask: omp_mask (OMP_CLAUSE_DEPEND) | OMP_CLAUSE_NOWAIT);
6618}
6619
6620
6621match
6622gfc_match_omp_taskyield (void)
6623{
6624 if (gfc_match_omp_eos () != MATCH_YES)
6625 {
6626 gfc_error ("Unexpected junk after TASKYIELD clause at %C");
6627 return MATCH_ERROR;
6628 }
6629 new_st.op = EXEC_OMP_TASKYIELD;
6630 new_st.ext.omp_clauses = NULL;
6631 return MATCH_YES;
6632}
6633
6634
6635match
6636gfc_match_omp_teams (void)
6637{
6638 return match_omp (op: EXEC_OMP_TEAMS, OMP_TEAMS_CLAUSES);
6639}
6640
6641
6642match
6643gfc_match_omp_teams_distribute (void)
6644{
6645 return match_omp (op: EXEC_OMP_TEAMS_DISTRIBUTE,
6646 OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES);
6647}
6648
6649
6650match
6651gfc_match_omp_teams_distribute_parallel_do (void)
6652{
6653 return match_omp (op: EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO,
6654 mask: (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
6655 | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
6656 & ~(omp_mask (OMP_CLAUSE_ORDERED)
6657 | OMP_CLAUSE_LINEAR | OMP_CLAUSE_NOWAIT));
6658}
6659
6660
6661match
6662gfc_match_omp_teams_distribute_parallel_do_simd (void)
6663{
6664 return match_omp (op: EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
6665 mask: (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
6666 | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
6667 | OMP_SIMD_CLAUSES)
6668 & ~(omp_mask (OMP_CLAUSE_ORDERED) | OMP_CLAUSE_NOWAIT));
6669}
6670
6671
6672match
6673gfc_match_omp_teams_distribute_simd (void)
6674{
6675 return match_omp (op: EXEC_OMP_TEAMS_DISTRIBUTE_SIMD,
6676 OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
6677 | OMP_SIMD_CLAUSES);
6678}
6679
6680
6681match
6682gfc_match_omp_workshare (void)
6683{
6684 return match_omp (op: EXEC_OMP_WORKSHARE, OMP_WORKSHARE_CLAUSES);
6685}
6686
6687
6688match
6689gfc_match_omp_masked (void)
6690{
6691 return match_omp (op: EXEC_OMP_MASKED, OMP_MASKED_CLAUSES);
6692}
6693
6694match
6695gfc_match_omp_masked_taskloop (void)
6696{
6697 return match_omp (op: EXEC_OMP_MASKED_TASKLOOP,
6698 OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES);
6699}
6700
6701match
6702gfc_match_omp_masked_taskloop_simd (void)
6703{
6704 return match_omp (op: EXEC_OMP_MASKED_TASKLOOP_SIMD,
6705 mask: (OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES
6706 | OMP_SIMD_CLAUSES));
6707}
6708
6709match
6710gfc_match_omp_master (void)
6711{
6712 if (gfc_match_omp_eos () != MATCH_YES)
6713 {
6714 gfc_error ("Unexpected junk after $OMP MASTER statement at %C");
6715 return MATCH_ERROR;
6716 }
6717 new_st.op = EXEC_OMP_MASTER;
6718 new_st.ext.omp_clauses = NULL;
6719 return MATCH_YES;
6720}
6721
6722match
6723gfc_match_omp_master_taskloop (void)
6724{
6725 return match_omp (op: EXEC_OMP_MASTER_TASKLOOP, OMP_TASKLOOP_CLAUSES);
6726}
6727
6728match
6729gfc_match_omp_master_taskloop_simd (void)
6730{
6731 return match_omp (op: EXEC_OMP_MASTER_TASKLOOP_SIMD,
6732 OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES);
6733}
6734
6735match
6736gfc_match_omp_ordered (void)
6737{
6738 return match_omp (op: EXEC_OMP_ORDERED, OMP_ORDERED_CLAUSES);
6739}
6740
6741match
6742gfc_match_omp_nothing (void)
6743{
6744 if (gfc_match_omp_eos () != MATCH_YES)
6745 {
6746 gfc_error ("Unexpected junk after $OMP NOTHING statement at %C");
6747 return MATCH_ERROR;
6748 }
6749 /* Will use ST_NONE; therefore, no EXEC_OMP_ is needed. */
6750 return MATCH_YES;
6751}
6752
6753match
6754gfc_match_omp_ordered_depend (void)
6755{
6756 return match_omp (op: EXEC_OMP_ORDERED, mask: omp_mask (OMP_CLAUSE_DOACROSS));
6757}
6758
6759
6760/* omp atomic [clause-list]
6761 - atomic-clause: read | write | update
6762 - capture
6763 - memory-order-clause: seq_cst | acq_rel | release | acquire | relaxed
6764 - hint(hint-expr)
6765 - OpenMP 5.1: compare | fail (seq_cst | acquire | relaxed ) | weak
6766*/
6767
6768match
6769gfc_match_omp_atomic (void)
6770{
6771 gfc_omp_clauses *c;
6772 locus loc = gfc_current_locus;
6773
6774 if (gfc_match_omp_clauses (cp: &c, OMP_ATOMIC_CLAUSES, first: true, needs_space: true) != MATCH_YES)
6775 return MATCH_ERROR;
6776
6777 if (c->atomic_op == GFC_OMP_ATOMIC_UNSET)
6778 c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
6779
6780 if (c->capture && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
6781 gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
6782 "READ or WRITE", &loc, "CAPTURE");
6783 if (c->compare && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
6784 gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
6785 "READ or WRITE", &loc, "COMPARE");
6786 if (c->fail != OMP_MEMORDER_UNSET && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
6787 gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
6788 "READ or WRITE", &loc, "FAIL");
6789 if (c->weak && !c->compare)
6790 {
6791 gfc_error ("!$OMP ATOMIC at %L with %s clause requires %s clause", &loc,
6792 "WEAK", "COMPARE");
6793 c->weak = false;
6794 }
6795
6796 if (c->memorder == OMP_MEMORDER_UNSET)
6797 {
6798 gfc_namespace *prog_unit = gfc_current_ns;
6799 while (prog_unit->parent)
6800 prog_unit = prog_unit->parent;
6801 switch (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
6802 {
6803 case 0:
6804 case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED:
6805 c->memorder = OMP_MEMORDER_RELAXED;
6806 break;
6807 case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST:
6808 c->memorder = OMP_MEMORDER_SEQ_CST;
6809 break;
6810 case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL:
6811 if (c->capture)
6812 c->memorder = OMP_MEMORDER_ACQ_REL;
6813 else if (c->atomic_op == GFC_OMP_ATOMIC_READ)
6814 c->memorder = OMP_MEMORDER_ACQUIRE;
6815 else
6816 c->memorder = OMP_MEMORDER_RELEASE;
6817 break;
6818 default:
6819 gcc_unreachable ();
6820 }
6821 }
6822 else
6823 switch (c->atomic_op)
6824 {
6825 case GFC_OMP_ATOMIC_READ:
6826 if (c->memorder == OMP_MEMORDER_RELEASE)
6827 {
6828 gfc_error ("!$OMP ATOMIC READ at %L incompatible with "
6829 "RELEASE clause", &loc);
6830 c->memorder = OMP_MEMORDER_SEQ_CST;
6831 }
6832 else if (c->memorder == OMP_MEMORDER_ACQ_REL)
6833 c->memorder = OMP_MEMORDER_ACQUIRE;
6834 break;
6835 case GFC_OMP_ATOMIC_WRITE:
6836 if (c->memorder == OMP_MEMORDER_ACQUIRE)
6837 {
6838 gfc_error ("!$OMP ATOMIC WRITE at %L incompatible with "
6839 "ACQUIRE clause", &loc);
6840 c->memorder = OMP_MEMORDER_SEQ_CST;
6841 }
6842 else if (c->memorder == OMP_MEMORDER_ACQ_REL)
6843 c->memorder = OMP_MEMORDER_RELEASE;
6844 break;
6845 default:
6846 break;
6847 }
6848 gfc_error_check ();
6849 new_st.ext.omp_clauses = c;
6850 new_st.op = EXEC_OMP_ATOMIC;
6851 return MATCH_YES;
6852}
6853
6854
6855/* acc atomic [ read | write | update | capture] */
6856
6857match
6858gfc_match_oacc_atomic (void)
6859{
6860 gfc_omp_clauses *c = gfc_get_omp_clauses ();
6861 c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
6862 c->memorder = OMP_MEMORDER_RELAXED;
6863 gfc_gobble_whitespace ();
6864 if (gfc_match ("update") == MATCH_YES)
6865 ;
6866 else if (gfc_match ("read") == MATCH_YES)
6867 c->atomic_op = GFC_OMP_ATOMIC_READ;
6868 else if (gfc_match ("write") == MATCH_YES)
6869 c->atomic_op = GFC_OMP_ATOMIC_WRITE;
6870 else if (gfc_match ("capture") == MATCH_YES)
6871 c->capture = true;
6872 gfc_gobble_whitespace ();
6873 if (gfc_match_omp_eos () != MATCH_YES)
6874 {
6875 gfc_error ("Unexpected junk after !$ACC ATOMIC statement at %C");
6876 gfc_free_omp_clauses (c);
6877 return MATCH_ERROR;
6878 }
6879 new_st.ext.omp_clauses = c;
6880 new_st.op = EXEC_OACC_ATOMIC;
6881 return MATCH_YES;
6882}
6883
6884
6885match
6886gfc_match_omp_barrier (void)
6887{
6888 if (gfc_match_omp_eos () != MATCH_YES)
6889 {
6890 gfc_error ("Unexpected junk after $OMP BARRIER statement at %C");
6891 return MATCH_ERROR;
6892 }
6893 new_st.op = EXEC_OMP_BARRIER;
6894 new_st.ext.omp_clauses = NULL;
6895 return MATCH_YES;
6896}
6897
6898
6899match
6900gfc_match_omp_taskgroup (void)
6901{
6902 return match_omp (op: EXEC_OMP_TASKGROUP, OMP_TASKGROUP_CLAUSES);
6903}
6904
6905
6906static enum gfc_omp_cancel_kind
6907gfc_match_omp_cancel_kind (void)
6908{
6909 if (gfc_match_space () != MATCH_YES)
6910 return OMP_CANCEL_UNKNOWN;
6911 if (gfc_match ("parallel") == MATCH_YES)
6912 return OMP_CANCEL_PARALLEL;
6913 if (gfc_match ("sections") == MATCH_YES)
6914 return OMP_CANCEL_SECTIONS;
6915 if (gfc_match ("do") == MATCH_YES)
6916 return OMP_CANCEL_DO;
6917 if (gfc_match ("taskgroup") == MATCH_YES)
6918 return OMP_CANCEL_TASKGROUP;
6919 return OMP_CANCEL_UNKNOWN;
6920}
6921
6922
6923match
6924gfc_match_omp_cancel (void)
6925{
6926 gfc_omp_clauses *c;
6927 enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
6928 if (kind == OMP_CANCEL_UNKNOWN)
6929 return MATCH_ERROR;
6930 if (gfc_match_omp_clauses (cp: &c, mask: omp_mask (OMP_CLAUSE_IF), first: false) != MATCH_YES)
6931 return MATCH_ERROR;
6932 c->cancel = kind;
6933 new_st.op = EXEC_OMP_CANCEL;
6934 new_st.ext.omp_clauses = c;
6935 return MATCH_YES;
6936}
6937
6938
6939match
6940gfc_match_omp_cancellation_point (void)
6941{
6942 gfc_omp_clauses *c;
6943 enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
6944 if (kind == OMP_CANCEL_UNKNOWN)
6945 {
6946 gfc_error ("Expected construct-type PARALLEL, SECTIONS, DO or TASKGROUP "
6947 "in $OMP CANCELLATION POINT statement at %C");
6948 return MATCH_ERROR;
6949 }
6950 if (gfc_match_omp_eos () != MATCH_YES)
6951 {
6952 gfc_error ("Unexpected junk after $OMP CANCELLATION POINT statement "
6953 "at %C");
6954 return MATCH_ERROR;
6955 }
6956 c = gfc_get_omp_clauses ();
6957 c->cancel = kind;
6958 new_st.op = EXEC_OMP_CANCELLATION_POINT;
6959 new_st.ext.omp_clauses = c;
6960 return MATCH_YES;
6961}
6962
6963
6964match
6965gfc_match_omp_end_nowait (void)
6966{
6967 bool nowait = false;
6968 if (gfc_match ("% nowait") == MATCH_YES)
6969 nowait = true;
6970 if (gfc_match_omp_eos () != MATCH_YES)
6971 {
6972 if (nowait)
6973 gfc_error ("Unexpected junk after NOWAIT clause at %C");
6974 else
6975 gfc_error ("Unexpected junk at %C");
6976 return MATCH_ERROR;
6977 }
6978 new_st.op = EXEC_OMP_END_NOWAIT;
6979 new_st.ext.omp_bool = nowait;
6980 return MATCH_YES;
6981}
6982
6983
6984match
6985gfc_match_omp_end_single (void)
6986{
6987 gfc_omp_clauses *c;
6988 if (gfc_match_omp_clauses (cp: &c, mask: omp_mask (OMP_CLAUSE_COPYPRIVATE)
6989 | OMP_CLAUSE_NOWAIT) != MATCH_YES)
6990 return MATCH_ERROR;
6991 new_st.op = EXEC_OMP_END_SINGLE;
6992 new_st.ext.omp_clauses = c;
6993 return MATCH_YES;
6994}
6995
6996
6997static bool
6998oacc_is_loop (gfc_code *code)
6999{
7000 return code->op == EXEC_OACC_PARALLEL_LOOP
7001 || code->op == EXEC_OACC_KERNELS_LOOP
7002 || code->op == EXEC_OACC_SERIAL_LOOP
7003 || code->op == EXEC_OACC_LOOP;
7004}
7005
7006static void
7007resolve_scalar_int_expr (gfc_expr *expr, const char *clause)
7008{
7009 if (!gfc_resolve_expr (expr)
7010 || expr->ts.type != BT_INTEGER
7011 || expr->rank != 0)
7012 gfc_error ("%s clause at %L requires a scalar INTEGER expression",
7013 clause, &expr->where);
7014}
7015
7016static void
7017resolve_positive_int_expr (gfc_expr *expr, const char *clause)
7018{
7019 resolve_scalar_int_expr (expr, clause);
7020 if (expr->expr_type == EXPR_CONSTANT
7021 && expr->ts.type == BT_INTEGER
7022 && mpz_sgn (expr->value.integer) <= 0)
7023 gfc_warning (opt: 0, "INTEGER expression of %s clause at %L must be positive",
7024 clause, &expr->where);
7025}
7026
7027static void
7028resolve_nonnegative_int_expr (gfc_expr *expr, const char *clause)
7029{
7030 resolve_scalar_int_expr (expr, clause);
7031 if (expr->expr_type == EXPR_CONSTANT
7032 && expr->ts.type == BT_INTEGER
7033 && mpz_sgn (expr->value.integer) < 0)
7034 gfc_warning (opt: 0, "INTEGER expression of %s clause at %L must be "
7035 "non-negative", clause, &expr->where);
7036}
7037
7038/* Emits error when symbol is pointer, cray pointer or cray pointee
7039 of derived of polymorphic type. */
7040
7041static void
7042check_symbol_not_pointer (gfc_symbol *sym, locus loc, const char *name)
7043{
7044 if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointer)
7045 gfc_error ("Cray pointer object %qs of derived type in %s clause at %L",
7046 sym->name, name, &loc);
7047 if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointee)
7048 gfc_error ("Cray pointee object %qs of derived type in %s clause at %L",
7049 sym->name, name, &loc);
7050
7051 if ((sym->ts.type == BT_ASSUMED && sym->attr.pointer)
7052 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
7053 && CLASS_DATA (sym)->attr.pointer))
7054 gfc_error ("POINTER object %qs of polymorphic type in %s clause at %L",
7055 sym->name, name, &loc);
7056 if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointer)
7057 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
7058 && CLASS_DATA (sym)->attr.cray_pointer))
7059 gfc_error ("Cray pointer object %qs of polymorphic type in %s clause at %L",
7060 sym->name, name, &loc);
7061 if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointee)
7062 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
7063 && CLASS_DATA (sym)->attr.cray_pointee))
7064 gfc_error ("Cray pointee object %qs of polymorphic type in %s clause at %L",
7065 sym->name, name, &loc);
7066}
7067
7068/* Emits error when symbol represents assumed size/rank array. */
7069
7070static void
7071check_array_not_assumed (gfc_symbol *sym, locus loc, const char *name)
7072{
7073 if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
7074 gfc_error ("Assumed size array %qs in %s clause at %L",
7075 sym->name, name, &loc);
7076 if (sym->as && sym->as->type == AS_ASSUMED_RANK)
7077 gfc_error ("Assumed rank array %qs in %s clause at %L",
7078 sym->name, name, &loc);
7079}
7080
7081static void
7082resolve_oacc_data_clauses (gfc_symbol *sym, locus loc, const char *name)
7083{
7084 check_array_not_assumed (sym, loc, name);
7085}
7086
7087static void
7088resolve_oacc_deviceptr_clause (gfc_symbol *sym, locus loc, const char *name)
7089{
7090 if (sym->attr.pointer
7091 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
7092 && CLASS_DATA (sym)->attr.class_pointer))
7093 gfc_error ("POINTER object %qs in %s clause at %L",
7094 sym->name, name, &loc);
7095 if (sym->attr.cray_pointer
7096 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
7097 && CLASS_DATA (sym)->attr.cray_pointer))
7098 gfc_error ("Cray pointer object %qs in %s clause at %L",
7099 sym->name, name, &loc);
7100 if (sym->attr.cray_pointee
7101 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
7102 && CLASS_DATA (sym)->attr.cray_pointee))
7103 gfc_error ("Cray pointee object %qs in %s clause at %L",
7104 sym->name, name, &loc);
7105 if (sym->attr.allocatable
7106 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
7107 && CLASS_DATA (sym)->attr.allocatable))
7108 gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
7109 sym->name, name, &loc);
7110 if (sym->attr.value)
7111 gfc_error ("VALUE object %qs in %s clause at %L",
7112 sym->name, name, &loc);
7113 check_array_not_assumed (sym, loc, name);
7114}
7115
7116
7117struct resolve_omp_udr_callback_data
7118{
7119 gfc_symbol *sym1, *sym2;
7120};
7121
7122
7123static int
7124resolve_omp_udr_callback (gfc_expr **e, int *, void *data)
7125{
7126 struct resolve_omp_udr_callback_data *rcd
7127 = (struct resolve_omp_udr_callback_data *) data;
7128 if ((*e)->expr_type == EXPR_VARIABLE
7129 && ((*e)->symtree->n.sym == rcd->sym1
7130 || (*e)->symtree->n.sym == rcd->sym2))
7131 {
7132 gfc_ref *ref = gfc_get_ref ();
7133 ref->type = REF_ARRAY;
7134 ref->u.ar.where = (*e)->where;
7135 ref->u.ar.as = (*e)->symtree->n.sym->as;
7136 ref->u.ar.type = AR_FULL;
7137 ref->u.ar.dimen = 0;
7138 ref->next = (*e)->ref;
7139 (*e)->ref = ref;
7140 }
7141 return 0;
7142}
7143
7144
7145static int
7146resolve_omp_udr_callback2 (gfc_expr **e, int *, void *)
7147{
7148 if ((*e)->expr_type == EXPR_FUNCTION
7149 && (*e)->value.function.isym == NULL)
7150 {
7151 gfc_symbol *sym = (*e)->symtree->n.sym;
7152 if (!sym->attr.intrinsic
7153 && sym->attr.if_source == IFSRC_UNKNOWN)
7154 gfc_error ("Implicitly declared function %s used in "
7155 "!$OMP DECLARE REDUCTION at %L", sym->name, &(*e)->where);
7156 }
7157 return 0;
7158}
7159
7160
7161static gfc_code *
7162resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns,
7163 gfc_symbol *sym1, gfc_symbol *sym2)
7164{
7165 gfc_code *copy;
7166 gfc_symbol sym1_copy, sym2_copy;
7167
7168 if (ns->code->op == EXEC_ASSIGN)
7169 {
7170 copy = gfc_get_code (EXEC_ASSIGN);
7171 copy->expr1 = gfc_copy_expr (ns->code->expr1);
7172 copy->expr2 = gfc_copy_expr (ns->code->expr2);
7173 }
7174 else
7175 {
7176 copy = gfc_get_code (EXEC_CALL);
7177 copy->symtree = ns->code->symtree;
7178 copy->ext.actual = gfc_copy_actual_arglist (ns->code->ext.actual);
7179 }
7180 copy->loc = ns->code->loc;
7181 sym1_copy = *sym1;
7182 sym2_copy = *sym2;
7183 *sym1 = *n->sym;
7184 *sym2 = *n->sym;
7185 sym1->name = sym1_copy.name;
7186 sym2->name = sym2_copy.name;
7187 ns->proc_name = ns->parent->proc_name;
7188 if (n->sym->attr.dimension)
7189 {
7190 struct resolve_omp_udr_callback_data rcd;
7191 rcd.sym1 = sym1;
7192 rcd.sym2 = sym2;
7193 gfc_code_walker (&copy, gfc_dummy_code_callback,
7194 resolve_omp_udr_callback, &rcd);
7195 }
7196 gfc_resolve_code (copy, gfc_current_ns);
7197 if (copy->op == EXEC_CALL && copy->resolved_isym == NULL)
7198 {
7199 gfc_symbol *sym = copy->resolved_sym;
7200 if (sym
7201 && !sym->attr.intrinsic
7202 && sym->attr.if_source == IFSRC_UNKNOWN)
7203 gfc_error ("Implicitly declared subroutine %s used in "
7204 "!$OMP DECLARE REDUCTION at %L", sym->name,
7205 &copy->loc);
7206 }
7207 gfc_code_walker (&copy, gfc_dummy_code_callback,
7208 resolve_omp_udr_callback2, NULL);
7209 *sym1 = sym1_copy;
7210 *sym2 = sym2_copy;
7211 return copy;
7212}
7213
7214/* Assume that a constant expression in the range 1 (omp_default_mem_alloc)
7215 to 8 (omp_thread_mem_alloc) range is fine. The original symbol name is
7216 already lost during matching via gfc_match_expr. */
7217static bool
7218is_predefined_allocator (gfc_expr *expr)
7219{
7220 return (gfc_resolve_expr (expr)
7221 && expr->rank == 0
7222 && expr->ts.type == BT_INTEGER
7223 && expr->ts.kind == gfc_c_intptr_kind
7224 && expr->expr_type == EXPR_CONSTANT
7225 && mpz_sgn (expr->value.integer) > 0
7226 && mpz_cmp_si (expr->value.integer, 8) <= 0);
7227}
7228
7229/* Resolve declarative ALLOCATE statement. Note: Common block vars only appear
7230 as /block/ not individual, which is ensured during parsing. */
7231
7232void
7233gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list)
7234{
7235 for (gfc_omp_namelist *n = list; n; n = n->next)
7236 {
7237 if (n->sym->attr.result || n->sym->result == n->sym)
7238 {
7239 gfc_error ("Unexpected function-result variable %qs at %L in "
7240 "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
7241 continue;
7242 }
7243 if (ns->omp_allocate->sym->attr.proc_pointer)
7244 {
7245 gfc_error ("Procedure pointer %qs not supported with !$OMP "
7246 "ALLOCATE at %L", n->sym->name, &n->where);
7247 continue;
7248 }
7249 if (n->sym->attr.flavor != FL_VARIABLE)
7250 {
7251 gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE "
7252 "directive must be a variable", n->sym->name,
7253 &n->where);
7254 continue;
7255 }
7256 if (ns != n->sym->ns || n->sym->attr.use_assoc || n->sym->attr.imported)
7257 {
7258 gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE shall be"
7259 " in the same scope as the variable declaration",
7260 n->sym->name, &n->where);
7261 continue;
7262 }
7263 if (n->sym->attr.dummy)
7264 {
7265 gfc_error ("Unexpected dummy argument %qs as argument at %L to "
7266 "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
7267 continue;
7268 }
7269 if (n->sym->attr.codimension)
7270 {
7271 gfc_error ("Unexpected coarray argument %qs as argument at %L to "
7272 "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
7273 continue;
7274 }
7275 if (n->sym->attr.omp_allocate)
7276 {
7277 if (n->sym->attr.in_common)
7278 {
7279 gfc_error ("Duplicated common block %</%s/%> in !$OMP ALLOCATE "
7280 "at %L", n->sym->common_head->name, &n->where);
7281 while (n->next && n->next->sym
7282 && n->sym->common_head == n->next->sym->common_head)
7283 n = n->next;
7284 }
7285 else
7286 gfc_error ("Duplicated variable %qs in !$OMP ALLOCATE at %L",
7287 n->sym->name, &n->where);
7288 continue;
7289 }
7290 /* For 'equivalence(a,b)', a 'union_type {<type> a,b} equiv.0' is created
7291 with a value expression for 'a' as 'equiv.0.a' (likewise for b); while
7292 this can be handled, EQUIVALENCE is marked as obsolescent since Fortran
7293 2018 and also not widely used. However, it could be supported,
7294 if needed. */
7295 if (n->sym->attr.in_equivalence)
7296 {
7297 gfc_error ("Sorry, EQUIVALENCE object %qs not supported with !$OMP "
7298 "ALLOCATE at %L", n->sym->name, &n->where);
7299 continue;
7300 }
7301 /* Similar for Cray pointer/pointee - they could be implemented but as
7302 common vendor extension but nowadays rarely used and requiring
7303 -fcray-pointer, there is no need to support them. */
7304 if (n->sym->attr.cray_pointer || n->sym->attr.cray_pointee)
7305 {
7306 gfc_error ("Sorry, Cray pointers and pointees such as %qs are not "
7307 "supported with !$OMP ALLOCATE at %L",
7308 n->sym->name, &n->where);
7309 continue;
7310 }
7311 n->sym->attr.omp_allocate = 1;
7312 if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok
7313 && CLASS_DATA (n->sym)->attr.allocatable)
7314 || (n->sym->ts.type != BT_CLASS && n->sym->attr.allocatable))
7315 gfc_error ("Unexpected allocatable variable %qs at %L in declarative "
7316 "!$OMP ALLOCATE directive", n->sym->name, &n->where);
7317 else if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok
7318 && CLASS_DATA (n->sym)->attr.class_pointer)
7319 || (n->sym->ts.type != BT_CLASS && n->sym->attr.pointer))
7320 gfc_error ("Unexpected pointer variable %qs at %L in declarative "
7321 "!$OMP ALLOCATE directive", n->sym->name, &n->where);
7322 HOST_WIDE_INT alignment = 0;
7323 if (n->u.align
7324 && (!gfc_resolve_expr (n->u.align)
7325 || n->u.align->ts.type != BT_INTEGER
7326 || n->u.align->rank != 0
7327 || n->u.align->expr_type != EXPR_CONSTANT
7328 || gfc_extract_hwi (n->u.align, &alignment)
7329 || !pow2p_hwi (x: alignment)))
7330 {
7331 gfc_error ("ALIGN requires a scalar positive constant integer "
7332 "alignment expression at %L that is a power of two",
7333 &n->u.align->where);
7334 while (n->sym->attr.in_common && n->next && n->next->sym
7335 && n->sym->common_head == n->next->sym->common_head)
7336 n = n->next;
7337 continue;
7338 }
7339 if (n->sym->attr.in_common || n->sym->attr.save || n->sym->ns->save_all
7340 || (n->sym->ns->proc_name
7341 && (n->sym->ns->proc_name->attr.flavor == FL_PROGRAM
7342 || n->sym->ns->proc_name->attr.flavor == FL_MODULE)))
7343 {
7344 bool com = n->sym->attr.in_common;
7345 if (!n->u2.allocator)
7346 gfc_error ("An ALLOCATOR clause is required as the list item "
7347 "%<%s%s%s%> at %L has the SAVE attribute", com ? "/" : "",
7348 com ? n->sym->common_head->name : n->sym->name,
7349 com ? "/" : "", &n->where);
7350 else if (!is_predefined_allocator (expr: n->u2.allocator))
7351 gfc_error ("Predefined allocator required in ALLOCATOR clause at %L"
7352 " as the list item %<%s%s%s%> at %L has the SAVE attribute",
7353 &n->u2.allocator->where, com ? "/" : "",
7354 com ? n->sym->common_head->name : n->sym->name,
7355 com ? "/" : "", &n->where);
7356 while (n->sym->attr.in_common && n->next && n->next->sym
7357 && n->sym->common_head == n->next->sym->common_head)
7358 n = n->next;
7359 }
7360 else if (n->u2.allocator
7361 && (!gfc_resolve_expr (n->u2.allocator)
7362 || n->u2.allocator->ts.type != BT_INTEGER
7363 || n->u2.allocator->rank != 0
7364 || n->u2.allocator->ts.kind != gfc_c_intptr_kind))
7365 gfc_error ("Expected integer expression of the "
7366 "%<omp_allocator_handle_kind%> kind at %L",
7367 &n->u2.allocator->where);
7368 }
7369}
7370
7371/* Resolve ASSUME's and ASSUMES' assumption clauses. Note that absent/contains
7372 is handled during parse time in omp_verify_merge_absent_contains. */
7373
7374void
7375gfc_resolve_omp_assumptions (gfc_omp_assumptions *assume)
7376{
7377 for (gfc_expr_list *el = assume->holds; el; el = el->next)
7378 if (!gfc_resolve_expr (el->expr)
7379 || el->expr->ts.type != BT_LOGICAL
7380 || el->expr->rank != 0)
7381 gfc_error ("HOLDS expression at %L must be a scalar logical expression",
7382 &el->expr->where);
7383}
7384
7385
7386/* OpenMP directive resolving routines. */
7387
7388static void
7389resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
7390 gfc_namespace *ns, bool openacc = false)
7391{
7392 gfc_omp_namelist *n, *last;
7393 gfc_expr_list *el;
7394 int list;
7395 int ifc;
7396 bool if_without_mod = false;
7397 gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
7398 static const char *clause_names[]
7399 = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
7400 "COPYIN", "UNIFORM", "AFFINITY", "ALIGNED", "LINEAR", "DEPEND", "MAP",
7401 "TO", "FROM", "INCLUSIVE", "EXCLUSIVE",
7402 "REDUCTION", "REDUCTION" /*inscan*/, "REDUCTION" /*task*/,
7403 "IN_REDUCTION", "TASK_REDUCTION",
7404 "DEVICE_RESIDENT", "LINK", "USE_DEVICE",
7405 "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR",
7406 "NONTEMPORAL", "ALLOCATE", "HAS_DEVICE_ADDR", "ENTER",
7407 "USES_ALLOCATORS" };
7408 STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM);
7409
7410 if (omp_clauses == NULL)
7411 return;
7412
7413 if (omp_clauses->orderedc && omp_clauses->orderedc < omp_clauses->collapse)
7414 gfc_error ("ORDERED clause parameter is less than COLLAPSE at %L",
7415 &code->loc);
7416 if (omp_clauses->order_concurrent && omp_clauses->ordered)
7417 gfc_error ("ORDER clause must not be used together ORDERED at %L",
7418 &code->loc);
7419 if (omp_clauses->if_expr)
7420 {
7421 gfc_expr *expr = omp_clauses->if_expr;
7422 if (!gfc_resolve_expr (expr)
7423 || expr->ts.type != BT_LOGICAL || expr->rank != 0)
7424 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
7425 &expr->where);
7426 if_without_mod = true;
7427 }
7428 for (ifc = 0; ifc < OMP_IF_LAST; ifc++)
7429 if (omp_clauses->if_exprs[ifc])
7430 {
7431 gfc_expr *expr = omp_clauses->if_exprs[ifc];
7432 bool ok = true;
7433 if (!gfc_resolve_expr (expr)
7434 || expr->ts.type != BT_LOGICAL || expr->rank != 0)
7435 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
7436 &expr->where);
7437 else if (if_without_mod)
7438 {
7439 gfc_error ("IF clause without modifier at %L used together with "
7440 "IF clauses with modifiers",
7441 &omp_clauses->if_expr->where);
7442 if_without_mod = false;
7443 }
7444 else
7445 switch (code->op)
7446 {
7447 case EXEC_OMP_CANCEL:
7448 ok = ifc == OMP_IF_CANCEL;
7449 break;
7450
7451 case EXEC_OMP_PARALLEL:
7452 case EXEC_OMP_PARALLEL_DO:
7453 case EXEC_OMP_PARALLEL_LOOP:
7454 case EXEC_OMP_PARALLEL_MASKED:
7455 case EXEC_OMP_PARALLEL_MASTER:
7456 case EXEC_OMP_PARALLEL_SECTIONS:
7457 case EXEC_OMP_PARALLEL_WORKSHARE:
7458 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
7459 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
7460 ok = ifc == OMP_IF_PARALLEL;
7461 break;
7462
7463 case EXEC_OMP_PARALLEL_DO_SIMD:
7464 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
7465 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
7466 ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_SIMD;
7467 break;
7468
7469 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
7470 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
7471 ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_TASKLOOP;
7472 break;
7473
7474 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
7475 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
7476 ok = (ifc == OMP_IF_PARALLEL
7477 || ifc == OMP_IF_TASKLOOP
7478 || ifc == OMP_IF_SIMD);
7479 break;
7480
7481 case EXEC_OMP_SIMD:
7482 case EXEC_OMP_DO_SIMD:
7483 case EXEC_OMP_DISTRIBUTE_SIMD:
7484 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
7485 ok = ifc == OMP_IF_SIMD;
7486 break;
7487
7488 case EXEC_OMP_TASK:
7489 ok = ifc == OMP_IF_TASK;
7490 break;
7491
7492 case EXEC_OMP_TASKLOOP:
7493 case EXEC_OMP_MASKED_TASKLOOP:
7494 case EXEC_OMP_MASTER_TASKLOOP:
7495 ok = ifc == OMP_IF_TASKLOOP;
7496 break;
7497
7498 case EXEC_OMP_TASKLOOP_SIMD:
7499 case EXEC_OMP_MASKED_TASKLOOP_SIMD:
7500 case EXEC_OMP_MASTER_TASKLOOP_SIMD:
7501 ok = ifc == OMP_IF_TASKLOOP || ifc == OMP_IF_SIMD;
7502 break;
7503
7504 case EXEC_OMP_TARGET:
7505 case EXEC_OMP_TARGET_TEAMS:
7506 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
7507 case EXEC_OMP_TARGET_TEAMS_LOOP:
7508 ok = ifc == OMP_IF_TARGET;
7509 break;
7510
7511 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
7512 case EXEC_OMP_TARGET_SIMD:
7513 ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_SIMD;
7514 break;
7515
7516 case EXEC_OMP_TARGET_DATA:
7517 ok = ifc == OMP_IF_TARGET_DATA;
7518 break;
7519
7520 case EXEC_OMP_TARGET_UPDATE:
7521 ok = ifc == OMP_IF_TARGET_UPDATE;
7522 break;
7523
7524 case EXEC_OMP_TARGET_ENTER_DATA:
7525 ok = ifc == OMP_IF_TARGET_ENTER_DATA;
7526 break;
7527
7528 case EXEC_OMP_TARGET_EXIT_DATA:
7529 ok = ifc == OMP_IF_TARGET_EXIT_DATA;
7530 break;
7531
7532 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
7533 case EXEC_OMP_TARGET_PARALLEL:
7534 case EXEC_OMP_TARGET_PARALLEL_DO:
7535 case EXEC_OMP_TARGET_PARALLEL_LOOP:
7536 ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_PARALLEL;
7537 break;
7538
7539 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
7540 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
7541 ok = (ifc == OMP_IF_TARGET
7542 || ifc == OMP_IF_PARALLEL
7543 || ifc == OMP_IF_SIMD);
7544 break;
7545
7546 default:
7547 ok = false;
7548 break;
7549 }
7550 if (!ok)
7551 {
7552 static const char *ifs[] = {
7553 "CANCEL",
7554 "PARALLEL",
7555 "SIMD",
7556 "TASK",
7557 "TASKLOOP",
7558 "TARGET",
7559 "TARGET DATA",
7560 "TARGET UPDATE",
7561 "TARGET ENTER DATA",
7562 "TARGET EXIT DATA"
7563 };
7564 gfc_error ("IF clause modifier %s at %L not appropriate for "
7565 "the current OpenMP construct", ifs[ifc], &expr->where);
7566 }
7567 }
7568
7569 if (omp_clauses->self_expr)
7570 {
7571 gfc_expr *expr = omp_clauses->self_expr;
7572 if (!gfc_resolve_expr (expr)
7573 || expr->ts.type != BT_LOGICAL || expr->rank != 0)
7574 gfc_error ("SELF clause at %L requires a scalar LOGICAL expression",
7575 &expr->where);
7576 }
7577
7578 if (omp_clauses->final_expr)
7579 {
7580 gfc_expr *expr = omp_clauses->final_expr;
7581 if (!gfc_resolve_expr (expr)
7582 || expr->ts.type != BT_LOGICAL || expr->rank != 0)
7583 gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression",
7584 &expr->where);
7585 }
7586 if (omp_clauses->num_threads)
7587 resolve_positive_int_expr (expr: omp_clauses->num_threads, clause: "NUM_THREADS");
7588 if (omp_clauses->chunk_size)
7589 {
7590 gfc_expr *expr = omp_clauses->chunk_size;
7591 if (!gfc_resolve_expr (expr)
7592 || expr->ts.type != BT_INTEGER || expr->rank != 0)
7593 gfc_error ("SCHEDULE clause's chunk_size at %L requires "
7594 "a scalar INTEGER expression", &expr->where);
7595 else if (expr->expr_type == EXPR_CONSTANT
7596 && expr->ts.type == BT_INTEGER
7597 && mpz_sgn (expr->value.integer) <= 0)
7598 gfc_warning (opt: 0, "INTEGER expression of SCHEDULE clause's chunk_size "
7599 "at %L must be positive", &expr->where);
7600 }
7601 if (omp_clauses->sched_kind != OMP_SCHED_NONE
7602 && omp_clauses->sched_nonmonotonic)
7603 {
7604 if (omp_clauses->sched_monotonic)
7605 gfc_error ("Both MONOTONIC and NONMONOTONIC schedule modifiers "
7606 "specified at %L", &code->loc);
7607 else if (omp_clauses->ordered)
7608 gfc_error ("NONMONOTONIC schedule modifier specified with ORDERED "
7609 "clause at %L", &code->loc);
7610 }
7611
7612 if (omp_clauses->depobj
7613 && (!gfc_resolve_expr (omp_clauses->depobj)
7614 || omp_clauses->depobj->ts.type != BT_INTEGER
7615 || omp_clauses->depobj->ts.kind != 2 * gfc_index_integer_kind
7616 || omp_clauses->depobj->rank != 0))
7617 gfc_error ("DEPOBJ in DEPOBJ construct at %L shall be a scalar integer "
7618 "of OMP_DEPEND_KIND kind", &omp_clauses->depobj->where);
7619
7620 /* Check that no symbol appears on multiple clauses, except that
7621 a symbol can appear on both firstprivate and lastprivate. */
7622 for (list = 0; list < OMP_LIST_NUM; list++)
7623 for (n = omp_clauses->lists[list]; n; n = n->next)
7624 {
7625 if (!n->sym) /* omp_all_memory. */
7626 continue;
7627 n->sym->mark = 0;
7628 n->sym->comp_mark = 0;
7629 n->sym->data_mark = 0;
7630 n->sym->dev_mark = 0;
7631 n->sym->gen_mark = 0;
7632 n->sym->reduc_mark = 0;
7633 if (n->sym->attr.flavor == FL_VARIABLE
7634 || n->sym->attr.proc_pointer
7635 || (!code && (!n->sym->attr.dummy || n->sym->ns != ns)))
7636 {
7637 if (!code && (!n->sym->attr.dummy || n->sym->ns != ns))
7638 gfc_error ("Variable %qs is not a dummy argument at %L",
7639 n->sym->name, &n->where);
7640 continue;
7641 }
7642 if (n->sym->attr.flavor == FL_PROCEDURE
7643 && n->sym->result == n->sym
7644 && n->sym->attr.function)
7645 {
7646 if (gfc_current_ns->proc_name == n->sym
7647 || (gfc_current_ns->parent
7648 && gfc_current_ns->parent->proc_name == n->sym))
7649 continue;
7650 if (gfc_current_ns->proc_name->attr.entry_master)
7651 {
7652 gfc_entry_list *el = gfc_current_ns->entries;
7653 for (; el; el = el->next)
7654 if (el->sym == n->sym)
7655 break;
7656 if (el)
7657 continue;
7658 }
7659 if (gfc_current_ns->parent
7660 && gfc_current_ns->parent->proc_name->attr.entry_master)
7661 {
7662 gfc_entry_list *el = gfc_current_ns->parent->entries;
7663 for (; el; el = el->next)
7664 if (el->sym == n->sym)
7665 break;
7666 if (el)
7667 continue;
7668 }
7669 }
7670 if (list == OMP_LIST_MAP
7671 && n->sym->attr.flavor == FL_PARAMETER)
7672 {
7673 if (openacc)
7674 gfc_error ("Object %qs is not a variable at %L; parameters"
7675 " cannot be and need not be copied", n->sym->name,
7676 &n->where);
7677 else
7678 gfc_error ("Object %qs is not a variable at %L; parameters"
7679 " cannot be and need not be mapped", n->sym->name,
7680 &n->where);
7681 }
7682 else if (list != OMP_LIST_USES_ALLOCATORS)
7683 gfc_error ("Object %qs is not a variable at %L", n->sym->name,
7684 &n->where);
7685 }
7686 if (omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
7687 {
7688 locus *loc = &omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where;
7689 if (code->op != EXEC_OMP_DO
7690 && code->op != EXEC_OMP_SIMD
7691 && code->op != EXEC_OMP_DO_SIMD
7692 && code->op != EXEC_OMP_PARALLEL_DO
7693 && code->op != EXEC_OMP_PARALLEL_DO_SIMD)
7694 gfc_error ("%<inscan%> REDUCTION clause on construct other than DO, "
7695 "SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD at %L",
7696 loc);
7697 if (omp_clauses->ordered)
7698 gfc_error ("ORDERED clause specified together with %<inscan%> "
7699 "REDUCTION clause at %L", loc);
7700 if (omp_clauses->sched_kind != OMP_SCHED_NONE)
7701 gfc_error ("SCHEDULE clause specified together with %<inscan%> "
7702 "REDUCTION clause at %L", loc);
7703 }
7704
7705 for (list = 0; list < OMP_LIST_NUM; list++)
7706 if (list != OMP_LIST_FIRSTPRIVATE
7707 && list != OMP_LIST_LASTPRIVATE
7708 && list != OMP_LIST_ALIGNED
7709 && list != OMP_LIST_DEPEND
7710 && list != OMP_LIST_FROM
7711 && list != OMP_LIST_TO
7712 && (list != OMP_LIST_REDUCTION || !openacc)
7713 && list != OMP_LIST_ALLOCATE)
7714 for (n = omp_clauses->lists[list]; n; n = n->next)
7715 {
7716 bool component_ref_p = false;
7717
7718 /* Allow multiple components of the same (e.g. derived-type)
7719 variable here. Duplicate components are detected elsewhere. */
7720 if (n->expr && n->expr->expr_type == EXPR_VARIABLE)
7721 for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
7722 if (ref->type == REF_COMPONENT)
7723 component_ref_p = true;
7724 if ((list == OMP_LIST_IS_DEVICE_PTR
7725 || list == OMP_LIST_HAS_DEVICE_ADDR)
7726 && !component_ref_p)
7727 {
7728 if (n->sym->gen_mark
7729 || n->sym->dev_mark
7730 || n->sym->reduc_mark
7731 || n->sym->mark)
7732 gfc_error ("Symbol %qs present on multiple clauses at %L",
7733 n->sym->name, &n->where);
7734 else
7735 n->sym->dev_mark = 1;
7736 }
7737 else if ((list == OMP_LIST_USE_DEVICE_PTR
7738 || list == OMP_LIST_USE_DEVICE_ADDR
7739 || list == OMP_LIST_PRIVATE
7740 || list == OMP_LIST_SHARED)
7741 && !component_ref_p)
7742 {
7743 if (n->sym->gen_mark || n->sym->dev_mark || n->sym->reduc_mark)
7744 gfc_error ("Symbol %qs present on multiple clauses at %L",
7745 n->sym->name, &n->where);
7746 else
7747 {
7748 n->sym->gen_mark = 1;
7749 /* Set both generic and device bits if we have
7750 use_device_*(x) or shared(x). This allows us to diagnose
7751 "map(x) private(x)" below. */
7752 if (list != OMP_LIST_PRIVATE)
7753 n->sym->dev_mark = 1;
7754 }
7755 }
7756 else if ((list == OMP_LIST_REDUCTION
7757 || list == OMP_LIST_REDUCTION_TASK
7758 || list == OMP_LIST_REDUCTION_INSCAN
7759 || list == OMP_LIST_IN_REDUCTION
7760 || list == OMP_LIST_TASK_REDUCTION)
7761 && !component_ref_p)
7762 {
7763 /* Attempts to mix reduction types are diagnosed below. */
7764 if (n->sym->gen_mark || n->sym->dev_mark)
7765 gfc_error ("Symbol %qs present on multiple clauses at %L",
7766 n->sym->name, &n->where);
7767 n->sym->reduc_mark = 1;
7768 }
7769 else if ((!component_ref_p && n->sym->comp_mark)
7770 || (component_ref_p && n->sym->mark))
7771 {
7772 if (openacc)
7773 gfc_error ("Symbol %qs has mixed component and non-component "
7774 "accesses at %L", n->sym->name, &n->where);
7775 }
7776 else if (n->sym->mark)
7777 gfc_error ("Symbol %qs present on multiple clauses at %L",
7778 n->sym->name, &n->where);
7779 else
7780 {
7781 if (component_ref_p)
7782 n->sym->comp_mark = 1;
7783 else
7784 n->sym->mark = 1;
7785 }
7786 }
7787
7788 /* Detect specifically the case where we have "map(x) private(x)" and raise
7789 an error. If we have "...simd" combined directives though, the "private"
7790 applies to the simd part, so this is permitted though. */
7791 for (n = omp_clauses->lists[OMP_LIST_PRIVATE]; n; n = n->next)
7792 if (n->sym->mark
7793 && n->sym->gen_mark
7794 && !n->sym->dev_mark
7795 && !n->sym->reduc_mark
7796 && code->op != EXEC_OMP_TARGET_SIMD
7797 && code->op != EXEC_OMP_TARGET_PARALLEL_DO_SIMD
7798 && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
7799 && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD)
7800 gfc_error ("Symbol %qs present on multiple clauses at %L",
7801 n->sym->name, &n->where);
7802
7803 gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1);
7804 for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE; list++)
7805 for (n = omp_clauses->lists[list]; n; n = n->next)
7806 if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
7807 {
7808 gfc_error ("Symbol %qs present on multiple clauses at %L",
7809 n->sym->name, &n->where);
7810 n->sym->data_mark = n->sym->gen_mark = n->sym->dev_mark = 0;
7811 }
7812 else if (n->sym->mark
7813 && code->op != EXEC_OMP_TARGET_TEAMS
7814 && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
7815 && code->op != EXEC_OMP_TARGET_TEAMS_LOOP
7816 && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
7817 && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
7818 && code->op != EXEC_OMP_TARGET_PARALLEL
7819 && code->op != EXEC_OMP_TARGET_PARALLEL_DO
7820 && code->op != EXEC_OMP_TARGET_PARALLEL_LOOP
7821 && code->op != EXEC_OMP_TARGET_PARALLEL_DO_SIMD
7822 && code->op != EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD)
7823 gfc_error ("Symbol %qs present on both data and map clauses "
7824 "at %L", n->sym->name, &n->where);
7825
7826 for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next)
7827 {
7828 if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
7829 gfc_error ("Symbol %qs present on multiple clauses at %L",
7830 n->sym->name, &n->where);
7831 else
7832 n->sym->data_mark = 1;
7833 }
7834 for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
7835 n->sym->data_mark = 0;
7836
7837 for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
7838 {
7839 if (n->sym->data_mark || n->sym->gen_mark || n->sym->dev_mark)
7840 gfc_error ("Symbol %qs present on multiple clauses at %L",
7841 n->sym->name, &n->where);
7842 else
7843 n->sym->data_mark = 1;
7844 }
7845
7846 for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
7847 n->sym->mark = 0;
7848
7849 for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
7850 {
7851 if (n->sym->mark)
7852 gfc_error ("Symbol %qs present on multiple clauses at %L",
7853 n->sym->name, &n->where);
7854 else
7855 n->sym->mark = 1;
7856 }
7857
7858 if (omp_clauses->lists[OMP_LIST_ALLOCATE])
7859 {
7860 for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
7861 {
7862 if (n->u2.allocator
7863 && (!gfc_resolve_expr (n->u2.allocator)
7864 || n->u2.allocator->ts.type != BT_INTEGER
7865 || n->u2.allocator->rank != 0
7866 || n->u2.allocator->ts.kind != gfc_c_intptr_kind))
7867 {
7868 gfc_error ("Expected integer expression of the "
7869 "%<omp_allocator_handle_kind%> kind at %L",
7870 &n->u2.allocator->where);
7871 break;
7872 }
7873 if (!n->u.align)
7874 continue;
7875 HOST_WIDE_INT alignment = 0;
7876 if (!gfc_resolve_expr (n->u.align)
7877 || n->u.align->ts.type != BT_INTEGER
7878 || n->u.align->rank != 0
7879 || n->u.align->expr_type != EXPR_CONSTANT
7880 || gfc_extract_hwi (n->u.align, &alignment)
7881 || alignment <= 0
7882 || !pow2p_hwi (x: alignment))
7883 {
7884 gfc_error ("ALIGN requires a scalar positive constant integer "
7885 "alignment expression at %L that is a power of two",
7886 &n->u.align->where);
7887 break;
7888 }
7889 }
7890
7891 /* Check for 2 things here.
7892 1. There is no duplication of variable in allocate clause.
7893 2. Variable in allocate clause are also present in some
7894 privatization clase (non-composite case). */
7895 for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
7896 if (n->sym)
7897 n->sym->mark = 0;
7898
7899 gfc_omp_namelist *prev = NULL;
7900 for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; )
7901 {
7902 if (n->sym == NULL)
7903 {
7904 n = n->next;
7905 continue;
7906 }
7907 if (n->sym->mark == 1)
7908 {
7909 gfc_warning (opt: 0, "%qs appears more than once in %<allocate%> "
7910 "at %L" , n->sym->name, &n->where);
7911 /* We have already seen this variable so it is a duplicate.
7912 Remove it. */
7913 if (prev != NULL && prev->next == n)
7914 {
7915 prev->next = n->next;
7916 n->next = NULL;
7917 gfc_free_omp_namelist (n, false, true, false);
7918 n = prev->next;
7919 }
7920 continue;
7921 }
7922 n->sym->mark = 1;
7923 prev = n;
7924 n = n->next;
7925 }
7926
7927 /* Non-composite constructs. */
7928 if (code && code->op < EXEC_OMP_DO_SIMD)
7929 {
7930 for (list = 0; list < OMP_LIST_NUM; list++)
7931 switch (list)
7932 {
7933 case OMP_LIST_PRIVATE:
7934 case OMP_LIST_FIRSTPRIVATE:
7935 case OMP_LIST_LASTPRIVATE:
7936 case OMP_LIST_REDUCTION:
7937 case OMP_LIST_REDUCTION_INSCAN:
7938 case OMP_LIST_REDUCTION_TASK:
7939 case OMP_LIST_IN_REDUCTION:
7940 case OMP_LIST_TASK_REDUCTION:
7941 case OMP_LIST_LINEAR:
7942 for (n = omp_clauses->lists[list]; n; n = n->next)
7943 n->sym->mark = 0;
7944 break;
7945 default:
7946 break;
7947 }
7948
7949 for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
7950 if (n->sym->mark == 1)
7951 gfc_error ("%qs specified in %<allocate%> clause at %L but not "
7952 "in an explicit privatization clause",
7953 n->sym->name, &n->where);
7954 }
7955 if (code
7956 && (code->op == EXEC_OMP_ALLOCATORS || code->op == EXEC_OMP_ALLOCATE)
7957 && code->block
7958 && code->block->next
7959 && code->block->next->op == EXEC_ALLOCATE)
7960 {
7961 gfc_alloc *a;
7962 for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
7963 {
7964 if (n->sym == NULL)
7965 continue;
7966 if (n->sym->attr.codimension)
7967 gfc_error ("Unexpected coarray %qs in %<allocate%> at %L",
7968 n->sym->name, &n->where);
7969 for (a = code->block->next->ext.alloc.list; a; a = a->next)
7970 if (a->expr->expr_type == EXPR_VARIABLE
7971 && a->expr->symtree->n.sym == n->sym)
7972 break;
7973 if (a == NULL)
7974 gfc_error ("%qs specified in %<allocate%> at %L but not "
7975 "in the associated ALLOCATE statement",
7976 n->sym->name, &n->where);
7977 }
7978 }
7979
7980 }
7981
7982 /* OpenACC reductions. */
7983 if (openacc)
7984 {
7985 for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next)
7986 n->sym->mark = 0;
7987
7988 for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next)
7989 {
7990 if (n->sym->mark)
7991 gfc_error ("Symbol %qs present on multiple clauses at %L",
7992 n->sym->name, &n->where);
7993 else
7994 n->sym->mark = 1;
7995
7996 /* OpenACC does not support reductions on arrays. */
7997 if (n->sym->as)
7998 gfc_error ("Array %qs is not permitted in reduction at %L",
7999 n->sym->name, &n->where);
8000 }
8001 }
8002
8003 for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
8004 n->sym->mark = 0;
8005 for (n = omp_clauses->lists[OMP_LIST_FROM]; n; n = n->next)
8006 if (n->expr == NULL)
8007 n->sym->mark = 1;
8008 for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
8009 {
8010 if (n->expr == NULL && n->sym->mark)
8011 gfc_error ("Symbol %qs present on both FROM and TO clauses at %L",
8012 n->sym->name, &n->where);
8013 else
8014 n->sym->mark = 1;
8015 }
8016
8017 bool has_inscan = false, has_notinscan = false;
8018 for (list = 0; list < OMP_LIST_NUM; list++)
8019 if ((n = omp_clauses->lists[list]) != NULL)
8020 {
8021 const char *name = clause_names[list];
8022
8023 switch (list)
8024 {
8025 case OMP_LIST_COPYIN:
8026 for (; n != NULL; n = n->next)
8027 {
8028 if (!n->sym->attr.threadprivate)
8029 gfc_error ("Non-THREADPRIVATE object %qs in COPYIN clause"
8030 " at %L", n->sym->name, &n->where);
8031 }
8032 break;
8033 case OMP_LIST_COPYPRIVATE:
8034 if (omp_clauses->nowait)
8035 gfc_error ("NOWAIT clause must not be used with COPYPRIVATE "
8036 "clause at %L", &n->where);
8037 for (; n != NULL; n = n->next)
8038 {
8039 if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
8040 gfc_error ("Assumed size array %qs in COPYPRIVATE clause "
8041 "at %L", n->sym->name, &n->where);
8042 if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
8043 gfc_error ("INTENT(IN) POINTER %qs in COPYPRIVATE clause "
8044 "at %L", n->sym->name, &n->where);
8045 }
8046 break;
8047 case OMP_LIST_SHARED:
8048 for (; n != NULL; n = n->next)
8049 {
8050 if (n->sym->attr.threadprivate)
8051 gfc_error ("THREADPRIVATE object %qs in SHARED clause at "
8052 "%L", n->sym->name, &n->where);
8053 if (n->sym->attr.cray_pointee)
8054 gfc_error ("Cray pointee %qs in SHARED clause at %L",
8055 n->sym->name, &n->where);
8056 if (n->sym->attr.associate_var)
8057 gfc_error ("Associate name %qs in SHARED clause at %L",
8058 n->sym->attr.select_type_temporary
8059 ? n->sym->assoc->target->symtree->n.sym->name
8060 : n->sym->name, &n->where);
8061 if (omp_clauses->detach
8062 && n->sym == omp_clauses->detach->symtree->n.sym)
8063 gfc_error ("DETACH event handle %qs in SHARED clause at %L",
8064 n->sym->name, &n->where);
8065 }
8066 break;
8067 case OMP_LIST_ALIGNED:
8068 for (; n != NULL; n = n->next)
8069 {
8070 if (!n->sym->attr.pointer
8071 && !n->sym->attr.allocatable
8072 && !n->sym->attr.cray_pointer
8073 && (n->sym->ts.type != BT_DERIVED
8074 || (n->sym->ts.u.derived->from_intmod
8075 != INTMOD_ISO_C_BINDING)
8076 || (n->sym->ts.u.derived->intmod_sym_id
8077 != ISOCBINDING_PTR)))
8078 gfc_error ("%qs in ALIGNED clause must be POINTER, "
8079 "ALLOCATABLE, Cray pointer or C_PTR at %L",
8080 n->sym->name, &n->where);
8081 else if (n->expr)
8082 {
8083 if (!gfc_resolve_expr (n->expr)
8084 || n->expr->ts.type != BT_INTEGER
8085 || n->expr->rank != 0
8086 || n->expr->expr_type != EXPR_CONSTANT
8087 || mpz_sgn (n->expr->value.integer) <= 0)
8088 gfc_error ("%qs in ALIGNED clause at %L requires a scalar"
8089 " positive constant integer alignment "
8090 "expression", n->sym->name, &n->where);
8091 }
8092 }
8093 break;
8094 case OMP_LIST_AFFINITY:
8095 case OMP_LIST_DEPEND:
8096 case OMP_LIST_MAP:
8097 case OMP_LIST_TO:
8098 case OMP_LIST_FROM:
8099 case OMP_LIST_CACHE:
8100 for (; n != NULL; n = n->next)
8101 {
8102 if ((list == OMP_LIST_DEPEND || list == OMP_LIST_AFFINITY)
8103 && n->u2.ns && !n->u2.ns->resolved)
8104 {
8105 n->u2.ns->resolved = 1;
8106 for (gfc_symbol *sym = n->u2.ns->omp_affinity_iterators;
8107 sym; sym = sym->tlink)
8108 {
8109 gfc_constructor *c;
8110 c = gfc_constructor_first (base: sym->value->value.constructor);
8111 if (!gfc_resolve_expr (c->expr)
8112 || c->expr->ts.type != BT_INTEGER
8113 || c->expr->rank != 0)
8114 gfc_error ("Scalar integer expression for range begin"
8115 " expected at %L", &c->expr->where);
8116 c = gfc_constructor_next (ctor: c);
8117 if (!gfc_resolve_expr (c->expr)
8118 || c->expr->ts.type != BT_INTEGER
8119 || c->expr->rank != 0)
8120 gfc_error ("Scalar integer expression for range end "
8121 "expected at %L", &c->expr->where);
8122 c = gfc_constructor_next (ctor: c);
8123 if (c && (!gfc_resolve_expr (c->expr)
8124 || c->expr->ts.type != BT_INTEGER
8125 || c->expr->rank != 0))
8126 gfc_error ("Scalar integer expression for range step "
8127 "expected at %L", &c->expr->where);
8128 else if (c
8129 && c->expr->expr_type == EXPR_CONSTANT
8130 && mpz_cmp_si (c->expr->value.integer, 0) == 0)
8131 gfc_error ("Nonzero range step expected at %L",
8132 &c->expr->where);
8133 }
8134 }
8135
8136 if (list == OMP_LIST_DEPEND)
8137 {
8138 if (n->u.depend_doacross_op == OMP_DEPEND_SINK_FIRST
8139 || n->u.depend_doacross_op == OMP_DOACROSS_SINK_FIRST
8140 || n->u.depend_doacross_op == OMP_DOACROSS_SINK)
8141 {
8142 if (omp_clauses->doacross_source)
8143 {
8144 gfc_error ("Dependence-type SINK used together with"
8145 " SOURCE on the same construct at %L",
8146 &n->where);
8147 omp_clauses->doacross_source = false;
8148 }
8149 else if (n->expr)
8150 {
8151 if (!gfc_resolve_expr (n->expr)
8152 || n->expr->ts.type != BT_INTEGER
8153 || n->expr->rank != 0)
8154 gfc_error ("SINK addend not a constant integer "
8155 "at %L", &n->where);
8156 }
8157 if (n->sym == NULL
8158 && (n->expr == NULL
8159 || mpz_cmp_si (n->expr->value.integer, -1) != 0))
8160 gfc_error ("omp_cur_iteration at %L requires %<-1%> "
8161 "as logical offset", &n->where);
8162 continue;
8163 }
8164 else if (n->u.depend_doacross_op == OMP_DEPEND_DEPOBJ
8165 && !n->expr
8166 && (n->sym->ts.type != BT_INTEGER
8167 || n->sym->ts.kind
8168 != 2 * gfc_index_integer_kind
8169 || n->sym->attr.dimension))
8170 gfc_error ("Locator %qs at %L in DEPEND clause of depobj "
8171 "type shall be a scalar integer of "
8172 "OMP_DEPEND_KIND kind", n->sym->name,
8173 &n->where);
8174 else if (n->u.depend_doacross_op == OMP_DEPEND_DEPOBJ
8175 && n->expr
8176 && (!gfc_resolve_expr (n->expr)
8177 || n->expr->ts.type != BT_INTEGER
8178 || n->expr->ts.kind
8179 != 2 * gfc_index_integer_kind
8180 || n->expr->rank != 0))
8181 gfc_error ("Locator at %L in DEPEND clause of depobj "
8182 "type shall be a scalar integer of "
8183 "OMP_DEPEND_KIND kind", &n->expr->where);
8184 }
8185 gfc_ref *lastref = NULL, *lastslice = NULL;
8186 bool resolved = false;
8187 if (n->expr)
8188 {
8189 lastref = n->expr->ref;
8190 resolved = gfc_resolve_expr (n->expr);
8191
8192 /* Look through component refs to find last array
8193 reference. */
8194 if (resolved)
8195 {
8196 for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
8197 if (ref->type == REF_COMPONENT
8198 || ref->type == REF_SUBSTRING
8199 || ref->type == REF_INQUIRY)
8200 lastref = ref;
8201 else if (ref->type == REF_ARRAY)
8202 {
8203 for (int i = 0; i < ref->u.ar.dimen; i++)
8204 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE)
8205 lastslice = ref;
8206
8207 lastref = ref;
8208 }
8209
8210 /* The "!$acc cache" directive allows rectangular
8211 subarrays to be specified, with some restrictions
8212 on the form of bounds (not implemented).
8213 Only raise an error here if we're really sure the
8214 array isn't contiguous. An expression such as
8215 arr(-n:n,-n:n) could be contiguous even if it looks
8216 like it may not be. */
8217 if (code->op != EXEC_OACC_UPDATE
8218 && list != OMP_LIST_CACHE
8219 && list != OMP_LIST_DEPEND
8220 && !gfc_is_simply_contiguous (n->expr, false, true)
8221 && gfc_is_not_contiguous (n->expr)
8222 && !(lastslice
8223 && (lastslice->next
8224 || lastslice->type != REF_ARRAY)))
8225 gfc_error ("Array is not contiguous at %L",
8226 &n->where);
8227 }
8228 }
8229 if (openacc
8230 && list == OMP_LIST_MAP
8231 && (n->u.map_op == OMP_MAP_ATTACH
8232 || n->u.map_op == OMP_MAP_DETACH))
8233 {
8234 symbol_attribute attr;
8235 if (n->expr)
8236 attr = gfc_expr_attr (n->expr);
8237 else
8238 attr = n->sym->attr;
8239 if (!attr.pointer && !attr.allocatable)
8240 gfc_error ("%qs clause argument must be ALLOCATABLE or "
8241 "a POINTER at %L",
8242 (n->u.map_op == OMP_MAP_ATTACH) ? "attach"
8243 : "detach", &n->where);
8244 }
8245 if (lastref
8246 || (n->expr
8247 && (!resolved || n->expr->expr_type != EXPR_VARIABLE)))
8248 {
8249 if (!lastslice
8250 && lastref
8251 && lastref->type == REF_SUBSTRING)
8252 gfc_error ("Unexpected substring reference in %s clause "
8253 "at %L", name, &n->where);
8254 else if (!lastslice
8255 && lastref
8256 && lastref->type == REF_INQUIRY)
8257 {
8258 gcc_assert (lastref->u.i == INQUIRY_RE
8259 || lastref->u.i == INQUIRY_IM);
8260 gfc_error ("Unexpected complex-parts designator "
8261 "reference in %s clause at %L",
8262 name, &n->where);
8263 }
8264 else if (!resolved
8265 || n->expr->expr_type != EXPR_VARIABLE
8266 || (lastslice
8267 && (lastslice->next
8268 || lastslice->type != REF_ARRAY)))
8269 gfc_error ("%qs in %s clause at %L is not a proper "
8270 "array section", n->sym->name, name,
8271 &n->where);
8272 else if (lastslice)
8273 {
8274 int i;
8275 gfc_array_ref *ar = &lastslice->u.ar;
8276 for (i = 0; i < ar->dimen; i++)
8277 if (ar->stride[i] && code->op != EXEC_OACC_UPDATE)
8278 {
8279 gfc_error ("Stride should not be specified for "
8280 "array section in %s clause at %L",
8281 name, &n->where);
8282 break;
8283 }
8284 else if (ar->dimen_type[i] != DIMEN_ELEMENT
8285 && ar->dimen_type[i] != DIMEN_RANGE)
8286 {
8287 gfc_error ("%qs in %s clause at %L is not a "
8288 "proper array section",
8289 n->sym->name, name, &n->where);
8290 break;
8291 }
8292 else if ((list == OMP_LIST_DEPEND
8293 || list == OMP_LIST_AFFINITY)
8294 && ar->start[i]
8295 && ar->start[i]->expr_type == EXPR_CONSTANT
8296 && ar->end[i]
8297 && ar->end[i]->expr_type == EXPR_CONSTANT
8298 && mpz_cmp (ar->start[i]->value.integer,
8299 ar->end[i]->value.integer) > 0)
8300 {
8301 gfc_error ("%qs in %s clause at %L is a "
8302 "zero size array section",
8303 n->sym->name,
8304 list == OMP_LIST_DEPEND
8305 ? "DEPEND" : "AFFINITY", &n->where);
8306 break;
8307 }
8308 }
8309 }
8310 else if (openacc)
8311 {
8312 if (list == OMP_LIST_MAP
8313 && n->u.map_op == OMP_MAP_FORCE_DEVICEPTR)
8314 resolve_oacc_deviceptr_clause (sym: n->sym, loc: n->where, name);
8315 else
8316 resolve_oacc_data_clauses (sym: n->sym, loc: n->where, name);
8317 }
8318 else if (list != OMP_LIST_DEPEND
8319 && n->sym->as
8320 && n->sym->as->type == AS_ASSUMED_SIZE)
8321 gfc_error ("Assumed size array %qs in %s clause at %L",
8322 n->sym->name, name, &n->where);
8323 if (!openacc
8324 && list == OMP_LIST_MAP
8325 && n->sym->ts.type == BT_DERIVED
8326 && n->sym->ts.u.derived->attr.alloc_comp)
8327 gfc_error ("List item %qs with allocatable components is not "
8328 "permitted in map clause at %L", n->sym->name,
8329 &n->where);
8330 if (list == OMP_LIST_MAP && !openacc)
8331 switch (code->op)
8332 {
8333 case EXEC_OMP_TARGET:
8334 case EXEC_OMP_TARGET_DATA:
8335 switch (n->u.map_op)
8336 {
8337 case OMP_MAP_TO:
8338 case OMP_MAP_ALWAYS_TO:
8339 case OMP_MAP_PRESENT_TO:
8340 case OMP_MAP_ALWAYS_PRESENT_TO:
8341 case OMP_MAP_FROM:
8342 case OMP_MAP_ALWAYS_FROM:
8343 case OMP_MAP_PRESENT_FROM:
8344 case OMP_MAP_ALWAYS_PRESENT_FROM:
8345 case OMP_MAP_TOFROM:
8346 case OMP_MAP_ALWAYS_TOFROM:
8347 case OMP_MAP_PRESENT_TOFROM:
8348 case OMP_MAP_ALWAYS_PRESENT_TOFROM:
8349 case OMP_MAP_ALLOC:
8350 case OMP_MAP_PRESENT_ALLOC:
8351 break;
8352 default:
8353 gfc_error ("TARGET%s with map-type other than TO, "
8354 "FROM, TOFROM, or ALLOC on MAP clause "
8355 "at %L",
8356 code->op == EXEC_OMP_TARGET
8357 ? "" : " DATA", &n->where);
8358 break;
8359 }
8360 break;
8361 case EXEC_OMP_TARGET_ENTER_DATA:
8362 switch (n->u.map_op)
8363 {
8364 case OMP_MAP_TO:
8365 case OMP_MAP_ALWAYS_TO:
8366 case OMP_MAP_PRESENT_TO:
8367 case OMP_MAP_ALWAYS_PRESENT_TO:
8368 case OMP_MAP_ALLOC:
8369 case OMP_MAP_PRESENT_ALLOC:
8370 break;
8371 case OMP_MAP_TOFROM:
8372 n->u.map_op = OMP_MAP_TO;
8373 break;
8374 case OMP_MAP_ALWAYS_TOFROM:
8375 n->u.map_op = OMP_MAP_ALWAYS_TO;
8376 break;
8377 case OMP_MAP_PRESENT_TOFROM:
8378 n->u.map_op = OMP_MAP_PRESENT_TO;
8379 break;
8380 case OMP_MAP_ALWAYS_PRESENT_TOFROM:
8381 n->u.map_op = OMP_MAP_ALWAYS_PRESENT_TO;
8382 break;
8383 default:
8384 gfc_error ("TARGET ENTER DATA with map-type other "
8385 "than TO, TOFROM or ALLOC on MAP clause "
8386 "at %L", &n->where);
8387 break;
8388 }
8389 break;
8390 case EXEC_OMP_TARGET_EXIT_DATA:
8391 switch (n->u.map_op)
8392 {
8393 case OMP_MAP_FROM:
8394 case OMP_MAP_ALWAYS_FROM:
8395 case OMP_MAP_PRESENT_FROM:
8396 case OMP_MAP_ALWAYS_PRESENT_FROM:
8397 case OMP_MAP_RELEASE:
8398 case OMP_MAP_DELETE:
8399 break;
8400 case OMP_MAP_TOFROM:
8401 n->u.map_op = OMP_MAP_FROM;
8402 break;
8403 case OMP_MAP_ALWAYS_TOFROM:
8404 n->u.map_op = OMP_MAP_ALWAYS_FROM;
8405 break;
8406 case OMP_MAP_PRESENT_TOFROM:
8407 n->u.map_op = OMP_MAP_PRESENT_FROM;
8408 break;
8409 case OMP_MAP_ALWAYS_PRESENT_TOFROM:
8410 n->u.map_op = OMP_MAP_ALWAYS_PRESENT_FROM;
8411 break;
8412 default:
8413 gfc_error ("TARGET EXIT DATA with map-type other "
8414 "than FROM, TOFROM, RELEASE, or DELETE on "
8415 "MAP clause at %L", &n->where);
8416 break;
8417 }
8418 break;
8419 default:
8420 break;
8421 }
8422 }
8423
8424 if (list != OMP_LIST_DEPEND)
8425 for (n = omp_clauses->lists[list]; n != NULL; n = n->next)
8426 {
8427 n->sym->attr.referenced = 1;
8428 if (n->sym->attr.threadprivate)
8429 gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
8430 n->sym->name, name, &n->where);
8431 if (n->sym->attr.cray_pointee)
8432 gfc_error ("Cray pointee %qs in %s clause at %L",
8433 n->sym->name, name, &n->where);
8434 }
8435 break;
8436 case OMP_LIST_IS_DEVICE_PTR:
8437 last = NULL;
8438 for (n = omp_clauses->lists[list]; n != NULL; )
8439 {
8440 if (n->sym->ts.type == BT_DERIVED
8441 && n->sym->ts.u.derived->ts.is_iso_c
8442 && code->op != EXEC_OMP_TARGET)
8443 /* Non-TARGET (i.e. DISPATCH) requires a C_PTR. */
8444 gfc_error ("List item %qs in %s clause at %L must be of "
8445 "TYPE(C_PTR)", n->sym->name, name, &n->where);
8446 else if (n->sym->ts.type != BT_DERIVED
8447 || !n->sym->ts.u.derived->ts.is_iso_c)
8448 {
8449 /* For TARGET, non-C_PTR are deprecated and handled as
8450 has_device_addr. */
8451 gfc_omp_namelist *n2 = n;
8452 n = n->next;
8453 if (last)
8454 last->next = n;
8455 else
8456 omp_clauses->lists[list] = n;
8457 n2->next = omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR];
8458 omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR] = n2;
8459 continue;
8460 }
8461 last = n;
8462 n = n->next;
8463 }
8464 break;
8465 case OMP_LIST_HAS_DEVICE_ADDR:
8466 case OMP_LIST_USE_DEVICE_ADDR:
8467 break;
8468 case OMP_LIST_USE_DEVICE_PTR:
8469 /* Non-C_PTR are deprecated and handled as use_device_ADDR. */
8470 last = NULL;
8471 for (n = omp_clauses->lists[list]; n != NULL; )
8472 {
8473 gfc_omp_namelist *n2 = n;
8474 if (n->sym->ts.type != BT_DERIVED
8475 || !n->sym->ts.u.derived->ts.is_iso_c)
8476 {
8477 n = n->next;
8478 if (last)
8479 last->next = n;
8480 else
8481 omp_clauses->lists[list] = n;
8482 n2->next = omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR];
8483 omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] = n2;
8484 continue;
8485 }
8486 last = n;
8487 n = n->next;
8488 }
8489 break;
8490 case OMP_LIST_USES_ALLOCATORS:
8491 {
8492 if (n != NULL
8493 && n->u.memspace_sym
8494 && (n->u.memspace_sym->attr.flavor != FL_PARAMETER
8495 || n->u.memspace_sym->ts.type != BT_INTEGER
8496 || n->u.memspace_sym->ts.kind != gfc_c_intptr_kind
8497 || n->u.memspace_sym->attr.dimension
8498 || (!startswith (str: n->u.memspace_sym->name, prefix: "omp_")
8499 && !startswith (str: n->u.memspace_sym->name, prefix: "ompx_"))
8500 || !endswith (str: n->u.memspace_sym->name, suffix: "_mem_space")))
8501 gfc_error ("Memspace %qs at %L in USES_ALLOCATORS must be "
8502 "a predefined memory space",
8503 n->u.memspace_sym->name, &n->where);
8504 for (; n != NULL; n = n->next)
8505 {
8506 if (n->sym->ts.type != BT_INTEGER
8507 || n->sym->ts.kind != gfc_c_intptr_kind
8508 || n->sym->attr.dimension)
8509 gfc_error ("Allocator %qs at %L in USES_ALLOCATORS must "
8510 "be a scalar integer of kind "
8511 "%<omp_allocator_handle_kind%>", n->sym->name,
8512 &n->where);
8513 else if (n->sym->attr.flavor != FL_VARIABLE
8514 && ((!startswith (str: n->sym->name, prefix: "omp_")
8515 && !startswith (str: n->sym->name, prefix: "ompx_"))
8516 || !endswith (str: n->sym->name, suffix: "_mem_alloc")))
8517 gfc_error ("Allocator %qs at %L in USES_ALLOCATORS must "
8518 "either a variable or a predefined allocator",
8519 n->sym->name, &n->where);
8520 else if ((n->u.memspace_sym || n->u2.traits_sym)
8521 && n->sym->attr.flavor != FL_VARIABLE)
8522 gfc_error ("A memory space or traits array may not be "
8523 "specified for predefined allocator %qs at %L",
8524 n->sym->name, &n->where);
8525 if (n->u2.traits_sym
8526 && (n->u2.traits_sym->attr.flavor != FL_PARAMETER
8527 || !n->u2.traits_sym->attr.dimension
8528 || n->u2.traits_sym->as->rank != 1
8529 || n->u2.traits_sym->ts.type != BT_DERIVED
8530 || strcmp (s1: n->u2.traits_sym->ts.u.derived->name,
8531 s2: "omp_alloctrait") != 0))
8532 {
8533 gfc_error ("Traits array %qs in USES_ALLOCATORS %L must "
8534 "be a one-dimensional named constant array of "
8535 "type %<omp_alloctrait%>",
8536 n->u2.traits_sym->name, &n->where);
8537 break;
8538 }
8539 }
8540 break;
8541 }
8542 default:
8543 for (; n != NULL; n = n->next)
8544 {
8545 if (n->sym == NULL)
8546 {
8547 gcc_assert (code->op == EXEC_OMP_ALLOCATORS
8548 || code->op == EXEC_OMP_ALLOCATE);
8549 continue;
8550 }
8551 bool bad = false;
8552 bool is_reduction = (list == OMP_LIST_REDUCTION
8553 || list == OMP_LIST_REDUCTION_INSCAN
8554 || list == OMP_LIST_REDUCTION_TASK
8555 || list == OMP_LIST_IN_REDUCTION
8556 || list == OMP_LIST_TASK_REDUCTION);
8557 if (list == OMP_LIST_REDUCTION_INSCAN)
8558 has_inscan = true;
8559 else if (is_reduction)
8560 has_notinscan = true;
8561 if (has_inscan && has_notinscan && is_reduction)
8562 {
8563 gfc_error ("%<inscan%> and non-%<inscan%> %<reduction%> "
8564 "clauses on the same construct at %L",
8565 &n->where);
8566 break;
8567 }
8568 if (n->sym->attr.threadprivate)
8569 gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
8570 n->sym->name, name, &n->where);
8571 if (n->sym->attr.cray_pointee)
8572 gfc_error ("Cray pointee %qs in %s clause at %L",
8573 n->sym->name, name, &n->where);
8574 if (n->sym->attr.associate_var)
8575 gfc_error ("Associate name %qs in %s clause at %L",
8576 n->sym->attr.select_type_temporary
8577 ? n->sym->assoc->target->symtree->n.sym->name
8578 : n->sym->name, name, &n->where);
8579 if (list != OMP_LIST_PRIVATE && is_reduction)
8580 {
8581 if (n->sym->attr.proc_pointer)
8582 gfc_error ("Procedure pointer %qs in %s clause at %L",
8583 n->sym->name, name, &n->where);
8584 if (n->sym->attr.pointer)
8585 gfc_error ("POINTER object %qs in %s clause at %L",
8586 n->sym->name, name, &n->where);
8587 if (n->sym->attr.cray_pointer)
8588 gfc_error ("Cray pointer %qs in %s clause at %L",
8589 n->sym->name, name, &n->where);
8590 }
8591 if (code
8592 && (oacc_is_loop (code)
8593 || code->op == EXEC_OACC_PARALLEL
8594 || code->op == EXEC_OACC_SERIAL))
8595 check_array_not_assumed (sym: n->sym, loc: n->where, name);
8596 else if (list != OMP_LIST_UNIFORM
8597 && n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
8598 gfc_error ("Assumed size array %qs in %s clause at %L",
8599 n->sym->name, name, &n->where);
8600 if (n->sym->attr.in_namelist && !is_reduction)
8601 gfc_error ("Variable %qs in %s clause is used in "
8602 "NAMELIST statement at %L",
8603 n->sym->name, name, &n->where);
8604 if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
8605 switch (list)
8606 {
8607 case OMP_LIST_PRIVATE:
8608 case OMP_LIST_LASTPRIVATE:
8609 case OMP_LIST_LINEAR:
8610 /* case OMP_LIST_REDUCTION: */
8611 gfc_error ("INTENT(IN) POINTER %qs in %s clause at %L",
8612 n->sym->name, name, &n->where);
8613 break;
8614 default:
8615 break;
8616 }
8617 if (omp_clauses->detach
8618 && (list == OMP_LIST_PRIVATE
8619 || list == OMP_LIST_FIRSTPRIVATE
8620 || list == OMP_LIST_LASTPRIVATE)
8621 && n->sym == omp_clauses->detach->symtree->n.sym)
8622 gfc_error ("DETACH event handle %qs in %s clause at %L",
8623 n->sym->name, name, &n->where);
8624 switch (list)
8625 {
8626 case OMP_LIST_REDUCTION_TASK:
8627 if (code
8628 && (code->op == EXEC_OMP_LOOP
8629 || code->op == EXEC_OMP_TASKLOOP
8630 || code->op == EXEC_OMP_TASKLOOP_SIMD
8631 || code->op == EXEC_OMP_MASKED_TASKLOOP
8632 || code->op == EXEC_OMP_MASKED_TASKLOOP_SIMD
8633 || code->op == EXEC_OMP_MASTER_TASKLOOP
8634 || code->op == EXEC_OMP_MASTER_TASKLOOP_SIMD
8635 || code->op == EXEC_OMP_PARALLEL_LOOP
8636 || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP
8637 || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
8638 || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP
8639 || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
8640 || code->op == EXEC_OMP_TARGET_PARALLEL_LOOP
8641 || code->op == EXEC_OMP_TARGET_TEAMS_LOOP
8642 || code->op == EXEC_OMP_TEAMS
8643 || code->op == EXEC_OMP_TEAMS_DISTRIBUTE
8644 || code->op == EXEC_OMP_TEAMS_LOOP))
8645 {
8646 gfc_error ("Only DEFAULT permitted as reduction-"
8647 "modifier in REDUCTION clause at %L",
8648 &n->where);
8649 break;
8650 }
8651 gcc_fallthrough ();
8652 case OMP_LIST_REDUCTION:
8653 case OMP_LIST_IN_REDUCTION:
8654 case OMP_LIST_TASK_REDUCTION:
8655 case OMP_LIST_REDUCTION_INSCAN:
8656 switch (n->u.reduction_op)
8657 {
8658 case OMP_REDUCTION_PLUS:
8659 case OMP_REDUCTION_TIMES:
8660 case OMP_REDUCTION_MINUS:
8661 if (!gfc_numeric_ts (&n->sym->ts))
8662 bad = true;
8663 break;
8664 case OMP_REDUCTION_AND:
8665 case OMP_REDUCTION_OR:
8666 case OMP_REDUCTION_EQV:
8667 case OMP_REDUCTION_NEQV:
8668 if (n->sym->ts.type != BT_LOGICAL)
8669 bad = true;
8670 break;
8671 case OMP_REDUCTION_MAX:
8672 case OMP_REDUCTION_MIN:
8673 if (n->sym->ts.type != BT_INTEGER
8674 && n->sym->ts.type != BT_REAL)
8675 bad = true;
8676 break;
8677 case OMP_REDUCTION_IAND:
8678 case OMP_REDUCTION_IOR:
8679 case OMP_REDUCTION_IEOR:
8680 if (n->sym->ts.type != BT_INTEGER)
8681 bad = true;
8682 break;
8683 case OMP_REDUCTION_USER:
8684 bad = true;
8685 break;
8686 default:
8687 break;
8688 }
8689 if (!bad)
8690 n->u2.udr = NULL;
8691 else
8692 {
8693 const char *udr_name = NULL;
8694 if (n->u2.udr)
8695 {
8696 udr_name = n->u2.udr->udr->name;
8697 n->u2.udr->udr
8698 = gfc_find_omp_udr (NULL, name: udr_name,
8699 ts: &n->sym->ts);
8700 if (n->u2.udr->udr == NULL)
8701 {
8702 free (ptr: n->u2.udr);
8703 n->u2.udr = NULL;
8704 }
8705 }
8706 if (n->u2.udr == NULL)
8707 {
8708 if (udr_name == NULL)
8709 switch (n->u.reduction_op)
8710 {
8711 case OMP_REDUCTION_PLUS:
8712 case OMP_REDUCTION_TIMES:
8713 case OMP_REDUCTION_MINUS:
8714 case OMP_REDUCTION_AND:
8715 case OMP_REDUCTION_OR:
8716 case OMP_REDUCTION_EQV:
8717 case OMP_REDUCTION_NEQV:
8718 udr_name = gfc_op2string ((gfc_intrinsic_op)
8719 n->u.reduction_op);
8720 break;
8721 case OMP_REDUCTION_MAX:
8722 udr_name = "max";
8723 break;
8724 case OMP_REDUCTION_MIN:
8725 udr_name = "min";
8726 break;
8727 case OMP_REDUCTION_IAND:
8728 udr_name = "iand";
8729 break;
8730 case OMP_REDUCTION_IOR:
8731 udr_name = "ior";
8732 break;
8733 case OMP_REDUCTION_IEOR:
8734 udr_name = "ieor";
8735 break;
8736 default:
8737 gcc_unreachable ();
8738 }
8739 gfc_error ("!$OMP DECLARE REDUCTION %s not found "
8740 "for type %s at %L", udr_name,
8741 gfc_typename (&n->sym->ts), &n->where);
8742 }
8743 else
8744 {
8745 gfc_omp_udr *udr = n->u2.udr->udr;
8746 n->u.reduction_op = OMP_REDUCTION_USER;
8747 n->u2.udr->combiner
8748 = resolve_omp_udr_clause (n, ns: udr->combiner_ns,
8749 sym1: udr->omp_out,
8750 sym2: udr->omp_in);
8751 if (udr->initializer_ns)
8752 n->u2.udr->initializer
8753 = resolve_omp_udr_clause (n,
8754 ns: udr->initializer_ns,
8755 sym1: udr->omp_priv,
8756 sym2: udr->omp_orig);
8757 }
8758 }
8759 break;
8760 case OMP_LIST_LINEAR:
8761 if (code
8762 && n->u.linear.op != OMP_LINEAR_DEFAULT
8763 && n->u.linear.op != linear_op)
8764 {
8765 if (n->u.linear.old_modifier)
8766 {
8767 gfc_error ("LINEAR clause modifier used on DO or "
8768 "SIMD construct at %L", &n->where);
8769 linear_op = n->u.linear.op;
8770 }
8771 else if (n->u.linear.op != OMP_LINEAR_VAL)
8772 {
8773 gfc_error ("LINEAR clause modifier other than VAL "
8774 "used on DO or SIMD construct at %L",
8775 &n->where);
8776 linear_op = n->u.linear.op;
8777 }
8778 }
8779 else if (n->u.linear.op != OMP_LINEAR_REF
8780 && n->sym->ts.type != BT_INTEGER)
8781 gfc_error ("LINEAR variable %qs must be INTEGER "
8782 "at %L", n->sym->name, &n->where);
8783 else if ((n->u.linear.op == OMP_LINEAR_REF
8784 || n->u.linear.op == OMP_LINEAR_UVAL)
8785 && n->sym->attr.value)
8786 gfc_error ("LINEAR dummy argument %qs with VALUE "
8787 "attribute with %s modifier at %L",
8788 n->sym->name,
8789 n->u.linear.op == OMP_LINEAR_REF
8790 ? "REF" : "UVAL", &n->where);
8791 else if (n->expr)
8792 {
8793 gfc_expr *expr = n->expr;
8794 if (!gfc_resolve_expr (expr)
8795 || expr->ts.type != BT_INTEGER
8796 || expr->rank != 0)
8797 gfc_error ("%qs in LINEAR clause at %L requires "
8798 "a scalar integer linear-step expression",
8799 n->sym->name, &n->where);
8800 else if (!code && expr->expr_type != EXPR_CONSTANT)
8801 {
8802 if (expr->expr_type == EXPR_VARIABLE
8803 && expr->symtree->n.sym->attr.dummy
8804 && expr->symtree->n.sym->ns == ns)
8805 {
8806 gfc_omp_namelist *n2;
8807 for (n2 = omp_clauses->lists[OMP_LIST_UNIFORM];
8808 n2; n2 = n2->next)
8809 if (n2->sym == expr->symtree->n.sym)
8810 break;
8811 if (n2)
8812 break;
8813 }
8814 gfc_error ("%qs in LINEAR clause at %L requires "
8815 "a constant integer linear-step "
8816 "expression or dummy argument "
8817 "specified in UNIFORM clause",
8818 n->sym->name, &n->where);
8819 }
8820 }
8821 break;
8822 /* Workaround for PR middle-end/26316, nothing really needs
8823 to be done here for OMP_LIST_PRIVATE. */
8824 case OMP_LIST_PRIVATE:
8825 gcc_assert (code && code->op != EXEC_NOP);
8826 break;
8827 case OMP_LIST_USE_DEVICE:
8828 if (n->sym->attr.allocatable
8829 || (n->sym->ts.type == BT_CLASS && CLASS_DATA (n->sym)
8830 && CLASS_DATA (n->sym)->attr.allocatable))
8831 gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
8832 n->sym->name, name, &n->where);
8833 if (n->sym->ts.type == BT_CLASS
8834 && CLASS_DATA (n->sym)
8835 && CLASS_DATA (n->sym)->attr.class_pointer)
8836 gfc_error ("POINTER object %qs of polymorphic type in "
8837 "%s clause at %L", n->sym->name, name,
8838 &n->where);
8839 if (n->sym->attr.cray_pointer)
8840 gfc_error ("Cray pointer object %qs in %s clause at %L",
8841 n->sym->name, name, &n->where);
8842 else if (n->sym->attr.cray_pointee)
8843 gfc_error ("Cray pointee object %qs in %s clause at %L",
8844 n->sym->name, name, &n->where);
8845 else if (n->sym->attr.flavor == FL_VARIABLE
8846 && !n->sym->as
8847 && !n->sym->attr.pointer)
8848 gfc_error ("%s clause variable %qs at %L is neither "
8849 "a POINTER nor an array", name,
8850 n->sym->name, &n->where);
8851 /* FALLTHRU */
8852 case OMP_LIST_DEVICE_RESIDENT:
8853 check_symbol_not_pointer (sym: n->sym, loc: n->where, name);
8854 check_array_not_assumed (sym: n->sym, loc: n->where, name);
8855 break;
8856 default:
8857 break;
8858 }
8859 }
8860 break;
8861 }
8862 }
8863 /* OpenMP 5.1: use_device_ptr acts like use_device_addr, except for
8864 type(c_ptr). */
8865 if (omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR])
8866 {
8867 gfc_omp_namelist *n_prev, *n_next, *n_addr;
8868 n_addr = omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR];
8869 for (; n_addr && n_addr->next; n_addr = n_addr->next)
8870 ;
8871 n_prev = NULL;
8872 n = omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR];
8873 while (n)
8874 {
8875 n_next = n->next;
8876 if (n->sym->ts.type != BT_DERIVED
8877 || n->sym->ts.u.derived->ts.f90_type != BT_VOID)
8878 {
8879 n->next = NULL;
8880 if (n_addr)
8881 n_addr->next = n;
8882 else
8883 omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] = n;
8884 n_addr = n;
8885 if (n_prev)
8886 n_prev->next = n_next;
8887 else
8888 omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] = n_next;
8889 }
8890 else
8891 n_prev = n;
8892 n = n_next;
8893 }
8894 }
8895 if (omp_clauses->safelen_expr)
8896 resolve_positive_int_expr (expr: omp_clauses->safelen_expr, clause: "SAFELEN");
8897 if (omp_clauses->simdlen_expr)
8898 resolve_positive_int_expr (expr: omp_clauses->simdlen_expr, clause: "SIMDLEN");
8899 if (omp_clauses->num_teams_lower)
8900 resolve_positive_int_expr (expr: omp_clauses->num_teams_lower, clause: "NUM_TEAMS");
8901 if (omp_clauses->num_teams_upper)
8902 resolve_positive_int_expr (expr: omp_clauses->num_teams_upper, clause: "NUM_TEAMS");
8903 if (omp_clauses->num_teams_lower
8904 && omp_clauses->num_teams_lower->expr_type == EXPR_CONSTANT
8905 && omp_clauses->num_teams_upper->expr_type == EXPR_CONSTANT
8906 && mpz_cmp (omp_clauses->num_teams_lower->value.integer,
8907 omp_clauses->num_teams_upper->value.integer) > 0)
8908 gfc_warning (opt: 0, "NUM_TEAMS lower bound at %L larger than upper bound at %L",
8909 &omp_clauses->num_teams_lower->where,
8910 &omp_clauses->num_teams_upper->where);
8911 if (omp_clauses->device)
8912 resolve_scalar_int_expr (expr: omp_clauses->device, clause: "DEVICE");
8913 if (omp_clauses->filter)
8914 resolve_nonnegative_int_expr (expr: omp_clauses->filter, clause: "FILTER");
8915 if (omp_clauses->hint)
8916 {
8917 resolve_scalar_int_expr (expr: omp_clauses->hint, clause: "HINT");
8918 if (omp_clauses->hint->ts.type != BT_INTEGER
8919 || omp_clauses->hint->expr_type != EXPR_CONSTANT
8920 || mpz_sgn (omp_clauses->hint->value.integer) < 0)
8921 gfc_error ("Value of HINT clause at %L shall be a valid "
8922 "constant hint expression", &omp_clauses->hint->where);
8923 }
8924 if (omp_clauses->priority)
8925 resolve_nonnegative_int_expr (expr: omp_clauses->priority, clause: "PRIORITY");
8926 if (omp_clauses->dist_chunk_size)
8927 {
8928 gfc_expr *expr = omp_clauses->dist_chunk_size;
8929 if (!gfc_resolve_expr (expr)
8930 || expr->ts.type != BT_INTEGER || expr->rank != 0)
8931 gfc_error ("DIST_SCHEDULE clause's chunk_size at %L requires "
8932 "a scalar INTEGER expression", &expr->where);
8933 }
8934 if (omp_clauses->thread_limit)
8935 resolve_positive_int_expr (expr: omp_clauses->thread_limit, clause: "THREAD_LIMIT");
8936 if (omp_clauses->grainsize)
8937 resolve_positive_int_expr (expr: omp_clauses->grainsize, clause: "GRAINSIZE");
8938 if (omp_clauses->num_tasks)
8939 resolve_positive_int_expr (expr: omp_clauses->num_tasks, clause: "NUM_TASKS");
8940 if (omp_clauses->async)
8941 if (omp_clauses->async_expr)
8942 resolve_scalar_int_expr (expr: omp_clauses->async_expr, clause: "ASYNC");
8943 if (omp_clauses->num_gangs_expr)
8944 resolve_positive_int_expr (expr: omp_clauses->num_gangs_expr, clause: "NUM_GANGS");
8945 if (omp_clauses->num_workers_expr)
8946 resolve_positive_int_expr (expr: omp_clauses->num_workers_expr, clause: "NUM_WORKERS");
8947 if (omp_clauses->vector_length_expr)
8948 resolve_positive_int_expr (expr: omp_clauses->vector_length_expr,
8949 clause: "VECTOR_LENGTH");
8950 if (omp_clauses->gang_num_expr)
8951 resolve_positive_int_expr (expr: omp_clauses->gang_num_expr, clause: "GANG");
8952 if (omp_clauses->gang_static_expr)
8953 resolve_positive_int_expr (expr: omp_clauses->gang_static_expr, clause: "GANG");
8954 if (omp_clauses->worker_expr)
8955 resolve_positive_int_expr (expr: omp_clauses->worker_expr, clause: "WORKER");
8956 if (omp_clauses->vector_expr)
8957 resolve_positive_int_expr (expr: omp_clauses->vector_expr, clause: "VECTOR");
8958 for (el = omp_clauses->wait_list; el; el = el->next)
8959 resolve_scalar_int_expr (expr: el->expr, clause: "WAIT");
8960 if (omp_clauses->collapse && omp_clauses->tile_list)
8961 gfc_error ("Incompatible use of TILE and COLLAPSE at %L", &code->loc);
8962 if (omp_clauses->message)
8963 {
8964 gfc_expr *expr = omp_clauses->message;
8965 if (!gfc_resolve_expr (expr)
8966 || expr->ts.kind != gfc_default_character_kind
8967 || expr->ts.type != BT_CHARACTER || expr->rank != 0)
8968 gfc_error ("MESSAGE clause at %L requires a scalar default-kind "
8969 "CHARACTER expression", &expr->where);
8970 }
8971 if (!openacc
8972 && code
8973 && omp_clauses->lists[OMP_LIST_MAP] == NULL
8974 && omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] == NULL
8975 && omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] == NULL)
8976 {
8977 const char *p = NULL;
8978 switch (code->op)
8979 {
8980 case EXEC_OMP_TARGET_ENTER_DATA: p = "TARGET ENTER DATA"; break;
8981 case EXEC_OMP_TARGET_EXIT_DATA: p = "TARGET EXIT DATA"; break;
8982 default: break;
8983 }
8984 if (code->op == EXEC_OMP_TARGET_DATA)
8985 gfc_error ("TARGET DATA must contain at least one MAP, USE_DEVICE_PTR, "
8986 "or USE_DEVICE_ADDR clause at %L", &code->loc);
8987 else if (p)
8988 gfc_error ("%s must contain at least one MAP clause at %L",
8989 p, &code->loc);
8990 }
8991
8992 if (!openacc && omp_clauses->detach)
8993 {
8994 if (!gfc_resolve_expr (omp_clauses->detach)
8995 || omp_clauses->detach->ts.type != BT_INTEGER
8996 || omp_clauses->detach->ts.kind != gfc_c_intptr_kind
8997 || omp_clauses->detach->rank != 0)
8998 gfc_error ("%qs at %L should be a scalar of type "
8999 "integer(kind=omp_event_handle_kind)",
9000 omp_clauses->detach->symtree->n.sym->name,
9001 &omp_clauses->detach->where);
9002 else if (omp_clauses->detach->symtree->n.sym->attr.dimension > 0)
9003 gfc_error ("The event handle at %L must not be an array element",
9004 &omp_clauses->detach->where);
9005 else if (omp_clauses->detach->symtree->n.sym->ts.type == BT_DERIVED
9006 || omp_clauses->detach->symtree->n.sym->ts.type == BT_CLASS)
9007 gfc_error ("The event handle at %L must not be part of "
9008 "a derived type or class", &omp_clauses->detach->where);
9009
9010 if (omp_clauses->mergeable)
9011 gfc_error ("%<DETACH%> clause at %L must not be used together with "
9012 "%<MERGEABLE%> clause", &omp_clauses->detach->where);
9013 }
9014
9015 if (openacc
9016 && code->op == EXEC_OACC_HOST_DATA
9017 && omp_clauses->lists[OMP_LIST_USE_DEVICE] == NULL)
9018 gfc_error ("%<host_data%> construct at %L requires %<use_device%> clause",
9019 &code->loc);
9020
9021 if (omp_clauses->assume)
9022 gfc_resolve_omp_assumptions (assume: omp_clauses->assume);
9023}
9024
9025
9026/* Return true if SYM is ever referenced in EXPR except in the SE node. */
9027
9028static bool
9029expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
9030{
9031 gfc_actual_arglist *arg;
9032 if (e == NULL || e == se)
9033 return false;
9034 switch (e->expr_type)
9035 {
9036 case EXPR_CONSTANT:
9037 case EXPR_NULL:
9038 case EXPR_VARIABLE:
9039 case EXPR_STRUCTURE:
9040 case EXPR_ARRAY:
9041 if (e->symtree != NULL
9042 && e->symtree->n.sym == s)
9043 return true;
9044 return false;
9045 case EXPR_SUBSTRING:
9046 if (e->ref != NULL
9047 && (expr_references_sym (e: e->ref->u.ss.start, s, se)
9048 || expr_references_sym (e: e->ref->u.ss.end, s, se)))
9049 return true;
9050 return false;
9051 case EXPR_OP:
9052 if (expr_references_sym (e: e->value.op.op2, s, se))
9053 return true;
9054 return expr_references_sym (e: e->value.op.op1, s, se);
9055 case EXPR_FUNCTION:
9056 for (arg = e->value.function.actual; arg; arg = arg->next)
9057 if (expr_references_sym (e: arg->expr, s, se))
9058 return true;
9059 return false;
9060 default:
9061 gcc_unreachable ();
9062 }
9063}
9064
9065
9066/* If EXPR is a conversion function that widens the type
9067 if WIDENING is true or narrows the type if NARROW is true,
9068 return the inner expression, otherwise return NULL. */
9069
9070static gfc_expr *
9071is_conversion (gfc_expr *expr, bool narrowing, bool widening)
9072{
9073 gfc_typespec *ts1, *ts2;
9074
9075 if (expr->expr_type != EXPR_FUNCTION
9076 || expr->value.function.isym == NULL
9077 || expr->value.function.esym != NULL
9078 || expr->value.function.isym->id != GFC_ISYM_CONVERSION
9079 || (!narrowing && !widening))
9080 return NULL;
9081
9082 if (narrowing && widening)
9083 return expr->value.function.actual->expr;
9084
9085 if (widening)
9086 {
9087 ts1 = &expr->ts;
9088 ts2 = &expr->value.function.actual->expr->ts;
9089 }
9090 else
9091 {
9092 ts1 = &expr->value.function.actual->expr->ts;
9093 ts2 = &expr->ts;
9094 }
9095
9096 if (ts1->type > ts2->type
9097 || (ts1->type == ts2->type && ts1->kind > ts2->kind))
9098 return expr->value.function.actual->expr;
9099
9100 return NULL;
9101}
9102
9103static bool
9104is_scalar_intrinsic_expr (gfc_expr *expr, bool must_be_var, bool conv_ok)
9105{
9106 if (must_be_var
9107 && (expr->expr_type != EXPR_VARIABLE || !expr->symtree))
9108 {
9109 if (!conv_ok)
9110 return false;
9111 gfc_expr *conv = is_conversion (expr, narrowing: true, widening: true);
9112 if (!conv)
9113 return false;
9114 if (conv->expr_type != EXPR_VARIABLE || !conv->symtree)
9115 return false;
9116 }
9117 return (expr->rank == 0
9118 && !gfc_is_coindexed (expr)
9119 && (expr->ts.type == BT_INTEGER
9120 || expr->ts.type == BT_REAL
9121 || expr->ts.type == BT_COMPLEX
9122 || expr->ts.type == BT_LOGICAL));
9123}
9124
9125static void
9126resolve_omp_atomic (gfc_code *code)
9127{
9128 gfc_code *atomic_code = code->block;
9129 gfc_symbol *var;
9130 gfc_expr *stmt_expr2, *capt_expr2;
9131 gfc_omp_atomic_op aop
9132 = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op
9133 & GFC_OMP_ATOMIC_MASK);
9134 gfc_code *stmt = NULL, *capture_stmt = NULL, *tailing_stmt = NULL;
9135 gfc_expr *comp_cond = NULL;
9136 locus *loc = NULL;
9137
9138 code = code->block->next;
9139 /* resolve_blocks asserts this is initially EXEC_ASSIGN or EXEC_IF
9140 If it changed to EXEC_NOP, assume an error has been emitted already. */
9141 if (code->op == EXEC_NOP)
9142 return;
9143
9144 if (atomic_code->ext.omp_clauses->compare
9145 && atomic_code->ext.omp_clauses->capture)
9146 {
9147 /* Must be either "if (x == e) then; x = d; else; v = x; end if"
9148 or "v = expr" followed/preceded by
9149 "if (x == e) then; x = d; end if" or "if (x == e) x = d". */
9150 gfc_code *next = code;
9151 if (code->op == EXEC_ASSIGN)
9152 {
9153 capture_stmt = code;
9154 next = code->next;
9155 }
9156 if (next->op == EXEC_IF
9157 && next->block
9158 && next->block->op == EXEC_IF
9159 && next->block->next
9160 && next->block->next->op == EXEC_ASSIGN)
9161 {
9162 comp_cond = next->block->expr1;
9163 stmt = next->block->next;
9164 if (stmt->next)
9165 {
9166 loc = &stmt->loc;
9167 goto unexpected;
9168 }
9169 }
9170 else if (capture_stmt)
9171 {
9172 gfc_error ("Expected IF at %L in atomic compare capture",
9173 &next->loc);
9174 return;
9175 }
9176 if (stmt && !capture_stmt && next->block->block)
9177 {
9178 if (next->block->block->expr1)
9179 {
9180 gfc_error ("Expected ELSE at %L in atomic compare capture",
9181 &next->block->block->expr1->where);
9182 return;
9183 }
9184 if (!code->block->block->next
9185 || code->block->block->next->op != EXEC_ASSIGN)
9186 {
9187 loc = (code->block->block->next ? &code->block->block->next->loc
9188 : &code->block->block->loc);
9189 goto unexpected;
9190 }
9191 capture_stmt = code->block->block->next;
9192 if (capture_stmt->next)
9193 {
9194 loc = &capture_stmt->next->loc;
9195 goto unexpected;
9196 }
9197 }
9198 if (stmt && !capture_stmt && next->next->op == EXEC_ASSIGN)
9199 capture_stmt = next->next;
9200 else if (!capture_stmt)
9201 {
9202 loc = &code->loc;
9203 goto unexpected;
9204 }
9205 }
9206 else if (atomic_code->ext.omp_clauses->compare)
9207 {
9208 /* Must be: "if (x == e) then; x = d; end if" or "if (x == e) x = d". */
9209 if (code->op == EXEC_IF
9210 && code->block
9211 && code->block->op == EXEC_IF
9212 && code->block->next
9213 && code->block->next->op == EXEC_ASSIGN)
9214 {
9215 comp_cond = code->block->expr1;
9216 stmt = code->block->next;
9217 if (stmt->next || code->block->block)
9218 {
9219 loc = stmt->next ? &stmt->next->loc : &code->block->block->loc;
9220 goto unexpected;
9221 }
9222 }
9223 else
9224 {
9225 loc = &code->loc;
9226 goto unexpected;
9227 }
9228 }
9229 else if (atomic_code->ext.omp_clauses->capture)
9230 {
9231 /* Must be: "v = x" followed/preceded by "x = ...". */
9232 if (code->op != EXEC_ASSIGN)
9233 goto unexpected;
9234 if (code->next->op != EXEC_ASSIGN)
9235 {
9236 loc = &code->next->loc;
9237 goto unexpected;
9238 }
9239 gfc_expr *expr2, *expr2_next;
9240 expr2 = is_conversion (expr: code->expr2, narrowing: true, widening: true);
9241 if (expr2 == NULL)
9242 expr2 = code->expr2;
9243 expr2_next = is_conversion (expr: code->next->expr2, narrowing: true, widening: true);
9244 if (expr2_next == NULL)
9245 expr2_next = code->next->expr2;
9246 if (code->expr1->expr_type == EXPR_VARIABLE
9247 && code->next->expr1->expr_type == EXPR_VARIABLE
9248 && expr2->expr_type == EXPR_VARIABLE
9249 && expr2_next->expr_type == EXPR_VARIABLE)
9250 {
9251 if (code->expr1->symtree->n.sym == expr2_next->symtree->n.sym)
9252 {
9253 stmt = code;
9254 capture_stmt = code->next;
9255 }
9256 else
9257 {
9258 capture_stmt = code;
9259 stmt = code->next;
9260 }
9261 }
9262 else if (expr2->expr_type == EXPR_VARIABLE)
9263 {
9264 capture_stmt = code;
9265 stmt = code->next;
9266 }
9267 else
9268 {
9269 stmt = code;
9270 capture_stmt = code->next;
9271 }
9272 /* Shall be NULL but can happen for invalid code. */
9273 tailing_stmt = code->next->next;
9274 }
9275 else
9276 {
9277 /* x = ... */
9278 stmt = code;
9279 if (!atomic_code->ext.omp_clauses->compare && stmt->op != EXEC_ASSIGN)
9280 goto unexpected;
9281 /* Shall be NULL but can happen for invalid code. */
9282 tailing_stmt = code->next;
9283 }
9284
9285 if (comp_cond)
9286 {
9287 if (comp_cond->expr_type != EXPR_OP
9288 || (comp_cond->value.op.op != INTRINSIC_EQ
9289 && comp_cond->value.op.op != INTRINSIC_EQ_OS
9290 && comp_cond->value.op.op != INTRINSIC_EQV))
9291 {
9292 gfc_error ("Expected %<==%>, %<.EQ.%> or %<.EQV.%> atomic comparison "
9293 "expression at %L", &comp_cond->where);
9294 return;
9295 }
9296 if (!is_scalar_intrinsic_expr (expr: comp_cond->value.op.op1, must_be_var: true, conv_ok: true))
9297 {
9298 gfc_error ("Expected scalar intrinsic variable at %L in atomic "
9299 "comparison", &comp_cond->value.op.op1->where);
9300 return;
9301 }
9302 if (!gfc_resolve_expr (comp_cond->value.op.op2))
9303 return;
9304 if (!is_scalar_intrinsic_expr (expr: comp_cond->value.op.op2, must_be_var: false, conv_ok: false))
9305 {
9306 gfc_error ("Expected scalar intrinsic expression at %L in atomic "
9307 "comparison", &comp_cond->value.op.op1->where);
9308 return;
9309 }
9310 }
9311
9312 if (!is_scalar_intrinsic_expr (expr: stmt->expr1, must_be_var: true, conv_ok: false))
9313 {
9314 gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
9315 "intrinsic type at %L", &stmt->expr1->where);
9316 return;
9317 }
9318
9319 if (!gfc_resolve_expr (stmt->expr2))
9320 return;
9321 if (!is_scalar_intrinsic_expr (expr: stmt->expr2, must_be_var: false, conv_ok: false))
9322 {
9323 gfc_error ("!$OMP ATOMIC statement must assign an expression of "
9324 "intrinsic type at %L", &stmt->expr2->where);
9325 return;
9326 }
9327
9328 if (gfc_expr_attr (stmt->expr1).allocatable)
9329 {
9330 gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L",
9331 &stmt->expr1->where);
9332 return;
9333 }
9334
9335 /* Should be diagnosed above already. */
9336 gcc_assert (tailing_stmt == NULL);
9337
9338 var = stmt->expr1->symtree->n.sym;
9339 stmt_expr2 = is_conversion (expr: stmt->expr2, narrowing: true, widening: true);
9340 if (stmt_expr2 == NULL)
9341 stmt_expr2 = stmt->expr2;
9342
9343 switch (aop)
9344 {
9345 case GFC_OMP_ATOMIC_READ:
9346 if (stmt_expr2->expr_type != EXPR_VARIABLE)
9347 gfc_error ("!$OMP ATOMIC READ statement must read from a scalar "
9348 "variable of intrinsic type at %L", &stmt_expr2->where);
9349 return;
9350 case GFC_OMP_ATOMIC_WRITE:
9351 if (expr_references_sym (e: stmt_expr2, s: var, NULL))
9352 gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr "
9353 "must be scalar and cannot reference var at %L",
9354 &stmt_expr2->where);
9355 return;
9356 default:
9357 break;
9358 }
9359
9360 if (atomic_code->ext.omp_clauses->capture)
9361 {
9362 if (!is_scalar_intrinsic_expr (expr: capture_stmt->expr1, must_be_var: true, conv_ok: false))
9363 {
9364 gfc_error ("!$OMP ATOMIC capture-statement must set a scalar "
9365 "variable of intrinsic type at %L",
9366 &capture_stmt->expr1->where);
9367 return;
9368 }
9369
9370 if (!is_scalar_intrinsic_expr (expr: capture_stmt->expr2, must_be_var: true, conv_ok: true))
9371 {
9372 gfc_error ("!$OMP ATOMIC capture-statement requires a scalar variable"
9373 " of intrinsic type at %L", &capture_stmt->expr2->where);
9374 return;
9375 }
9376 capt_expr2 = is_conversion (expr: capture_stmt->expr2, narrowing: true, widening: true);
9377 if (capt_expr2 == NULL)
9378 capt_expr2 = capture_stmt->expr2;
9379
9380 if (capt_expr2->symtree->n.sym != var)
9381 {
9382 gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
9383 "different variable than update statement writes "
9384 "into at %L", &capture_stmt->expr2->where);
9385 return;
9386 }
9387 }
9388
9389 if (atomic_code->ext.omp_clauses->compare)
9390 {
9391 gfc_expr *var_expr;
9392 if (comp_cond->value.op.op1->expr_type == EXPR_VARIABLE)
9393 var_expr = comp_cond->value.op.op1;
9394 else
9395 var_expr = comp_cond->value.op.op1->value.function.actual->expr;
9396 if (var_expr->symtree->n.sym != var)
9397 {
9398 gfc_error ("For !$OMP ATOMIC COMPARE, the first operand in comparison"
9399 " at %L must be the variable %qs that the update statement"
9400 " writes into at %L", &var_expr->where, var->name,
9401 &stmt->expr1->where);
9402 return;
9403 }
9404 if (stmt_expr2->rank != 0 || expr_references_sym (e: stmt_expr2, s: var, NULL))
9405 {
9406 gfc_error ("expr in !$OMP ATOMIC COMPARE assignment var = expr "
9407 "must be scalar and cannot reference var at %L",
9408 &stmt_expr2->where);
9409 return;
9410 }
9411 }
9412 else if (atomic_code->ext.omp_clauses->capture
9413 && !expr_references_sym (e: stmt_expr2, s: var, NULL))
9414 atomic_code->ext.omp_clauses->atomic_op
9415 = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op
9416 | GFC_OMP_ATOMIC_SWAP);
9417 else if (stmt_expr2->expr_type == EXPR_OP)
9418 {
9419 gfc_expr *v = NULL, *e, *c;
9420 gfc_intrinsic_op op = stmt_expr2->value.op.op;
9421 gfc_intrinsic_op alt_op = INTRINSIC_NONE;
9422
9423 if (atomic_code->ext.omp_clauses->fail != OMP_MEMORDER_UNSET)
9424 gfc_error ("!$OMP ATOMIC UPDATE at %L with FAIL clause requiries either"
9425 " the COMPARE clause or using the intrinsic MIN/MAX "
9426 "procedure", &atomic_code->loc);
9427 switch (op)
9428 {
9429 case INTRINSIC_PLUS:
9430 alt_op = INTRINSIC_MINUS;
9431 break;
9432 case INTRINSIC_TIMES:
9433 alt_op = INTRINSIC_DIVIDE;
9434 break;
9435 case INTRINSIC_MINUS:
9436 alt_op = INTRINSIC_PLUS;
9437 break;
9438 case INTRINSIC_DIVIDE:
9439 alt_op = INTRINSIC_TIMES;
9440 break;
9441 case INTRINSIC_AND:
9442 case INTRINSIC_OR:
9443 break;
9444 case INTRINSIC_EQV:
9445 alt_op = INTRINSIC_NEQV;
9446 break;
9447 case INTRINSIC_NEQV:
9448 alt_op = INTRINSIC_EQV;
9449 break;
9450 default:
9451 gfc_error ("!$OMP ATOMIC assignment operator must be binary "
9452 "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
9453 &stmt_expr2->where);
9454 return;
9455 }
9456
9457 /* Check for var = var op expr resp. var = expr op var where
9458 expr doesn't reference var and var op expr is mathematically
9459 equivalent to var op (expr) resp. expr op var equivalent to
9460 (expr) op var. We rely here on the fact that the matcher
9461 for x op1 y op2 z where op1 and op2 have equal precedence
9462 returns (x op1 y) op2 z. */
9463 e = stmt_expr2->value.op.op2;
9464 if (e->expr_type == EXPR_VARIABLE
9465 && e->symtree != NULL
9466 && e->symtree->n.sym == var)
9467 v = e;
9468 else if ((c = is_conversion (expr: e, narrowing: false, widening: true)) != NULL
9469 && c->expr_type == EXPR_VARIABLE
9470 && c->symtree != NULL
9471 && c->symtree->n.sym == var)
9472 v = c;
9473 else
9474 {
9475 gfc_expr **p = NULL, **q;
9476 for (q = &stmt_expr2->value.op.op1; (e = *q) != NULL; )
9477 if (e->expr_type == EXPR_VARIABLE
9478 && e->symtree != NULL
9479 && e->symtree->n.sym == var)
9480 {
9481 v = e;
9482 break;
9483 }
9484 else if ((c = is_conversion (expr: e, narrowing: false, widening: true)) != NULL)
9485 q = &e->value.function.actual->expr;
9486 else if (e->expr_type != EXPR_OP
9487 || (e->value.op.op != op
9488 && e->value.op.op != alt_op)
9489 || e->rank != 0)
9490 break;
9491 else
9492 {
9493 p = q;
9494 q = &e->value.op.op1;
9495 }
9496
9497 if (v == NULL)
9498 {
9499 gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
9500 "or var = expr op var at %L", &stmt_expr2->where);
9501 return;
9502 }
9503
9504 if (p != NULL)
9505 {
9506 e = *p;
9507 switch (e->value.op.op)
9508 {
9509 case INTRINSIC_MINUS:
9510 case INTRINSIC_DIVIDE:
9511 case INTRINSIC_EQV:
9512 case INTRINSIC_NEQV:
9513 gfc_error ("!$OMP ATOMIC var = var op expr not "
9514 "mathematically equivalent to var = var op "
9515 "(expr) at %L", &stmt_expr2->where);
9516 break;
9517 default:
9518 break;
9519 }
9520
9521 /* Canonicalize into var = var op (expr). */
9522 *p = e->value.op.op2;
9523 e->value.op.op2 = stmt_expr2;
9524 e->ts = stmt_expr2->ts;
9525 if (stmt->expr2 == stmt_expr2)
9526 stmt->expr2 = stmt_expr2 = e;
9527 else
9528 stmt->expr2->value.function.actual->expr = stmt_expr2 = e;
9529
9530 if (!gfc_compare_types (&stmt_expr2->value.op.op1->ts,
9531 &stmt_expr2->ts))
9532 {
9533 for (p = &stmt_expr2->value.op.op1; *p != v;
9534 p = &(*p)->value.function.actual->expr)
9535 ;
9536 *p = NULL;
9537 gfc_free_expr (stmt_expr2->value.op.op1);
9538 stmt_expr2->value.op.op1 = v;
9539 gfc_convert_type (v, &stmt_expr2->ts, 2);
9540 }
9541 }
9542 }
9543
9544 if (e->rank != 0 || expr_references_sym (e: stmt->expr2, s: var, se: v))
9545 {
9546 gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
9547 "must be scalar and cannot reference var at %L",
9548 &stmt_expr2->where);
9549 return;
9550 }
9551 }
9552 else if (stmt_expr2->expr_type == EXPR_FUNCTION
9553 && stmt_expr2->value.function.isym != NULL
9554 && stmt_expr2->value.function.esym == NULL
9555 && stmt_expr2->value.function.actual != NULL
9556 && stmt_expr2->value.function.actual->next != NULL)
9557 {
9558 gfc_actual_arglist *arg, *var_arg;
9559
9560 switch (stmt_expr2->value.function.isym->id)
9561 {
9562 case GFC_ISYM_MIN:
9563 case GFC_ISYM_MAX:
9564 break;
9565 case GFC_ISYM_IAND:
9566 case GFC_ISYM_IOR:
9567 case GFC_ISYM_IEOR:
9568 if (stmt_expr2->value.function.actual->next->next != NULL)
9569 {
9570 gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
9571 "or IEOR must have two arguments at %L",
9572 &stmt_expr2->where);
9573 return;
9574 }
9575 break;
9576 default:
9577 gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
9578 "MIN, MAX, IAND, IOR or IEOR at %L",
9579 &stmt_expr2->where);
9580 return;
9581 }
9582
9583 var_arg = NULL;
9584 for (arg = stmt_expr2->value.function.actual; arg; arg = arg->next)
9585 {
9586 gfc_expr *e = NULL;
9587 if (arg == stmt_expr2->value.function.actual
9588 || (var_arg == NULL && arg->next == NULL))
9589 {
9590 e = is_conversion (expr: arg->expr, narrowing: false, widening: true);
9591 if (!e)
9592 e = arg->expr;
9593 if (e->expr_type == EXPR_VARIABLE
9594 && e->symtree != NULL
9595 && e->symtree->n.sym == var)
9596 var_arg = arg;
9597 }
9598 if ((!var_arg || !e) && expr_references_sym (e: arg->expr, s: var, NULL))
9599 {
9600 gfc_error ("!$OMP ATOMIC intrinsic arguments except one must "
9601 "not reference %qs at %L",
9602 var->name, &arg->expr->where);
9603 return;
9604 }
9605 if (arg->expr->rank != 0)
9606 {
9607 gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
9608 "at %L", &arg->expr->where);
9609 return;
9610 }
9611 }
9612
9613 if (var_arg == NULL)
9614 {
9615 gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
9616 "be %qs at %L", var->name, &stmt_expr2->where);
9617 return;
9618 }
9619
9620 if (var_arg != stmt_expr2->value.function.actual)
9621 {
9622 /* Canonicalize, so that var comes first. */
9623 gcc_assert (var_arg->next == NULL);
9624 for (arg = stmt_expr2->value.function.actual;
9625 arg->next != var_arg; arg = arg->next)
9626 ;
9627 var_arg->next = stmt_expr2->value.function.actual;
9628 stmt_expr2->value.function.actual = var_arg;
9629 arg->next = NULL;
9630 }
9631 }
9632 else
9633 gfc_error ("!$OMP ATOMIC assignment must have an operator or "
9634 "intrinsic on right hand side at %L", &stmt_expr2->where);
9635 return;
9636
9637unexpected:
9638 gfc_error ("unexpected !$OMP ATOMIC expression at %L",
9639 loc ? loc : &code->loc);
9640 return;
9641}
9642
9643
9644static struct fortran_omp_context
9645{
9646 gfc_code *code;
9647 hash_set<gfc_symbol *> *sharing_clauses;
9648 hash_set<gfc_symbol *> *private_iterators;
9649 struct fortran_omp_context *previous;
9650 bool is_openmp;
9651} *omp_current_ctx;
9652static gfc_code *omp_current_do_code;
9653static int omp_current_do_collapse;
9654
9655/* Forward declaration for mutually recursive functions. */
9656static gfc_code *
9657find_nested_loop_in_block (gfc_code *block);
9658
9659/* Return the first nested DO loop in CHAIN, or NULL if there
9660 isn't one. Does no error checking on intervening code. */
9661
9662static gfc_code *
9663find_nested_loop_in_chain (gfc_code *chain)
9664{
9665 gfc_code *code;
9666
9667 if (!chain)
9668 return NULL;
9669
9670 for (code = chain; code; code = code->next)
9671 {
9672 if (code->op == EXEC_DO)
9673 return code;
9674 else if (code->op == EXEC_BLOCK)
9675 {
9676 gfc_code *c = find_nested_loop_in_block (block: code);
9677 if (c)
9678 return c;
9679 }
9680 }
9681 return NULL;
9682}
9683
9684/* Return the first nested DO loop in BLOCK, or NULL if there
9685 isn't one. Does no error checking on intervening code. */
9686static gfc_code *
9687find_nested_loop_in_block (gfc_code *block)
9688{
9689 gfc_namespace *ns;
9690 gcc_assert (block->op == EXEC_BLOCK);
9691 ns = block->ext.block.ns;
9692 gcc_assert (ns);
9693 return find_nested_loop_in_chain (chain: ns->code);
9694}
9695
9696void
9697gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
9698{
9699 if (code->block->next && code->block->next->op == EXEC_DO)
9700 {
9701 int i;
9702
9703 omp_current_do_code = code->block->next;
9704 if (code->ext.omp_clauses->orderedc)
9705 omp_current_do_collapse = code->ext.omp_clauses->orderedc;
9706 else if (code->ext.omp_clauses->collapse)
9707 omp_current_do_collapse = code->ext.omp_clauses->collapse;
9708 else
9709 omp_current_do_collapse = 1;
9710 if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
9711 {
9712 /* Checking that there is a matching EXEC_OMP_SCAN in the
9713 innermost body cannot be deferred to resolve_omp_do because
9714 we process directives nested in the loop before we get
9715 there. */
9716 locus *loc
9717 = &code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where;
9718 gfc_code *c;
9719
9720 for (i = 1, c = omp_current_do_code;
9721 i < omp_current_do_collapse; i++)
9722 {
9723 c = find_nested_loop_in_chain (chain: c->block->next);
9724 if (!c || c->op != EXEC_DO || c->block == NULL)
9725 break;
9726 }
9727
9728 /* Skip this if we don't have enough nested loops. That
9729 problem will be diagnosed elsewhere. */
9730 if (c && c->op == EXEC_DO)
9731 {
9732 gfc_code *block = c->block ? c->block->next : NULL;
9733 if (block && block->op != EXEC_OMP_SCAN)
9734 while (block && block->next
9735 && block->next->op != EXEC_OMP_SCAN)
9736 block = block->next;
9737 if (!block
9738 || (block->op != EXEC_OMP_SCAN
9739 && (!block->next || block->next->op != EXEC_OMP_SCAN)))
9740 gfc_error ("With INSCAN at %L, expected loop body with "
9741 "!$OMP SCAN between two "
9742 "structured block sequences", loc);
9743 else
9744 {
9745 if (block->op == EXEC_OMP_SCAN)
9746 gfc_warning (opt: 0, "!$OMP SCAN at %L with zero executable "
9747 "statements in preceding structured block "
9748 "sequence", &block->loc);
9749 if ((block->op == EXEC_OMP_SCAN && !block->next)
9750 || (block->next && block->next->op == EXEC_OMP_SCAN
9751 && !block->next->next))
9752 gfc_warning (opt: 0, "!$OMP SCAN at %L with zero executable "
9753 "statements in succeeding structured block "
9754 "sequence", block->op == EXEC_OMP_SCAN
9755 ? &block->loc : &block->next->loc);
9756 }
9757 if (block && block->op != EXEC_OMP_SCAN)
9758 block = block->next;
9759 if (block && block->op == EXEC_OMP_SCAN)
9760 /* Mark 'omp scan' as checked; flag will be unset later. */
9761 block->ext.omp_clauses->if_present = true;
9762 }
9763 }
9764 }
9765 gfc_resolve_blocks (code->block, ns);
9766 omp_current_do_collapse = 0;
9767 omp_current_do_code = NULL;
9768}
9769
9770
9771void
9772gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
9773{
9774 struct fortran_omp_context ctx;
9775 gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
9776 gfc_omp_namelist *n;
9777 int list;
9778
9779 ctx.code = code;
9780 ctx.sharing_clauses = new hash_set<gfc_symbol *>;
9781 ctx.private_iterators = new hash_set<gfc_symbol *>;
9782 ctx.previous = omp_current_ctx;
9783 ctx.is_openmp = true;
9784 omp_current_ctx = &ctx;
9785
9786 for (list = 0; list < OMP_LIST_NUM; list++)
9787 switch (list)
9788 {
9789 case OMP_LIST_SHARED:
9790 case OMP_LIST_PRIVATE:
9791 case OMP_LIST_FIRSTPRIVATE:
9792 case OMP_LIST_LASTPRIVATE:
9793 case OMP_LIST_REDUCTION:
9794 case OMP_LIST_REDUCTION_INSCAN:
9795 case OMP_LIST_REDUCTION_TASK:
9796 case OMP_LIST_IN_REDUCTION:
9797 case OMP_LIST_TASK_REDUCTION:
9798 case OMP_LIST_LINEAR:
9799 for (n = omp_clauses->lists[list]; n; n = n->next)
9800 ctx.sharing_clauses->add (k: n->sym);
9801 break;
9802 default:
9803 break;
9804 }
9805
9806 switch (code->op)
9807 {
9808 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
9809 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
9810 case EXEC_OMP_MASKED_TASKLOOP:
9811 case EXEC_OMP_MASKED_TASKLOOP_SIMD:
9812 case EXEC_OMP_MASTER_TASKLOOP:
9813 case EXEC_OMP_MASTER_TASKLOOP_SIMD:
9814 case EXEC_OMP_PARALLEL_DO:
9815 case EXEC_OMP_PARALLEL_DO_SIMD:
9816 case EXEC_OMP_PARALLEL_LOOP:
9817 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
9818 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
9819 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
9820 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
9821 case EXEC_OMP_TARGET_PARALLEL_DO:
9822 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
9823 case EXEC_OMP_TARGET_PARALLEL_LOOP:
9824 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
9825 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
9826 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
9827 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
9828 case EXEC_OMP_TARGET_TEAMS_LOOP:
9829 case EXEC_OMP_TASKLOOP:
9830 case EXEC_OMP_TASKLOOP_SIMD:
9831 case EXEC_OMP_TEAMS_DISTRIBUTE:
9832 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
9833 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
9834 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
9835 case EXEC_OMP_TEAMS_LOOP:
9836 gfc_resolve_omp_do_blocks (code, ns);
9837 break;
9838 default:
9839 gfc_resolve_blocks (code->block, ns);
9840 }
9841
9842 omp_current_ctx = ctx.previous;
9843 delete ctx.sharing_clauses;
9844 delete ctx.private_iterators;
9845}
9846
9847
9848/* Save and clear openmp.cc private state. */
9849
9850void
9851gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *state)
9852{
9853 state->ptrs[0] = omp_current_ctx;
9854 state->ptrs[1] = omp_current_do_code;
9855 state->ints[0] = omp_current_do_collapse;
9856 omp_current_ctx = NULL;
9857 omp_current_do_code = NULL;
9858 omp_current_do_collapse = 0;
9859}
9860
9861
9862/* Restore openmp.cc private state from the saved state. */
9863
9864void
9865gfc_omp_restore_state (struct gfc_omp_saved_state *state)
9866{
9867 omp_current_ctx = (struct fortran_omp_context *) state->ptrs[0];
9868 omp_current_do_code = (gfc_code *) state->ptrs[1];
9869 omp_current_do_collapse = state->ints[0];
9870}
9871
9872
9873/* Note a DO iterator variable. This is special in !$omp parallel
9874 construct, where they are predetermined private. */
9875
9876void
9877gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym, bool add_clause)
9878{
9879 if (omp_current_ctx == NULL)
9880 return;
9881
9882 int i = omp_current_do_collapse;
9883 gfc_code *c = omp_current_do_code;
9884
9885 if (sym->attr.threadprivate)
9886 return;
9887
9888 /* !$omp do and !$omp parallel do iteration variable is predetermined
9889 private just in the !$omp do resp. !$omp parallel do construct,
9890 with no implications for the outer parallel constructs. */
9891
9892 while (i-- >= 1 && c)
9893 {
9894 if (code == c)
9895 return;
9896 c = find_nested_loop_in_chain (chain: c->block->next);
9897 }
9898
9899 /* An openacc context may represent a data clause. Abort if so. */
9900 if (!omp_current_ctx->is_openmp && !oacc_is_loop (code: omp_current_ctx->code))
9901 return;
9902
9903 if (omp_current_ctx->sharing_clauses->contains (k: sym))
9904 return;
9905
9906 if (! omp_current_ctx->private_iterators->add (k: sym) && add_clause)
9907 {
9908 gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses;
9909 gfc_omp_namelist *p;
9910
9911 p = gfc_get_omp_namelist ();
9912 p->sym = sym;
9913 p->where = omp_current_ctx->code->loc;
9914 p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
9915 omp_clauses->lists[OMP_LIST_PRIVATE] = p;
9916 }
9917}
9918
9919static void
9920handle_local_var (gfc_symbol *sym)
9921{
9922 if (sym->attr.flavor != FL_VARIABLE
9923 || sym->as != NULL
9924 || (sym->ts.type != BT_INTEGER && sym->ts.type != BT_REAL))
9925 return;
9926 gfc_resolve_do_iterator (code: sym->ns->code, sym, add_clause: false);
9927}
9928
9929void
9930gfc_resolve_omp_local_vars (gfc_namespace *ns)
9931{
9932 if (omp_current_ctx)
9933 gfc_traverse_ns (ns, handle_local_var);
9934}
9935
9936
9937/* Error checking on intervening code uses a code walker. */
9938
9939struct icode_error_state
9940{
9941 const char *name;
9942 bool errorp;
9943 gfc_code *nested;
9944 gfc_code *next;
9945};
9946
9947static int
9948icode_code_error_callback (gfc_code **codep,
9949 int *walk_subtrees ATTRIBUTE_UNUSED, void *opaque)
9950{
9951 gfc_code *code = *codep;
9952 icode_error_state *state = (icode_error_state *)opaque;
9953
9954 /* gfc_code_walker walks down CODE's next chain as well as
9955 walking things that are actually nested in CODE. We need to
9956 special-case traversal of outer blocks, so stop immediately if we
9957 are heading down such a next chain. */
9958 if (code == state->next)
9959 return 1;
9960
9961 switch (code->op)
9962 {
9963 case EXEC_DO:
9964 case EXEC_DO_WHILE:
9965 case EXEC_DO_CONCURRENT:
9966 gfc_error ("%s cannot contain loop in intervening code at %L",
9967 state->name, &code->loc);
9968 state->errorp = true;
9969 break;
9970 case EXEC_CYCLE:
9971 case EXEC_EXIT:
9972 /* Errors have already been diagnosed in match_exit_cycle. */
9973 state->errorp = true;
9974 break;
9975 case EXEC_OMP_CRITICAL:
9976 case EXEC_OMP_DO:
9977 case EXEC_OMP_FLUSH:
9978 case EXEC_OMP_MASTER:
9979 case EXEC_OMP_ORDERED:
9980 case EXEC_OMP_PARALLEL:
9981 case EXEC_OMP_PARALLEL_DO:
9982 case EXEC_OMP_PARALLEL_SECTIONS:
9983 case EXEC_OMP_PARALLEL_WORKSHARE:
9984 case EXEC_OMP_SECTIONS:
9985 case EXEC_OMP_SINGLE:
9986 case EXEC_OMP_WORKSHARE:
9987 case EXEC_OMP_ATOMIC:
9988 case EXEC_OMP_BARRIER:
9989 case EXEC_OMP_END_NOWAIT:
9990 case EXEC_OMP_END_SINGLE:
9991 case EXEC_OMP_TASK:
9992 case EXEC_OMP_TASKWAIT:
9993 case EXEC_OMP_TASKYIELD:
9994 case EXEC_OMP_CANCEL:
9995 case EXEC_OMP_CANCELLATION_POINT:
9996 case EXEC_OMP_TASKGROUP:
9997 case EXEC_OMP_SIMD:
9998 case EXEC_OMP_DO_SIMD:
9999 case EXEC_OMP_PARALLEL_DO_SIMD:
10000 case EXEC_OMP_TARGET:
10001 case EXEC_OMP_TARGET_DATA:
10002 case EXEC_OMP_TEAMS:
10003 case EXEC_OMP_DISTRIBUTE:
10004 case EXEC_OMP_DISTRIBUTE_SIMD:
10005 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
10006 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
10007 case EXEC_OMP_TARGET_TEAMS:
10008 case EXEC_OMP_TEAMS_DISTRIBUTE:
10009 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
10010 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
10011 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
10012 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
10013 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
10014 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10015 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10016 case EXEC_OMP_TARGET_UPDATE:
10017 case EXEC_OMP_END_CRITICAL:
10018 case EXEC_OMP_TARGET_ENTER_DATA:
10019 case EXEC_OMP_TARGET_EXIT_DATA:
10020 case EXEC_OMP_TARGET_PARALLEL:
10021 case EXEC_OMP_TARGET_PARALLEL_DO:
10022 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
10023 case EXEC_OMP_TARGET_SIMD:
10024 case EXEC_OMP_TASKLOOP:
10025 case EXEC_OMP_TASKLOOP_SIMD:
10026 case EXEC_OMP_SCAN:
10027 case EXEC_OMP_DEPOBJ:
10028 case EXEC_OMP_PARALLEL_MASTER:
10029 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
10030 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
10031 case EXEC_OMP_MASTER_TASKLOOP:
10032 case EXEC_OMP_MASTER_TASKLOOP_SIMD:
10033 case EXEC_OMP_LOOP:
10034 case EXEC_OMP_PARALLEL_LOOP:
10035 case EXEC_OMP_TEAMS_LOOP:
10036 case EXEC_OMP_TARGET_PARALLEL_LOOP:
10037 case EXEC_OMP_TARGET_TEAMS_LOOP:
10038 case EXEC_OMP_MASKED:
10039 case EXEC_OMP_PARALLEL_MASKED:
10040 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
10041 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
10042 case EXEC_OMP_MASKED_TASKLOOP:
10043 case EXEC_OMP_MASKED_TASKLOOP_SIMD:
10044 case EXEC_OMP_SCOPE:
10045 case EXEC_OMP_ERROR:
10046 gfc_error ("%s cannot contain OpenMP directive in intervening code "
10047 "at %L",
10048 state->name, &code->loc);
10049 state->errorp = true;
10050 break;
10051 case EXEC_CALL:
10052 /* Per OpenMP 5.2, the "omp_" prefix is reserved, so we don't have to
10053 consider the possibility that some locally-bound definition
10054 overrides the runtime routine. */
10055 if (code->resolved_sym
10056 && omp_runtime_api_procname (name: code->resolved_sym->name))
10057 {
10058 gfc_error ("%s cannot contain OpenMP API call in intervening code "
10059 "at %L",
10060 state->name, &code->loc);
10061 state->errorp = true;
10062 }
10063 break;
10064 default:
10065 break;
10066 }
10067 return 0;
10068}
10069
10070static int
10071icode_expr_error_callback (gfc_expr **expr,
10072 int *walk_subtrees ATTRIBUTE_UNUSED, void *opaque)
10073{
10074 icode_error_state *state = (icode_error_state *)opaque;
10075
10076 switch ((*expr)->expr_type)
10077 {
10078 /* As for EXPR_CALL with "omp_"-prefixed symbols. */
10079 case EXPR_FUNCTION:
10080 {
10081 gfc_symbol *sym = (*expr)->value.function.esym;
10082 if (sym && omp_runtime_api_procname (name: sym->name))
10083 {
10084 gfc_error ("%s cannot contain OpenMP API call in intervening code "
10085 "at %L",
10086 state->name, &((*expr)->where));
10087 state->errorp = true;
10088 }
10089 }
10090
10091 break;
10092 default:
10093 break;
10094 }
10095
10096 /* FIXME: The description of canonical loop form in the OpenMP standard
10097 also says "array expressions" are not permitted in intervening code.
10098 That term is not defined in either the OpenMP spec or the Fortran
10099 standard, although the latter uses it informally to refer to any
10100 expression that is not scalar-valued. It is also apparently not the
10101 thing GCC internally calls EXPR_ARRAY. It seems the intent of the
10102 OpenMP restriction is to disallow elemental operations/intrinsics
10103 (including things that are not expressions, like assignment
10104 statements) that generate implicit loops over array operands
10105 (even if the result is a scalar), but even if the spec said
10106 that there is no list of all the cases that would be forbidden.
10107 This is OpenMP issue 3326. */
10108
10109 return 0;
10110}
10111
10112static void
10113diagnose_intervening_code_errors_1 (gfc_code *chain,
10114 struct icode_error_state *state)
10115{
10116 gfc_code *code;
10117 for (code = chain; code; code = code->next)
10118 {
10119 if (code == state->nested)
10120 /* Do not walk the nested loop or its body, we are only
10121 interested in intervening code. */
10122 ;
10123 else if (code->op == EXEC_BLOCK
10124 && find_nested_loop_in_block (block: code) == state->nested)
10125 /* This block contains the nested loop, recurse on its
10126 statements. */
10127 {
10128 gfc_namespace* ns = code->ext.block.ns;
10129 diagnose_intervening_code_errors_1 (chain: ns->code, state);
10130 }
10131 else
10132 /* Treat the whole statement as a unit. */
10133 {
10134 gfc_code *temp = state->next;
10135 state->next = code->next;
10136 gfc_code_walker (&code, icode_code_error_callback,
10137 icode_expr_error_callback, state);
10138 state->next = temp;
10139 }
10140 }
10141}
10142
10143/* Diagnose intervening code errors in BLOCK with nested loop NESTED.
10144 NAME is the user-friendly name of the OMP directive, used for error
10145 messages. Returns true if any error was found. */
10146static bool
10147diagnose_intervening_code_errors (gfc_code *chain, const char *name,
10148 gfc_code *nested)
10149{
10150 struct icode_error_state state;
10151 state.name = name;
10152 state.errorp = false;
10153 state.nested = nested;
10154 state.next = NULL;
10155 diagnose_intervening_code_errors_1 (chain, state: &state);
10156 return state.errorp;
10157}
10158
10159/* Helper function for restructure_intervening_code: wrap CHAIN in
10160 a marker to indicate that it is a structured block sequence. That
10161 information will be used later on (in omp-low.cc) for error checking. */
10162static gfc_code *
10163make_structured_block (gfc_code *chain)
10164{
10165 gcc_assert (chain);
10166 gfc_namespace *ns = gfc_build_block_ns (gfc_current_ns);
10167 gfc_code *result = gfc_get_code (EXEC_BLOCK);
10168 result->op = EXEC_BLOCK;
10169 result->ext.block.ns = ns;
10170 result->ext.block.assoc = NULL;
10171 result->loc = chain->loc;
10172 ns->omp_structured_block = 1;
10173 ns->code = chain;
10174 return result;
10175}
10176
10177/* Push intervening code surrounding a loop, including nested scopes,
10178 into the body of the loop. CHAINP is the pointer to the head of
10179 the next-chain to scan, OUTER_LOOP is the EXEC_DO for the next outer
10180 loop level, and COLLAPSE is the number of nested loops we need to
10181 process.
10182 Note that CHAINP may point at outer_loop->block->next when we
10183 are scanning the body of a loop, but if there is an intervening block
10184 CHAINP points into the block's chain rather than its enclosing outer
10185 loop. This is why OUTER_LOOP is passed separately. */
10186static gfc_code *
10187restructure_intervening_code (gfc_code **chainp, gfc_code *outer_loop,
10188 int count)
10189{
10190 gfc_code *code;
10191 gfc_code *head = *chainp;
10192 gfc_code *tail = NULL;
10193 gfc_code *innermost_loop = NULL;
10194
10195 for (code = *chainp; code; code = code->next, chainp = &((*chainp)->next))
10196 {
10197 if (code->op == EXEC_DO)
10198 {
10199 /* Cut CODE free from its chain, leaving the ends dangling. */
10200 *chainp = NULL;
10201 tail = code->next;
10202 code->next = NULL;
10203
10204 if (count == 1)
10205 innermost_loop = code;
10206 else
10207 innermost_loop
10208 = restructure_intervening_code (chainp: &(code->block->next),
10209 outer_loop: code, count: count - 1);
10210 break;
10211 }
10212 else if (code->op == EXEC_BLOCK
10213 && find_nested_loop_in_block (block: code))
10214 {
10215 gfc_namespace *ns = code->ext.block.ns;
10216
10217 /* Cut CODE free from its chain, leaving the ends dangling. */
10218 *chainp = NULL;
10219 tail = code->next;
10220 code->next = NULL;
10221
10222 innermost_loop
10223 = restructure_intervening_code (chainp: &(ns->code), outer_loop,
10224 count);
10225
10226 /* At this point we have already pulled out the nested loop and
10227 pointed outer_loop at it, and moved the intervening code that
10228 was previously in the block into the body of innermost_loop.
10229 Now we want to move the BLOCK itself so it wraps the entire
10230 current body of innermost_loop. */
10231 ns->code = innermost_loop->block->next;
10232 innermost_loop->block->next = code;
10233 break;
10234 }
10235 }
10236
10237 gcc_assert (innermost_loop);
10238
10239 /* Now we have split the intervening code into two parts:
10240 head is the start of the part before the loop/block, terminating
10241 at *chainp, and tail is the part after it. Mark each part as
10242 a structured block sequence, and splice the two parts around the
10243 existing body of the innermost loop. */
10244 if (head != code)
10245 {
10246 gfc_code *block = make_structured_block (chain: head);
10247 if (innermost_loop->block->next)
10248 gfc_append_code (block, innermost_loop->block->next);
10249 innermost_loop->block->next = block;
10250 }
10251 if (tail)
10252 {
10253 gfc_code *block = make_structured_block (chain: tail);
10254 if (innermost_loop->block->next)
10255 gfc_append_code (innermost_loop->block->next, block);
10256 else
10257 innermost_loop->block->next = block;
10258 }
10259
10260 /* For loops, finally splice CODE into OUTER_LOOP. We already handled
10261 relinking EXEC_BLOCK above. */
10262 if (code->op == EXEC_DO && outer_loop)
10263 outer_loop->block->next = code;
10264
10265 return innermost_loop;
10266}
10267
10268/* CODE is an OMP loop construct. Return true if VAR matches an iteration
10269 variable outer to level DEPTH. */
10270static bool
10271is_outer_iteration_variable (gfc_code *code, int depth, gfc_symbol *var)
10272{
10273 int i;
10274 gfc_code *do_code = code;
10275
10276 for (i = 1; i < depth; i++)
10277 {
10278 do_code = find_nested_loop_in_chain (chain: do_code->block->next);
10279 gcc_assert (do_code);
10280 gfc_symbol *ivar = do_code->ext.iterator->var->symtree->n.sym;
10281 if (var == ivar)
10282 return true;
10283 }
10284 return false;
10285}
10286
10287/* Forward declaration for recursive functions. */
10288static gfc_code *
10289check_nested_loop_in_block (gfc_code *block, gfc_expr *expr, gfc_symbol *sym,
10290 bool *bad);
10291
10292/* Like find_nested_loop_in_chain, but additionally check that EXPR
10293 does not reference any variables bound in intervening EXEC_BLOCKs
10294 and that SYM is not bound in such intervening blocks. Either EXPR or SYM
10295 may be null. Sets *BAD to true if either test fails. */
10296static gfc_code *
10297check_nested_loop_in_chain (gfc_code *chain, gfc_expr *expr, gfc_symbol *sym,
10298 bool *bad)
10299{
10300 for (gfc_code *code = chain; code; code = code->next)
10301 {
10302 if (code->op == EXEC_DO)
10303 return code;
10304 else if (code->op == EXEC_BLOCK)
10305 {
10306 gfc_code *c = check_nested_loop_in_block (block: code, expr, sym, bad);
10307 if (c)
10308 return c;
10309 }
10310 }
10311 return NULL;
10312}
10313
10314/* Code walker for block symtrees. It doesn't take any kind of state
10315 argument, so use a static variable. */
10316static struct check_nested_loop_in_block_state_t {
10317 gfc_expr *expr;
10318 gfc_symbol *sym;
10319 bool *bad;
10320} check_nested_loop_in_block_state;
10321
10322static void
10323check_nested_loop_in_block_symbol (gfc_symbol *sym)
10324{
10325 if (sym == check_nested_loop_in_block_state.sym
10326 || (check_nested_loop_in_block_state.expr
10327 && gfc_find_sym_in_expr (sym,
10328 check_nested_loop_in_block_state.expr)))
10329 *check_nested_loop_in_block_state.bad = true;
10330}
10331
10332/* Return the first nested DO loop in BLOCK, or NULL if there
10333 isn't one. Set *BAD to true if EXPR references any variables in BLOCK, or
10334 SYM is bound in BLOCK. Either EXPR or SYM may be null. */
10335static gfc_code *
10336check_nested_loop_in_block (gfc_code *block, gfc_expr *expr,
10337 gfc_symbol *sym, bool *bad)
10338{
10339 gfc_namespace *ns;
10340 gcc_assert (block->op == EXEC_BLOCK);
10341 ns = block->ext.block.ns;
10342 gcc_assert (ns);
10343
10344 /* Skip the check if this block doesn't contain the nested loop, or
10345 if we already know it's bad. */
10346 gfc_code *result = check_nested_loop_in_chain (chain: ns->code, expr, sym, bad);
10347 if (result && !*bad)
10348 {
10349 check_nested_loop_in_block_state.expr = expr;
10350 check_nested_loop_in_block_state.sym = sym;
10351 check_nested_loop_in_block_state.bad = bad;
10352 gfc_traverse_ns (ns, check_nested_loop_in_block_symbol);
10353 check_nested_loop_in_block_state.expr = NULL;
10354 check_nested_loop_in_block_state.sym = NULL;
10355 check_nested_loop_in_block_state.bad = NULL;
10356 }
10357 return result;
10358}
10359
10360/* CODE is an OMP loop construct. Return true if EXPR references
10361 any variables bound in intervening code, to level DEPTH. */
10362static bool
10363expr_uses_intervening_var (gfc_code *code, int depth, gfc_expr *expr)
10364{
10365 int i;
10366 gfc_code *do_code = code;
10367
10368 for (i = 0; i < depth; i++)
10369 {
10370 bool bad = false;
10371 do_code = check_nested_loop_in_chain (chain: do_code->block->next,
10372 expr, NULL, bad: &bad);
10373 if (bad)
10374 return true;
10375 }
10376 return false;
10377}
10378
10379/* CODE is an OMP loop construct. Return true if SYM is bound in
10380 intervening code, to level DEPTH. */
10381static bool
10382is_intervening_var (gfc_code *code, int depth, gfc_symbol *sym)
10383{
10384 int i;
10385 gfc_code *do_code = code;
10386
10387 for (i = 0; i < depth; i++)
10388 {
10389 bool bad = false;
10390 do_code = check_nested_loop_in_chain (chain: do_code->block->next,
10391 NULL, sym, bad: &bad);
10392 if (bad)
10393 return true;
10394 }
10395 return false;
10396}
10397
10398/* CODE is an OMP loop construct. Return true if EXPR does not reference
10399 any iteration variables outer to level DEPTH. */
10400static bool
10401expr_is_invariant (gfc_code *code, int depth, gfc_expr *expr)
10402{
10403 int i;
10404 gfc_code *do_code = code;
10405
10406 for (i = 1; i < depth; i++)
10407 {
10408 do_code = find_nested_loop_in_chain (chain: do_code->block->next);
10409 gcc_assert (do_code);
10410 gfc_symbol *ivar = do_code->ext.iterator->var->symtree->n.sym;
10411 if (gfc_find_sym_in_expr (ivar, expr))
10412 return false;
10413 }
10414 return true;
10415}
10416
10417/* CODE is an OMP loop construct. Return true if EXPR matches one of the
10418 canonical forms for a bound expression. It may include references to
10419 an iteration variable outer to level DEPTH; set OUTER_VARP if so. */
10420static bool
10421bound_expr_is_canonical (gfc_code *code, int depth, gfc_expr *expr,
10422 gfc_symbol **outer_varp)
10423{
10424 gfc_expr *expr2 = NULL;
10425
10426 /* Rectangular case. */
10427 if (depth == 0 || expr_is_invariant (code, depth, expr))
10428 return true;
10429
10430 /* Any simple variable that didn't pass expr_is_invariant must be
10431 an outer_var. */
10432 if (expr->expr_type == EXPR_VARIABLE && expr->rank == 0)
10433 {
10434 *outer_varp = expr->symtree->n.sym;
10435 return true;
10436 }
10437
10438 /* All other permitted forms are binary operators. */
10439 if (expr->expr_type != EXPR_OP)
10440 return false;
10441
10442 /* Check for plus/minus a loop invariant expr. */
10443 if (expr->value.op.op == INTRINSIC_PLUS
10444 || expr->value.op.op == INTRINSIC_MINUS)
10445 {
10446 if (expr_is_invariant (code, depth, expr: expr->value.op.op1))
10447 expr2 = expr->value.op.op2;
10448 else if (expr_is_invariant (code, depth, expr: expr->value.op.op2))
10449 expr2 = expr->value.op.op1;
10450 else
10451 return false;
10452 }
10453 else
10454 expr2 = expr;
10455
10456 /* Check for a product with a loop-invariant expr. */
10457 if (expr2->expr_type == EXPR_OP
10458 && expr2->value.op.op == INTRINSIC_TIMES)
10459 {
10460 if (expr_is_invariant (code, depth, expr: expr2->value.op.op1))
10461 expr2 = expr2->value.op.op2;
10462 else if (expr_is_invariant (code, depth, expr: expr2->value.op.op2))
10463 expr2 = expr2->value.op.op1;
10464 else
10465 return false;
10466 }
10467
10468 /* What's left must be a reference to an outer loop variable. */
10469 if (expr2->expr_type == EXPR_VARIABLE
10470 && expr2->rank == 0
10471 && is_outer_iteration_variable (code, depth, var: expr2->symtree->n.sym))
10472 {
10473 *outer_varp = expr2->symtree->n.sym;
10474 return true;
10475 }
10476
10477 return false;
10478}
10479
10480static void
10481resolve_omp_do (gfc_code *code)
10482{
10483 gfc_code *do_code, *next;
10484 int list, i, count;
10485 gfc_omp_namelist *n;
10486 gfc_symbol *dovar;
10487 const char *name;
10488 bool is_simd = false;
10489 bool errorp = false;
10490 bool perfect_nesting_errorp = false;
10491
10492 switch (code->op)
10493 {
10494 case EXEC_OMP_DISTRIBUTE: name = "!$OMP DISTRIBUTE"; break;
10495 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
10496 name = "!$OMP DISTRIBUTE PARALLEL DO";
10497 break;
10498 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
10499 name = "!$OMP DISTRIBUTE PARALLEL DO SIMD";
10500 is_simd = true;
10501 break;
10502 case EXEC_OMP_DISTRIBUTE_SIMD:
10503 name = "!$OMP DISTRIBUTE SIMD";
10504 is_simd = true;
10505 break;
10506 case EXEC_OMP_DO: name = "!$OMP DO"; break;
10507 case EXEC_OMP_DO_SIMD: name = "!$OMP DO SIMD"; is_simd = true; break;
10508 case EXEC_OMP_LOOP: name = "!$OMP LOOP"; break;
10509 case EXEC_OMP_PARALLEL_DO: name = "!$OMP PARALLEL DO"; break;
10510 case EXEC_OMP_PARALLEL_DO_SIMD:
10511 name = "!$OMP PARALLEL DO SIMD";
10512 is_simd = true;
10513 break;
10514 case EXEC_OMP_PARALLEL_LOOP: name = "!$OMP PARALLEL LOOP"; break;
10515 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
10516 name = "!$OMP PARALLEL MASKED TASKLOOP";
10517 break;
10518 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
10519 name = "!$OMP PARALLEL MASKED TASKLOOP SIMD";
10520 is_simd = true;
10521 break;
10522 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
10523 name = "!$OMP PARALLEL MASTER TASKLOOP";
10524 break;
10525 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
10526 name = "!$OMP PARALLEL MASTER TASKLOOP SIMD";
10527 is_simd = true;
10528 break;
10529 case EXEC_OMP_MASKED_TASKLOOP: name = "!$OMP MASKED TASKLOOP"; break;
10530 case EXEC_OMP_MASKED_TASKLOOP_SIMD:
10531 name = "!$OMP MASKED TASKLOOP SIMD";
10532 is_simd = true;
10533 break;
10534 case EXEC_OMP_MASTER_TASKLOOP: name = "!$OMP MASTER TASKLOOP"; break;
10535 case EXEC_OMP_MASTER_TASKLOOP_SIMD:
10536 name = "!$OMP MASTER TASKLOOP SIMD";
10537 is_simd = true;
10538 break;
10539 case EXEC_OMP_SIMD: name = "!$OMP SIMD"; is_simd = true; break;
10540 case EXEC_OMP_TARGET_PARALLEL_DO: name = "!$OMP TARGET PARALLEL DO"; break;
10541 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
10542 name = "!$OMP TARGET PARALLEL DO SIMD";
10543 is_simd = true;
10544 break;
10545 case EXEC_OMP_TARGET_PARALLEL_LOOP:
10546 name = "!$OMP TARGET PARALLEL LOOP";
10547 break;
10548 case EXEC_OMP_TARGET_SIMD:
10549 name = "!$OMP TARGET SIMD";
10550 is_simd = true;
10551 break;
10552 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
10553 name = "!$OMP TARGET TEAMS DISTRIBUTE";
10554 break;
10555 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
10556 name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
10557 break;
10558 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10559 name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
10560 is_simd = true;
10561 break;
10562 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
10563 name = "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
10564 is_simd = true;
10565 break;
10566 case EXEC_OMP_TARGET_TEAMS_LOOP: name = "!$OMP TARGET TEAMS LOOP"; break;
10567 case EXEC_OMP_TASKLOOP: name = "!$OMP TASKLOOP"; break;
10568 case EXEC_OMP_TASKLOOP_SIMD:
10569 name = "!$OMP TASKLOOP SIMD";
10570 is_simd = true;
10571 break;
10572 case EXEC_OMP_TEAMS_DISTRIBUTE: name = "!$OMP TEAMS DISTRIBUTE"; break;
10573 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
10574 name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
10575 break;
10576 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10577 name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
10578 is_simd = true;
10579 break;
10580 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
10581 name = "!$OMP TEAMS DISTRIBUTE SIMD";
10582 is_simd = true;
10583 break;
10584 case EXEC_OMP_TEAMS_LOOP: name = "!$OMP TEAMS LOOP"; break;
10585 default: gcc_unreachable ();
10586 }
10587
10588 if (code->ext.omp_clauses)
10589 resolve_omp_clauses (code, omp_clauses: code->ext.omp_clauses, NULL);
10590
10591 do_code = code->block->next;
10592 if (code->ext.omp_clauses->orderedc)
10593 count = code->ext.omp_clauses->orderedc;
10594 else
10595 {
10596 count = code->ext.omp_clauses->collapse;
10597 if (count <= 0)
10598 count = 1;
10599 }
10600
10601 /* While the spec defines the loop nest depth independently of the COLLAPSE
10602 clause, in practice the middle end only pays attention to the COLLAPSE
10603 depth and treats any further inner loops as the final-loop-body. So
10604 here we also check canonical loop nest form only for the number of
10605 outer loops specified by the COLLAPSE clause too. */
10606 for (i = 1; i <= count; i++)
10607 {
10608 gfc_symbol *start_var = NULL, *end_var = NULL;
10609 /* Parse errors are not recoverable. */
10610 if (do_code->op == EXEC_DO_WHILE)
10611 {
10612 gfc_error ("%s cannot be a DO WHILE or DO without loop control "
10613 "at %L", name, &do_code->loc);
10614 return;
10615 }
10616 if (do_code->op == EXEC_DO_CONCURRENT)
10617 {
10618 gfc_error ("%s cannot be a DO CONCURRENT loop at %L", name,
10619 &do_code->loc);
10620 return;
10621 }
10622 gcc_assert (do_code->op == EXEC_DO);
10623 if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
10624 {
10625 gfc_error ("%s iteration variable must be of type integer at %L",
10626 name, &do_code->loc);
10627 errorp = true;
10628 }
10629 dovar = do_code->ext.iterator->var->symtree->n.sym;
10630 if (dovar->attr.threadprivate)
10631 {
10632 gfc_error ("%s iteration variable must not be THREADPRIVATE "
10633 "at %L", name, &do_code->loc);
10634 errorp = true;
10635 }
10636 if (code->ext.omp_clauses)
10637 for (list = 0; list < OMP_LIST_NUM; list++)
10638 if (!is_simd || code->ext.omp_clauses->collapse > 1
10639 ? (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE
10640 && list != OMP_LIST_ALLOCATE)
10641 : (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE
10642 && list != OMP_LIST_ALLOCATE && list != OMP_LIST_LINEAR))
10643 for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
10644 if (dovar == n->sym)
10645 {
10646 if (!is_simd || code->ext.omp_clauses->collapse > 1)
10647 gfc_error ("%s iteration variable present on clause "
10648 "other than PRIVATE, LASTPRIVATE or "
10649 "ALLOCATE at %L", name, &do_code->loc);
10650 else
10651 gfc_error ("%s iteration variable present on clause "
10652 "other than PRIVATE, LASTPRIVATE, ALLOCATE or "
10653 "LINEAR at %L", name, &do_code->loc);
10654 errorp = true;
10655 }
10656 if (is_outer_iteration_variable (code, depth: i, var: dovar))
10657 {
10658 gfc_error ("%s iteration variable used in more than one loop at %L",
10659 name, &do_code->loc);
10660 errorp = true;
10661 }
10662 else if (is_intervening_var (code, depth: i, sym: dovar))
10663 {
10664 gfc_error ("%s iteration variable at %L is bound in "
10665 "intervening code",
10666 name, &do_code->loc);
10667 errorp = true;
10668 }
10669 else if (!bound_expr_is_canonical (code, depth: i,
10670 expr: do_code->ext.iterator->start,
10671 outer_varp: &start_var))
10672 {
10673 gfc_error ("%s loop start expression not in canonical form at %L",
10674 name, &do_code->loc);
10675 errorp = true;
10676 }
10677 else if (expr_uses_intervening_var (code, depth: i,
10678 expr: do_code->ext.iterator->start))
10679 {
10680 gfc_error ("%s loop start expression at %L uses variable bound in "
10681 "intervening code",
10682 name, &do_code->loc);
10683 errorp = true;
10684 }
10685 else if (!bound_expr_is_canonical (code, depth: i,
10686 expr: do_code->ext.iterator->end,
10687 outer_varp: &end_var))
10688 {
10689 gfc_error ("%s loop end expression not in canonical form at %L",
10690 name, &do_code->loc);
10691 errorp = true;
10692 }
10693 else if (expr_uses_intervening_var (code, depth: i,
10694 expr: do_code->ext.iterator->end))
10695 {
10696 gfc_error ("%s loop end expression at %L uses variable bound in "
10697 "intervening code",
10698 name, &do_code->loc);
10699 errorp = true;
10700 }
10701 else if (start_var && end_var && start_var != end_var)
10702 {
10703 gfc_error ("%s loop bounds reference different "
10704 "iteration variables at %L", name, &do_code->loc);
10705 errorp = true;
10706 }
10707 else if (!expr_is_invariant (code, depth: i, expr: do_code->ext.iterator->step))
10708 {
10709 gfc_error ("%s loop increment not in canonical form at %L",
10710 name, &do_code->loc);
10711 errorp = true;
10712 }
10713 else if (expr_uses_intervening_var (code, depth: i,
10714 expr: do_code->ext.iterator->step))
10715 {
10716 gfc_error ("%s loop increment expression at %L uses variable "
10717 "bound in intervening code",
10718 name, &do_code->loc);
10719 errorp = true;
10720 }
10721 if (start_var || end_var)
10722 code->ext.omp_clauses->non_rectangular = 1;
10723
10724 /* Only parse loop body into nested loop and intervening code if
10725 there are supposed to be more loops in the nest to collapse. */
10726 if (i == count)
10727 break;
10728
10729 next = find_nested_loop_in_chain (chain: do_code->block->next);
10730
10731 if (!next)
10732 {
10733 /* Parse error, can't recover from this. */
10734 gfc_error ("not enough DO loops for collapsed %s (level %d) at %L",
10735 name, i, &code->loc);
10736 return;
10737 }
10738 else if (next != do_code->block->next || next->next)
10739 /* Imperfectly nested loop found. */
10740 {
10741 /* Only diagnose violation of imperfect nesting constraints once. */
10742 if (!perfect_nesting_errorp)
10743 {
10744 if (code->ext.omp_clauses->orderedc)
10745 {
10746 gfc_error ("%s inner loops must be perfectly nested with "
10747 "ORDERED clause at %L",
10748 name, &code->loc);
10749 perfect_nesting_errorp = true;
10750 }
10751 else if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
10752 {
10753 gfc_error ("%s inner loops must be perfectly nested with "
10754 "REDUCTION INSCAN clause at %L",
10755 name, &code->loc);
10756 perfect_nesting_errorp = true;
10757 }
10758 /* FIXME: Also diagnose for TILE directives. */
10759 if (perfect_nesting_errorp)
10760 errorp = true;
10761 }
10762 if (diagnose_intervening_code_errors (chain: do_code->block->next,
10763 name, nested: next))
10764 errorp = true;
10765 }
10766 do_code = next;
10767 }
10768
10769 /* Give up now if we found any constraint violations. */
10770 if (errorp)
10771 return;
10772
10773 restructure_intervening_code (chainp: &(code->block->next), outer_loop: code, count);
10774}
10775
10776
10777static gfc_statement
10778omp_code_to_statement (gfc_code *code)
10779{
10780 switch (code->op)
10781 {
10782 case EXEC_OMP_PARALLEL:
10783 return ST_OMP_PARALLEL;
10784 case EXEC_OMP_PARALLEL_MASKED:
10785 return ST_OMP_PARALLEL_MASKED;
10786 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
10787 return ST_OMP_PARALLEL_MASKED_TASKLOOP;
10788 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
10789 return ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD;
10790 case EXEC_OMP_PARALLEL_MASTER:
10791 return ST_OMP_PARALLEL_MASTER;
10792 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
10793 return ST_OMP_PARALLEL_MASTER_TASKLOOP;
10794 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
10795 return ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD;
10796 case EXEC_OMP_PARALLEL_SECTIONS:
10797 return ST_OMP_PARALLEL_SECTIONS;
10798 case EXEC_OMP_SECTIONS:
10799 return ST_OMP_SECTIONS;
10800 case EXEC_OMP_ORDERED:
10801 return ST_OMP_ORDERED;
10802 case EXEC_OMP_CRITICAL:
10803 return ST_OMP_CRITICAL;
10804 case EXEC_OMP_MASKED:
10805 return ST_OMP_MASKED;
10806 case EXEC_OMP_MASKED_TASKLOOP:
10807 return ST_OMP_MASKED_TASKLOOP;
10808 case EXEC_OMP_MASKED_TASKLOOP_SIMD:
10809 return ST_OMP_MASKED_TASKLOOP_SIMD;
10810 case EXEC_OMP_MASTER:
10811 return ST_OMP_MASTER;
10812 case EXEC_OMP_MASTER_TASKLOOP:
10813 return ST_OMP_MASTER_TASKLOOP;
10814 case EXEC_OMP_MASTER_TASKLOOP_SIMD:
10815 return ST_OMP_MASTER_TASKLOOP_SIMD;
10816 case EXEC_OMP_SINGLE:
10817 return ST_OMP_SINGLE;
10818 case EXEC_OMP_TASK:
10819 return ST_OMP_TASK;
10820 case EXEC_OMP_WORKSHARE:
10821 return ST_OMP_WORKSHARE;
10822 case EXEC_OMP_PARALLEL_WORKSHARE:
10823 return ST_OMP_PARALLEL_WORKSHARE;
10824 case EXEC_OMP_DO:
10825 return ST_OMP_DO;
10826 case EXEC_OMP_LOOP:
10827 return ST_OMP_LOOP;
10828 case EXEC_OMP_ALLOCATE:
10829 return ST_OMP_ALLOCATE_EXEC;
10830 case EXEC_OMP_ALLOCATORS:
10831 return ST_OMP_ALLOCATORS;
10832 case EXEC_OMP_ASSUME:
10833 return ST_OMP_ASSUME;
10834 case EXEC_OMP_ATOMIC:
10835 return ST_OMP_ATOMIC;
10836 case EXEC_OMP_BARRIER:
10837 return ST_OMP_BARRIER;
10838 case EXEC_OMP_CANCEL:
10839 return ST_OMP_CANCEL;
10840 case EXEC_OMP_CANCELLATION_POINT:
10841 return ST_OMP_CANCELLATION_POINT;
10842 case EXEC_OMP_ERROR:
10843 return ST_OMP_ERROR;
10844 case EXEC_OMP_FLUSH:
10845 return ST_OMP_FLUSH;
10846 case EXEC_OMP_DISTRIBUTE:
10847 return ST_OMP_DISTRIBUTE;
10848 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
10849 return ST_OMP_DISTRIBUTE_PARALLEL_DO;
10850 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
10851 return ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD;
10852 case EXEC_OMP_DISTRIBUTE_SIMD:
10853 return ST_OMP_DISTRIBUTE_SIMD;
10854 case EXEC_OMP_DO_SIMD:
10855 return ST_OMP_DO_SIMD;
10856 case EXEC_OMP_SCAN:
10857 return ST_OMP_SCAN;
10858 case EXEC_OMP_SCOPE:
10859 return ST_OMP_SCOPE;
10860 case EXEC_OMP_SIMD:
10861 return ST_OMP_SIMD;
10862 case EXEC_OMP_TARGET:
10863 return ST_OMP_TARGET;
10864 case EXEC_OMP_TARGET_DATA:
10865 return ST_OMP_TARGET_DATA;
10866 case EXEC_OMP_TARGET_ENTER_DATA:
10867 return ST_OMP_TARGET_ENTER_DATA;
10868 case EXEC_OMP_TARGET_EXIT_DATA:
10869 return ST_OMP_TARGET_EXIT_DATA;
10870 case EXEC_OMP_TARGET_PARALLEL:
10871 return ST_OMP_TARGET_PARALLEL;
10872 case EXEC_OMP_TARGET_PARALLEL_DO:
10873 return ST_OMP_TARGET_PARALLEL_DO;
10874 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
10875 return ST_OMP_TARGET_PARALLEL_DO_SIMD;
10876 case EXEC_OMP_TARGET_PARALLEL_LOOP:
10877 return ST_OMP_TARGET_PARALLEL_LOOP;
10878 case EXEC_OMP_TARGET_SIMD:
10879 return ST_OMP_TARGET_SIMD;
10880 case EXEC_OMP_TARGET_TEAMS:
10881 return ST_OMP_TARGET_TEAMS;
10882 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
10883 return ST_OMP_TARGET_TEAMS_DISTRIBUTE;
10884 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
10885 return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
10886 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10887 return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
10888 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
10889 return ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD;
10890 case EXEC_OMP_TARGET_TEAMS_LOOP:
10891 return ST_OMP_TARGET_TEAMS_LOOP;
10892 case EXEC_OMP_TARGET_UPDATE:
10893 return ST_OMP_TARGET_UPDATE;
10894 case EXEC_OMP_TASKGROUP:
10895 return ST_OMP_TASKGROUP;
10896 case EXEC_OMP_TASKLOOP:
10897 return ST_OMP_TASKLOOP;
10898 case EXEC_OMP_TASKLOOP_SIMD:
10899 return ST_OMP_TASKLOOP_SIMD;
10900 case EXEC_OMP_TASKWAIT:
10901 return ST_OMP_TASKWAIT;
10902 case EXEC_OMP_TASKYIELD:
10903 return ST_OMP_TASKYIELD;
10904 case EXEC_OMP_TEAMS:
10905 return ST_OMP_TEAMS;
10906 case EXEC_OMP_TEAMS_DISTRIBUTE:
10907 return ST_OMP_TEAMS_DISTRIBUTE;
10908 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
10909 return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO;
10910 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
10911 return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
10912 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
10913 return ST_OMP_TEAMS_DISTRIBUTE_SIMD;
10914 case EXEC_OMP_TEAMS_LOOP:
10915 return ST_OMP_TEAMS_LOOP;
10916 case EXEC_OMP_PARALLEL_DO:
10917 return ST_OMP_PARALLEL_DO;
10918 case EXEC_OMP_PARALLEL_DO_SIMD:
10919 return ST_OMP_PARALLEL_DO_SIMD;
10920 case EXEC_OMP_PARALLEL_LOOP:
10921 return ST_OMP_PARALLEL_LOOP;
10922 case EXEC_OMP_DEPOBJ:
10923 return ST_OMP_DEPOBJ;
10924 default:
10925 gcc_unreachable ();
10926 }
10927}
10928
10929static gfc_statement
10930oacc_code_to_statement (gfc_code *code)
10931{
10932 switch (code->op)
10933 {
10934 case EXEC_OACC_PARALLEL:
10935 return ST_OACC_PARALLEL;
10936 case EXEC_OACC_KERNELS:
10937 return ST_OACC_KERNELS;
10938 case EXEC_OACC_SERIAL:
10939 return ST_OACC_SERIAL;
10940 case EXEC_OACC_DATA:
10941 return ST_OACC_DATA;
10942 case EXEC_OACC_HOST_DATA:
10943 return ST_OACC_HOST_DATA;
10944 case EXEC_OACC_PARALLEL_LOOP:
10945 return ST_OACC_PARALLEL_LOOP;
10946 case EXEC_OACC_KERNELS_LOOP:
10947 return ST_OACC_KERNELS_LOOP;
10948 case EXEC_OACC_SERIAL_LOOP:
10949 return ST_OACC_SERIAL_LOOP;
10950 case EXEC_OACC_LOOP:
10951 return ST_OACC_LOOP;
10952 case EXEC_OACC_ATOMIC:
10953 return ST_OACC_ATOMIC;
10954 case EXEC_OACC_ROUTINE:
10955 return ST_OACC_ROUTINE;
10956 case EXEC_OACC_UPDATE:
10957 return ST_OACC_UPDATE;
10958 case EXEC_OACC_WAIT:
10959 return ST_OACC_WAIT;
10960 case EXEC_OACC_CACHE:
10961 return ST_OACC_CACHE;
10962 case EXEC_OACC_ENTER_DATA:
10963 return ST_OACC_ENTER_DATA;
10964 case EXEC_OACC_EXIT_DATA:
10965 return ST_OACC_EXIT_DATA;
10966 case EXEC_OACC_DECLARE:
10967 return ST_OACC_DECLARE;
10968 default:
10969 gcc_unreachable ();
10970 }
10971}
10972
10973static void
10974resolve_oacc_directive_inside_omp_region (gfc_code *code)
10975{
10976 if (omp_current_ctx != NULL && omp_current_ctx->is_openmp)
10977 {
10978 gfc_statement st = omp_code_to_statement (code: omp_current_ctx->code);
10979 gfc_statement oacc_st = oacc_code_to_statement (code);
10980 gfc_error ("The %s directive cannot be specified within "
10981 "a %s region at %L", gfc_ascii_statement (oacc_st),
10982 gfc_ascii_statement (st), &code->loc);
10983 }
10984}
10985
10986static void
10987resolve_omp_directive_inside_oacc_region (gfc_code *code)
10988{
10989 if (omp_current_ctx != NULL && !omp_current_ctx->is_openmp)
10990 {
10991 gfc_statement st = oacc_code_to_statement (code: omp_current_ctx->code);
10992 gfc_statement omp_st = omp_code_to_statement (code);
10993 gfc_error ("The %s directive cannot be specified within "
10994 "a %s region at %L", gfc_ascii_statement (omp_st),
10995 gfc_ascii_statement (st), &code->loc);
10996 }
10997}
10998
10999
11000static void
11001resolve_oacc_nested_loops (gfc_code *code, gfc_code* do_code, int collapse,
11002 const char *clause)
11003{
11004 gfc_symbol *dovar;
11005 gfc_code *c;
11006 int i;
11007
11008 for (i = 1; i <= collapse; i++)
11009 {
11010 if (do_code->op == EXEC_DO_WHILE)
11011 {
11012 gfc_error ("!$ACC LOOP cannot be a DO WHILE or DO without loop control "
11013 "at %L", &do_code->loc);
11014 break;
11015 }
11016 if (do_code->op == EXEC_DO_CONCURRENT)
11017 {
11018 gfc_error ("!$ACC LOOP cannot be a DO CONCURRENT loop at %L",
11019 &do_code->loc);
11020 break;
11021 }
11022 gcc_assert (do_code->op == EXEC_DO);
11023 if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
11024 gfc_error ("!$ACC LOOP iteration variable must be of type integer at %L",
11025 &do_code->loc);
11026 dovar = do_code->ext.iterator->var->symtree->n.sym;
11027 if (i > 1)
11028 {
11029 gfc_code *do_code2 = code->block->next;
11030 int j;
11031
11032 for (j = 1; j < i; j++)
11033 {
11034 gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
11035 if (dovar == ivar
11036 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
11037 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
11038 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
11039 {
11040 gfc_error ("!$ACC LOOP %s loops don't form rectangular "
11041 "iteration space at %L", clause, &do_code->loc);
11042 break;
11043 }
11044 do_code2 = do_code2->block->next;
11045 }
11046 }
11047 if (i == collapse)
11048 break;
11049 for (c = do_code->next; c; c = c->next)
11050 if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
11051 {
11052 gfc_error ("%s !$ACC LOOP loops not perfectly nested at %L",
11053 clause, &c->loc);
11054 break;
11055 }
11056 if (c)
11057 break;
11058 do_code = do_code->block;
11059 if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
11060 && do_code->op != EXEC_DO_CONCURRENT)
11061 {
11062 gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
11063 clause, &code->loc);
11064 break;
11065 }
11066 do_code = do_code->next;
11067 if (do_code == NULL
11068 || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
11069 && do_code->op != EXEC_DO_CONCURRENT))
11070 {
11071 gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
11072 clause, &code->loc);
11073 break;
11074 }
11075 }
11076}
11077
11078
11079static void
11080resolve_oacc_loop_blocks (gfc_code *code)
11081{
11082 if (!oacc_is_loop (code))
11083 return;
11084
11085 if (code->ext.omp_clauses->tile_list && code->ext.omp_clauses->gang
11086 && code->ext.omp_clauses->worker && code->ext.omp_clauses->vector)
11087 gfc_error ("Tiled loop cannot be parallelized across gangs, workers and "
11088 "vectors at the same time at %L", &code->loc);
11089
11090 if (code->ext.omp_clauses->tile_list)
11091 {
11092 gfc_expr_list *el;
11093 for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
11094 {
11095 if (el->expr == NULL)
11096 {
11097 /* NULL expressions are used to represent '*' arguments.
11098 Convert those to a 0 expressions. */
11099 el->expr = gfc_get_constant_expr (BT_INTEGER,
11100 gfc_default_integer_kind,
11101 &code->loc);
11102 mpz_set_si (el->expr->value.integer, 0);
11103 }
11104 else
11105 {
11106 resolve_positive_int_expr (expr: el->expr, clause: "TILE");
11107 if (el->expr->expr_type != EXPR_CONSTANT)
11108 gfc_error ("TILE requires constant expression at %L",
11109 &code->loc);
11110 }
11111 }
11112 }
11113}
11114
11115
11116void
11117gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns)
11118{
11119 fortran_omp_context ctx;
11120 gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
11121 gfc_omp_namelist *n;
11122 int list;
11123
11124 resolve_oacc_loop_blocks (code);
11125
11126 ctx.code = code;
11127 ctx.sharing_clauses = new hash_set<gfc_symbol *>;
11128 ctx.private_iterators = new hash_set<gfc_symbol *>;
11129 ctx.previous = omp_current_ctx;
11130 ctx.is_openmp = false;
11131 omp_current_ctx = &ctx;
11132
11133 for (list = 0; list < OMP_LIST_NUM; list++)
11134 switch (list)
11135 {
11136 case OMP_LIST_PRIVATE:
11137 for (n = omp_clauses->lists[list]; n; n = n->next)
11138 ctx.sharing_clauses->add (k: n->sym);
11139 break;
11140 default:
11141 break;
11142 }
11143
11144 gfc_resolve_blocks (code->block, ns);
11145
11146 omp_current_ctx = ctx.previous;
11147 delete ctx.sharing_clauses;
11148 delete ctx.private_iterators;
11149}
11150
11151
11152static void
11153resolve_oacc_loop (gfc_code *code)
11154{
11155 gfc_code *do_code;
11156 int collapse;
11157
11158 if (code->ext.omp_clauses)
11159 resolve_omp_clauses (code, omp_clauses: code->ext.omp_clauses, NULL, openacc: true);
11160
11161 do_code = code->block->next;
11162 collapse = code->ext.omp_clauses->collapse;
11163
11164 /* Both collapsed and tiled loops are lowered the same way, but are not
11165 compatible. In gfc_trans_omp_do, the tile is prioritized. */
11166 if (code->ext.omp_clauses->tile_list)
11167 {
11168 int num = 0;
11169 gfc_expr_list *el;
11170 for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
11171 ++num;
11172 resolve_oacc_nested_loops (code, do_code: code->block->next, collapse: num, clause: "tiled");
11173 return;
11174 }
11175
11176 if (collapse <= 0)
11177 collapse = 1;
11178 resolve_oacc_nested_loops (code, do_code, collapse, clause: "collapsed");
11179}
11180
11181void
11182gfc_resolve_oacc_declare (gfc_namespace *ns)
11183{
11184 int list;
11185 gfc_omp_namelist *n;
11186 gfc_oacc_declare *oc;
11187
11188 if (ns->oacc_declare == NULL)
11189 return;
11190
11191 for (oc = ns->oacc_declare; oc; oc = oc->next)
11192 {
11193 for (list = 0; list < OMP_LIST_NUM; list++)
11194 for (n = oc->clauses->lists[list]; n; n = n->next)
11195 {
11196 n->sym->mark = 0;
11197 if (n->sym->attr.flavor != FL_VARIABLE
11198 && (n->sym->attr.flavor != FL_PROCEDURE
11199 || n->sym->result != n->sym))
11200 {
11201 gfc_error ("Object %qs is not a variable at %L",
11202 n->sym->name, &oc->loc);
11203 continue;
11204 }
11205
11206 if (n->expr && n->expr->ref->type == REF_ARRAY)
11207 {
11208 gfc_error ("Array sections: %qs not allowed in"
11209 " !$ACC DECLARE at %L", n->sym->name, &oc->loc);
11210 continue;
11211 }
11212 }
11213
11214 for (n = oc->clauses->lists[OMP_LIST_DEVICE_RESIDENT]; n; n = n->next)
11215 check_array_not_assumed (sym: n->sym, loc: oc->loc, name: "DEVICE_RESIDENT");
11216 }
11217
11218 for (oc = ns->oacc_declare; oc; oc = oc->next)
11219 {
11220 for (list = 0; list < OMP_LIST_NUM; list++)
11221 for (n = oc->clauses->lists[list]; n; n = n->next)
11222 {
11223 if (n->sym->mark)
11224 {
11225 gfc_error ("Symbol %qs present on multiple clauses at %L",
11226 n->sym->name, &oc->loc);
11227 continue;
11228 }
11229 else
11230 n->sym->mark = 1;
11231 }
11232 }
11233
11234 for (oc = ns->oacc_declare; oc; oc = oc->next)
11235 {
11236 for (list = 0; list < OMP_LIST_NUM; list++)
11237 for (n = oc->clauses->lists[list]; n; n = n->next)
11238 n->sym->mark = 0;
11239 }
11240}
11241
11242
11243void
11244gfc_resolve_oacc_routines (gfc_namespace *ns)
11245{
11246 for (gfc_oacc_routine_name *orn = ns->oacc_routine_names;
11247 orn;
11248 orn = orn->next)
11249 {
11250 gfc_symbol *sym = orn->sym;
11251 if (!sym->attr.external
11252 && !sym->attr.function
11253 && !sym->attr.subroutine)
11254 {
11255 gfc_error ("NAME %qs does not refer to a subroutine or function"
11256 " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
11257 continue;
11258 }
11259 if (!gfc_add_omp_declare_target (&sym->attr, sym->name, &orn->loc))
11260 {
11261 gfc_error ("NAME %qs invalid"
11262 " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
11263 continue;
11264 }
11265 }
11266}
11267
11268
11269void
11270gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
11271{
11272 resolve_oacc_directive_inside_omp_region (code);
11273
11274 switch (code->op)
11275 {
11276 case EXEC_OACC_PARALLEL:
11277 case EXEC_OACC_KERNELS:
11278 case EXEC_OACC_SERIAL:
11279 case EXEC_OACC_DATA:
11280 case EXEC_OACC_HOST_DATA:
11281 case EXEC_OACC_UPDATE:
11282 case EXEC_OACC_ENTER_DATA:
11283 case EXEC_OACC_EXIT_DATA:
11284 case EXEC_OACC_WAIT:
11285 case EXEC_OACC_CACHE:
11286 resolve_omp_clauses (code, omp_clauses: code->ext.omp_clauses, NULL, openacc: true);
11287 break;
11288 case EXEC_OACC_PARALLEL_LOOP:
11289 case EXEC_OACC_KERNELS_LOOP:
11290 case EXEC_OACC_SERIAL_LOOP:
11291 case EXEC_OACC_LOOP:
11292 resolve_oacc_loop (code);
11293 break;
11294 case EXEC_OACC_ATOMIC:
11295 resolve_omp_atomic (code);
11296 break;
11297 default:
11298 break;
11299 }
11300}
11301
11302
11303static void
11304resolve_omp_target (gfc_code *code)
11305{
11306#define GFC_IS_TEAMS_CONSTRUCT(op) \
11307 (op == EXEC_OMP_TEAMS \
11308 || op == EXEC_OMP_TEAMS_DISTRIBUTE \
11309 || op == EXEC_OMP_TEAMS_DISTRIBUTE_SIMD \
11310 || op == EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO \
11311 || op == EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD \
11312 || op == EXEC_OMP_TEAMS_LOOP)
11313
11314 if (!code->ext.omp_clauses->contains_teams_construct)
11315 return;
11316 gfc_code *c = code->block->next;
11317 if (c->op == EXEC_BLOCK)
11318 c = c->ext.block.ns->code;
11319 if (code->ext.omp_clauses->target_first_st_is_teams
11320 && ((GFC_IS_TEAMS_CONSTRUCT (c->op) && c->next == NULL)
11321 || (c->op == EXEC_BLOCK
11322 && c->next
11323 && GFC_IS_TEAMS_CONSTRUCT (c->next->op)
11324 && c->next->next == NULL)))
11325 return;
11326 while (c && !GFC_IS_TEAMS_CONSTRUCT (c->op))
11327 c = c->next;
11328 if (c)
11329 gfc_error ("!$OMP TARGET region at %L with a nested TEAMS at %L may not "
11330 "contain any other statement, declaration or directive outside "
11331 "of the single TEAMS construct", &c->loc, &code->loc);
11332 else
11333 gfc_error ("!$OMP TARGET region at %L with a nested TEAMS may not "
11334 "contain any other statement, declaration or directive outside "
11335 "of the single TEAMS construct", &code->loc);
11336#undef GFC_IS_TEAMS_CONSTRUCT
11337}
11338
11339
11340/* Resolve OpenMP directive clauses and check various requirements
11341 of each directive. */
11342
11343void
11344gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns)
11345{
11346 resolve_omp_directive_inside_oacc_region (code);
11347
11348 if (code->op != EXEC_OMP_ATOMIC)
11349 gfc_maybe_initialize_eh ();
11350
11351 switch (code->op)
11352 {
11353 case EXEC_OMP_DISTRIBUTE:
11354 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
11355 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
11356 case EXEC_OMP_DISTRIBUTE_SIMD:
11357 case EXEC_OMP_DO:
11358 case EXEC_OMP_DO_SIMD:
11359 case EXEC_OMP_LOOP:
11360 case EXEC_OMP_PARALLEL_DO:
11361 case EXEC_OMP_PARALLEL_DO_SIMD:
11362 case EXEC_OMP_PARALLEL_LOOP:
11363 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
11364 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
11365 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
11366 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
11367 case EXEC_OMP_MASKED_TASKLOOP:
11368 case EXEC_OMP_MASKED_TASKLOOP_SIMD:
11369 case EXEC_OMP_MASTER_TASKLOOP:
11370 case EXEC_OMP_MASTER_TASKLOOP_SIMD:
11371 case EXEC_OMP_SIMD:
11372 case EXEC_OMP_TARGET_PARALLEL_DO:
11373 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
11374 case EXEC_OMP_TARGET_PARALLEL_LOOP:
11375 case EXEC_OMP_TARGET_SIMD:
11376 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
11377 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
11378 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
11379 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
11380 case EXEC_OMP_TARGET_TEAMS_LOOP:
11381 case EXEC_OMP_TASKLOOP:
11382 case EXEC_OMP_TASKLOOP_SIMD:
11383 case EXEC_OMP_TEAMS_DISTRIBUTE:
11384 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
11385 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
11386 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
11387 case EXEC_OMP_TEAMS_LOOP:
11388 resolve_omp_do (code);
11389 break;
11390 case EXEC_OMP_TARGET:
11391 resolve_omp_target (code);
11392 gcc_fallthrough ();
11393 case EXEC_OMP_ALLOCATE:
11394 case EXEC_OMP_ALLOCATORS:
11395 case EXEC_OMP_ASSUME:
11396 case EXEC_OMP_CANCEL:
11397 case EXEC_OMP_ERROR:
11398 case EXEC_OMP_MASKED:
11399 case EXEC_OMP_ORDERED:
11400 case EXEC_OMP_PARALLEL_WORKSHARE:
11401 case EXEC_OMP_PARALLEL:
11402 case EXEC_OMP_PARALLEL_MASKED:
11403 case EXEC_OMP_PARALLEL_MASTER:
11404 case EXEC_OMP_PARALLEL_SECTIONS:
11405 case EXEC_OMP_SCOPE:
11406 case EXEC_OMP_SECTIONS:
11407 case EXEC_OMP_SINGLE:
11408 case EXEC_OMP_TARGET_DATA:
11409 case EXEC_OMP_TARGET_ENTER_DATA:
11410 case EXEC_OMP_TARGET_EXIT_DATA:
11411 case EXEC_OMP_TARGET_PARALLEL:
11412 case EXEC_OMP_TARGET_TEAMS:
11413 case EXEC_OMP_TASK:
11414 case EXEC_OMP_TASKWAIT:
11415 case EXEC_OMP_TEAMS:
11416 case EXEC_OMP_WORKSHARE:
11417 case EXEC_OMP_DEPOBJ:
11418 if (code->ext.omp_clauses)
11419 resolve_omp_clauses (code, omp_clauses: code->ext.omp_clauses, NULL);
11420 break;
11421 case EXEC_OMP_TARGET_UPDATE:
11422 if (code->ext.omp_clauses)
11423 resolve_omp_clauses (code, omp_clauses: code->ext.omp_clauses, NULL);
11424 if (code->ext.omp_clauses == NULL
11425 || (code->ext.omp_clauses->lists[OMP_LIST_TO] == NULL
11426 && code->ext.omp_clauses->lists[OMP_LIST_FROM] == NULL))
11427 gfc_error ("OMP TARGET UPDATE at %L requires at least one TO or "
11428 "FROM clause", &code->loc);
11429 break;
11430 case EXEC_OMP_ATOMIC:
11431 resolve_omp_clauses (code, omp_clauses: code->block->ext.omp_clauses, NULL);
11432 resolve_omp_atomic (code);
11433 break;
11434 case EXEC_OMP_CRITICAL:
11435 resolve_omp_clauses (code, omp_clauses: code->ext.omp_clauses, NULL);
11436 if (!code->ext.omp_clauses->critical_name
11437 && code->ext.omp_clauses->hint
11438 && code->ext.omp_clauses->hint->ts.type == BT_INTEGER
11439 && code->ext.omp_clauses->hint->expr_type == EXPR_CONSTANT
11440 && mpz_sgn (code->ext.omp_clauses->hint->value.integer) != 0)
11441 gfc_error ("OMP CRITICAL at %L with HINT clause requires a NAME, "
11442 "except when omp_sync_hint_none is used", &code->loc);
11443 break;
11444 case EXEC_OMP_SCAN:
11445 /* Flag is only used to checking, hence, it is unset afterwards. */
11446 if (!code->ext.omp_clauses->if_present)
11447 gfc_error ("Unexpected !$OMP SCAN at %L outside loop construct with "
11448 "%<inscan%> REDUCTION clause", &code->loc);
11449 code->ext.omp_clauses->if_present = false;
11450 resolve_omp_clauses (code, omp_clauses: code->ext.omp_clauses, ns);
11451 break;
11452 default:
11453 break;
11454 }
11455}
11456
11457/* Resolve !$omp declare simd constructs in NS. */
11458
11459void
11460gfc_resolve_omp_declare_simd (gfc_namespace *ns)
11461{
11462 gfc_omp_declare_simd *ods;
11463
11464 for (ods = ns->omp_declare_simd; ods; ods = ods->next)
11465 {
11466 if (ods->proc_name != NULL
11467 && ods->proc_name != ns->proc_name)
11468 gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure "
11469 "%qs at %L", ns->proc_name->name, &ods->where);
11470 if (ods->clauses)
11471 resolve_omp_clauses (NULL, omp_clauses: ods->clauses, ns);
11472 }
11473}
11474
11475struct omp_udr_callback_data
11476{
11477 gfc_omp_udr *omp_udr;
11478 bool is_initializer;
11479};
11480
11481static int
11482omp_udr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
11483 void *data)
11484{
11485 struct omp_udr_callback_data *cd = (struct omp_udr_callback_data *) data;
11486 if ((*e)->expr_type == EXPR_VARIABLE)
11487 {
11488 if (cd->is_initializer)
11489 {
11490 if ((*e)->symtree->n.sym != cd->omp_udr->omp_priv
11491 && (*e)->symtree->n.sym != cd->omp_udr->omp_orig)
11492 gfc_error ("Variable other than OMP_PRIV or OMP_ORIG used in "
11493 "INITIALIZER clause of !$OMP DECLARE REDUCTION at %L",
11494 &(*e)->where);
11495 }
11496 else
11497 {
11498 if ((*e)->symtree->n.sym != cd->omp_udr->omp_out
11499 && (*e)->symtree->n.sym != cd->omp_udr->omp_in)
11500 gfc_error ("Variable other than OMP_OUT or OMP_IN used in "
11501 "combiner of !$OMP DECLARE REDUCTION at %L",
11502 &(*e)->where);
11503 }
11504 }
11505 return 0;
11506}
11507
11508/* Resolve !$omp declare reduction constructs. */
11509
11510static void
11511gfc_resolve_omp_udr (gfc_omp_udr *omp_udr)
11512{
11513 gfc_actual_arglist *a;
11514 const char *predef_name = NULL;
11515
11516 switch (omp_udr->rop)
11517 {
11518 case OMP_REDUCTION_PLUS:
11519 case OMP_REDUCTION_TIMES:
11520 case OMP_REDUCTION_MINUS:
11521 case OMP_REDUCTION_AND:
11522 case OMP_REDUCTION_OR:
11523 case OMP_REDUCTION_EQV:
11524 case OMP_REDUCTION_NEQV:
11525 case OMP_REDUCTION_MAX:
11526 case OMP_REDUCTION_USER:
11527 break;
11528 default:
11529 gfc_error ("Invalid operator for !$OMP DECLARE REDUCTION %s at %L",
11530 omp_udr->name, &omp_udr->where);
11531 return;
11532 }
11533
11534 if (gfc_omp_udr_predef (rop: omp_udr->rop, name: omp_udr->name,
11535 ts: &omp_udr->ts, n: &predef_name))
11536 {
11537 if (predef_name)
11538 gfc_error_now ("Redefinition of predefined %s "
11539 "!$OMP DECLARE REDUCTION at %L",
11540 predef_name, &omp_udr->where);
11541 else
11542 gfc_error_now ("Redefinition of predefined "
11543 "!$OMP DECLARE REDUCTION at %L", &omp_udr->where);
11544 return;
11545 }
11546
11547 if (omp_udr->ts.type == BT_CHARACTER
11548 && omp_udr->ts.u.cl->length
11549 && omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
11550 {
11551 gfc_error ("CHARACTER length in !$OMP DECLARE REDUCTION %s not "
11552 "constant at %L", omp_udr->name, &omp_udr->where);
11553 return;
11554 }
11555
11556 struct omp_udr_callback_data cd;
11557 cd.omp_udr = omp_udr;
11558 cd.is_initializer = false;
11559 gfc_code_walker (&omp_udr->combiner_ns->code, gfc_dummy_code_callback,
11560 omp_udr_callback, &cd);
11561 if (omp_udr->combiner_ns->code->op == EXEC_CALL)
11562 {
11563 for (a = omp_udr->combiner_ns->code->ext.actual; a; a = a->next)
11564 if (a->expr == NULL)
11565 break;
11566 if (a)
11567 gfc_error ("Subroutine call with alternate returns in combiner "
11568 "of !$OMP DECLARE REDUCTION at %L",
11569 &omp_udr->combiner_ns->code->loc);
11570 }
11571 if (omp_udr->initializer_ns)
11572 {
11573 cd.is_initializer = true;
11574 gfc_code_walker (&omp_udr->initializer_ns->code, gfc_dummy_code_callback,
11575 omp_udr_callback, &cd);
11576 if (omp_udr->initializer_ns->code->op == EXEC_CALL)
11577 {
11578 for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
11579 if (a->expr == NULL)
11580 break;
11581 if (a)
11582 gfc_error ("Subroutine call with alternate returns in "
11583 "INITIALIZER clause of !$OMP DECLARE REDUCTION "
11584 "at %L", &omp_udr->initializer_ns->code->loc);
11585 for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
11586 if (a->expr
11587 && a->expr->expr_type == EXPR_VARIABLE
11588 && a->expr->symtree->n.sym == omp_udr->omp_priv
11589 && a->expr->ref == NULL)
11590 break;
11591 if (a == NULL)
11592 gfc_error ("One of actual subroutine arguments in INITIALIZER "
11593 "clause of !$OMP DECLARE REDUCTION must be OMP_PRIV "
11594 "at %L", &omp_udr->initializer_ns->code->loc);
11595 }
11596 }
11597 else if (omp_udr->ts.type == BT_DERIVED
11598 && !gfc_has_default_initializer (omp_udr->ts.u.derived))
11599 {
11600 gfc_error ("Missing INITIALIZER clause for !$OMP DECLARE REDUCTION "
11601 "of derived type without default initializer at %L",
11602 &omp_udr->where);
11603 return;
11604 }
11605}
11606
11607void
11608gfc_resolve_omp_udrs (gfc_symtree *st)
11609{
11610 gfc_omp_udr *omp_udr;
11611
11612 if (st == NULL)
11613 return;
11614 gfc_resolve_omp_udrs (st: st->left);
11615 gfc_resolve_omp_udrs (st: st->right);
11616 for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
11617 gfc_resolve_omp_udr (omp_udr);
11618}
11619

source code of gcc/fortran/openmp.cc