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