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