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