projects / gcc.git / blob
? search:


35f6b2f4938bd96a26cf5de5d68b3c1436aea8fd
[gcc.git] / gcc / fortran / openmp.c
1 /* OpenMP directive matching and resolving.
2 Copyright (C) 2005-2020 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 "diagnostic.h"
29 #include "gomp-constants.h"
30
31 /* Match an end of OpenMP directive. End of OpenMP directive is optional
32 whitespace, followed by '\n' or comment '!'. */
33
34 static match
35 gfc_match_omp_eos (void)
36 {
37 locus old_loc;
38 char c;
39
40 old_loc = gfc_current_locus;
41 gfc_gobble_whitespace ();
42
43 c = gfc_next_ascii_char ();
44 switch (c)
45 {
46 case '!':
47 do
48 c = gfc_next_ascii_char ();
49 while (c != '\n');
50 /* Fall through */
51
52 case '\n':
53 return MATCH_YES;
54 }
55
56 gfc_current_locus = old_loc;
57 return MATCH_NO;
58 }
59
60 match
61 gfc_match_omp_eos_error (void)
62 {
63 if (gfc_match_omp_eos() == MATCH_YES)
64 return MATCH_YES;
65
66 gfc_error ("Unexpected junk at %C");
67 return MATCH_ERROR;
68 }
69
70
71 /* Free an omp_clauses structure. */
72
73 void
74 gfc_free_omp_clauses (gfc_omp_clauses *c)
75 {
76 int i;
77 if (c == NULL)
78 return;
79
80 gfc_free_expr (c->if_expr);
81 gfc_free_expr (c->final_expr);
82 gfc_free_expr (c->num_threads);
83 gfc_free_expr (c->chunk_size);
84 gfc_free_expr (c->safelen_expr);
85 gfc_free_expr (c->simdlen_expr);
86 gfc_free_expr (c->num_teams);
87 gfc_free_expr (c->device);
88 gfc_free_expr (c->thread_limit);
89 gfc_free_expr (c->dist_chunk_size);
90 gfc_free_expr (c->grainsize);
91 gfc_free_expr (c->hint);
92 gfc_free_expr (c->num_tasks);
93 gfc_free_expr (c->priority);
94 for (i = 0; i < OMP_IF_LAST; i++)
95 gfc_free_expr (c->if_exprs[i]);
96 gfc_free_expr (c->async_expr);
97 gfc_free_expr (c->gang_num_expr);
98 gfc_free_expr (c->gang_static_expr);
99 gfc_free_expr (c->worker_expr);
100 gfc_free_expr (c->vector_expr);
101 gfc_free_expr (c->num_gangs_expr);
102 gfc_free_expr (c->num_workers_expr);
103 gfc_free_expr (c->vector_length_expr);
104 for (i = 0; i < OMP_LIST_NUM; i++)
105 gfc_free_omp_namelist (c->lists[i]);
106 gfc_free_expr_list (c->wait_list);
107 gfc_free_expr_list (c->tile_list);
108 free (CONST_CAST (char *, c->critical_name));
109 free (c);
110 }
111
112 /* Free oacc_declare structures. */
113
114 void
115 gfc_free_oacc_declare_clauses (struct gfc_oacc_declare *oc)
116 {
117 struct gfc_oacc_declare *decl = oc;
118
119 do
120 {
121 struct gfc_oacc_declare *next;
122
123 next = decl->next;
124 gfc_free_omp_clauses (decl->clauses);
125 free (decl);
126 decl = next;
127 }
128 while (decl);
129 }
130
131 /* Free expression list. */
132 void
133 gfc_free_expr_list (gfc_expr_list *list)
134 {
135 gfc_expr_list *n;
136
137 for (; list; list = n)
138 {
139 n = list->next;
140 free (list);
141 }
142 }
143
144 /* Free an !$omp declare simd construct list. */
145
146 void
147 gfc_free_omp_declare_simd (gfc_omp_declare_simd *ods)
148 {
149 if (ods)
150 {
151 gfc_free_omp_clauses (ods->clauses);
152 free (ods);
153 }
154 }
155
156 void
157 gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *list)
158 {
159 while (list)
160 {
161 gfc_omp_declare_simd *current = list;
162 list = list->next;
163 gfc_free_omp_declare_simd (current);
164 }
165 }
166
167 /* Free an !$omp declare reduction. */
168
169 void
170 gfc_free_omp_udr (gfc_omp_udr *omp_udr)
171 {
172 if (omp_udr)
173 {
174 gfc_free_omp_udr (omp_udr->next);
175 gfc_free_namespace (omp_udr->combiner_ns);
176 if (omp_udr->initializer_ns)
177 gfc_free_namespace (omp_udr->initializer_ns);
178 free (omp_udr);
179 }
180 }
181
182
183 static gfc_omp_udr *
184 gfc_find_omp_udr (gfc_namespace *ns, const char *name, gfc_typespec *ts)
185 {
186 gfc_symtree *st;
187
188 if (ns == NULL)
189 ns = gfc_current_ns;
190 do
191 {
192 gfc_omp_udr *omp_udr;
193
194 st = gfc_find_symtree (ns->omp_udr_root, name);
195 if (st != NULL)
196 {
197 for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
198 if (ts == NULL)
199 return omp_udr;
200 else if (gfc_compare_types (&omp_udr->ts, ts))
201 {
202 if (ts->type == BT_CHARACTER)
203 {
204 if (omp_udr->ts.u.cl->length == NULL)
205 return omp_udr;
206 if (ts->u.cl->length == NULL)
207 continue;
208 if (gfc_compare_expr (omp_udr->ts.u.cl->length,
209 ts->u.cl->length,
210 INTRINSIC_EQ) != 0)
211 continue;
212 }
213 return omp_udr;
214 }
215 }
216
217 /* Don't escape an interface block. */
218 if (ns && !ns->has_import_set
219 && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
220 break;
221
222 ns = ns->parent;
223 }
224 while (ns != NULL);
225
226 return NULL;
227 }
228
229
230 /* Match a variable/common block list and construct a namelist from it. */
231
232 static match
233 gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list,
234 bool allow_common, bool *end_colon = NULL,
235 gfc_omp_namelist ***headp = NULL,
236 bool allow_sections = false,
237 bool allow_derived = false)
238 {
239 gfc_omp_namelist *head, *tail, *p;
240 locus old_loc, cur_loc;
241 char n[GFC_MAX_SYMBOL_LEN+1];
242 gfc_symbol *sym;
243 match m;
244 gfc_symtree *st;
245
246 head = tail = NULL;
247
248 old_loc = gfc_current_locus;
249
250 m = gfc_match (str);
251 if (m != MATCH_YES)
252 return m;
253
254 for (;;)
255 {
256 cur_loc = gfc_current_locus;
257 m = gfc_match_symbol (&sym, 1);
258 switch (m)
259 {
260 case MATCH_YES:
261 gfc_expr *expr;
262 expr = NULL;
263 if ((allow_sections && gfc_peek_ascii_char () == '(')
264 || (allow_derived && gfc_peek_ascii_char () == '%'))
265 {
266 gfc_current_locus = cur_loc;
267 m = gfc_match_variable (&expr, 0);
268 switch (m)
269 {
270 case MATCH_ERROR:
271 goto cleanup;
272 case MATCH_NO:
273 goto syntax;
274 default:
275 break;
276 }
277 if (gfc_is_coindexed (expr))
278 {
279 gfc_error ("List item shall not be coindexed at %C");
280 goto cleanup;
281 }
282 }
283 gfc_set_sym_referenced (sym);
284 p = gfc_get_omp_namelist ();
285 if (head == NULL)
286 head = tail = p;
287 else
288 {
289 tail->next = p;
290 tail = tail->next;
291 }
292 tail->sym = sym;
293 tail->expr = expr;
294 tail->where = cur_loc;
295 goto next_item;
296 case MATCH_NO:
297 break;
298 case MATCH_ERROR:
299 goto cleanup;
300 }
301
302 if (!allow_common)
303 goto syntax;
304
305 m = gfc_match (" / %n /", n);
306 if (m == MATCH_ERROR)
307 goto cleanup;
308 if (m == MATCH_NO)
309 goto syntax;
310
311 st = gfc_find_symtree (gfc_current_ns->common_root, n);
312 if (st == NULL)
313 {
314 gfc_error ("COMMON block /%s/ not found at %C", n);
315 goto cleanup;
316 }
317 for (sym = st->n.common->head; sym; sym = sym->common_next)
318 {
319 gfc_set_sym_referenced (sym);
320 p = gfc_get_omp_namelist ();
321 if (head == NULL)
322 head = tail = p;
323 else
324 {
325 tail->next = p;
326 tail = tail->next;
327 }
328 tail->sym = sym;
329 tail->where = cur_loc;
330 }
331
332 next_item:
333 if (end_colon && gfc_match_char (':') == MATCH_YES)
334 {
335 *end_colon = true;
336 break;
337 }
338 if (gfc_match_char (')') == MATCH_YES)
339 break;
340 if (gfc_match_char (',') != MATCH_YES)
341 goto syntax;
342 }
343
344 while (*list)
345 list = &(*list)->next;
346
347 *list = head;
348 if (headp)
349 *headp = list;
350 return MATCH_YES;
351
352 syntax:
353 gfc_error ("Syntax error in OpenMP variable list at %C");
354
355 cleanup:
356 gfc_free_omp_namelist (head);
357 gfc_current_locus = old_loc;
358 return MATCH_ERROR;
359 }
360
361 /* Match a variable/procedure/common block list and construct a namelist
362 from it. */
363
364 static match
365 gfc_match_omp_to_link (const char *str, gfc_omp_namelist **list)
366 {
367 gfc_omp_namelist *head, *tail, *p;
368 locus old_loc, cur_loc;
369 char n[GFC_MAX_SYMBOL_LEN+1];
370 gfc_symbol *sym;
371 match m;
372 gfc_symtree *st;
373
374 head = tail = NULL;
375
376 old_loc = gfc_current_locus;
377
378 m = gfc_match (str);
379 if (m != MATCH_YES)
380 return m;
381
382 for (;;)
383 {
384 cur_loc = gfc_current_locus;
385 m = gfc_match_symbol (&sym, 1);
386 switch (m)
387 {
388 case MATCH_YES:
389 p = gfc_get_omp_namelist ();
390 if (head == NULL)
391 head = tail = p;
392 else
393 {
394 tail->next = p;
395 tail = tail->next;
396 }
397 tail->sym = sym;
398 tail->where = cur_loc;
399 goto next_item;
400 case MATCH_NO:
401 break;
402 case MATCH_ERROR:
403 goto cleanup;
404 }
405
406 m = gfc_match (" / %n /", n);
407 if (m == MATCH_ERROR)
408 goto cleanup;
409 if (m == MATCH_NO)
410 goto syntax;
411
412 st = gfc_find_symtree (gfc_current_ns->common_root, n);
413 if (st == NULL)
414 {
415 gfc_error ("COMMON block /%s/ not found at %C", n);
416 goto cleanup;
417 }
418 p = gfc_get_omp_namelist ();
419 if (head == NULL)
420 head = tail = p;
421 else
422 {
423 tail->next = p;
424 tail = tail->next;
425 }
426 tail->u.common = st->n.common;
427 tail->where = cur_loc;
428
429 next_item:
430 if (gfc_match_char (')') == MATCH_YES)
431 break;
432 if (gfc_match_char (',') != MATCH_YES)
433 goto syntax;
434 }
435
436 while (*list)
437 list = &(*list)->next;
438
439 *list = head;
440 return MATCH_YES;
441
442 syntax:
443 gfc_error ("Syntax error in OpenMP variable list at %C");
444
445 cleanup:
446 gfc_free_omp_namelist (head);
447 gfc_current_locus = old_loc;
448 return MATCH_ERROR;
449 }
450
451 /* Match depend(sink : ...) construct a namelist from it. */
452
453 static match
454 gfc_match_omp_depend_sink (gfc_omp_namelist **list)
455 {
456 gfc_omp_namelist *head, *tail, *p;
457 locus old_loc, cur_loc;
458 gfc_symbol *sym;
459
460 head = tail = NULL;
461
462 old_loc = gfc_current_locus;
463
464 for (;;)
465 {
466 cur_loc = gfc_current_locus;
467 switch (gfc_match_symbol (&sym, 1))
468 {
469 case MATCH_YES:
470 gfc_set_sym_referenced (sym);
471 p = gfc_get_omp_namelist ();
472 if (head == NULL)
473 {
474 head = tail = p;
475 head->u.depend_op = OMP_DEPEND_SINK_FIRST;
476 }
477 else
478 {
479 tail->next = p;
480 tail = tail->next;
481 tail->u.depend_op = OMP_DEPEND_SINK;
482 }
483 tail->sym = sym;
484 tail->expr = NULL;
485 tail->where = cur_loc;
486 if (gfc_match_char ('+') == MATCH_YES)
487 {
488 if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES)
489 goto syntax;
490 }
491 else if (gfc_match_char ('-') == MATCH_YES)
492 {
493 if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES)
494 goto syntax;
495 tail->expr = gfc_uminus (tail->expr);
496 }
497 break;
498 case MATCH_NO:
499 goto syntax;
500 case MATCH_ERROR:
501 goto cleanup;
502 }
503
504 if (gfc_match_char (')') == MATCH_YES)
505 break;
506 if (gfc_match_char (',') != MATCH_YES)
507 goto syntax;
508 }
509
510 while (*list)
511 list = &(*list)->next;
512
513 *list = head;
514 return MATCH_YES;
515
516 syntax:
517 gfc_error ("Syntax error in OpenMP DEPEND SINK list at %C");
518
519 cleanup:
520 gfc_free_omp_namelist (head);
521 gfc_current_locus = old_loc;
522 return MATCH_ERROR;
523 }
524
525 static match
526 match_oacc_expr_list (const char *str, gfc_expr_list **list,
527 bool allow_asterisk)
528 {
529 gfc_expr_list *head, *tail, *p;
530 locus old_loc;
531 gfc_expr *expr;
532 match m;
533
534 head = tail = NULL;
535
536 old_loc = gfc_current_locus;
537
538 m = gfc_match (str);
539 if (m != MATCH_YES)
540 return m;
541
542 for (;;)
543 {
544 m = gfc_match_expr (&expr);
545 if (m == MATCH_YES || allow_asterisk)
546 {
547 p = gfc_get_expr_list ();
548 if (head == NULL)
549 head = tail = p;
550 else
551 {
552 tail->next = p;
553 tail = tail->next;
554 }
555 if (m == MATCH_YES)
556 tail->expr = expr;
557 else if (gfc_match (" *") != MATCH_YES)
558 goto syntax;
559 goto next_item;
560 }
561 if (m == MATCH_ERROR)
562 goto cleanup;
563 goto syntax;
564
565 next_item:
566 if (gfc_match_char (')') == MATCH_YES)
567 break;
568 if (gfc_match_char (',') != MATCH_YES)
569 goto syntax;
570 }
571
572 while (*list)
573 list = &(*list)->next;
574
575 *list = head;
576 return MATCH_YES;
577
578 syntax:
579 gfc_error ("Syntax error in OpenACC expression list at %C");
580
581 cleanup:
582 gfc_free_expr_list (head);
583 gfc_current_locus = old_loc;
584 return MATCH_ERROR;
585 }
586
587 static match
588 match_oacc_clause_gwv (gfc_omp_clauses *cp, unsigned gwv)
589 {
590 match ret = MATCH_YES;
591
592 if (gfc_match (" ( ") != MATCH_YES)
593 return MATCH_NO;
594
595 if (gwv == GOMP_DIM_GANG)
596 {
597 /* The gang clause accepts two optional arguments, num and static.
598 The num argument may either be explicit (num: <val>) or
599 implicit without (<val> without num:). */
600
601 while (ret == MATCH_YES)
602 {
603 if (gfc_match (" static :") == MATCH_YES)
604 {
605 if (cp->gang_static)
606 return MATCH_ERROR;
607 else
608 cp->gang_static = true;
609 if (gfc_match_char ('*') == MATCH_YES)
610 cp->gang_static_expr = NULL;
611 else if (gfc_match (" %e ", &cp->gang_static_expr) != MATCH_YES)
612 return MATCH_ERROR;
613 }
614 else
615 {
616 if (cp->gang_num_expr)
617 return MATCH_ERROR;
618
619 /* The 'num' argument is optional. */
620 gfc_match (" num :");
621
622 if (gfc_match (" %e ", &cp->gang_num_expr) != MATCH_YES)
623 return MATCH_ERROR;
624 }
625
626 ret = gfc_match (" , ");
627 }
628 }
629 else if (gwv == GOMP_DIM_WORKER)
630 {
631 /* The 'num' argument is optional. */
632 gfc_match (" num :");
633
634 if (gfc_match (" %e ", &cp->worker_expr) != MATCH_YES)
635 return MATCH_ERROR;
636 }
637 else if (gwv == GOMP_DIM_VECTOR)
638 {
639 /* The 'length' argument is optional. */
640 gfc_match (" length :");
641
642 if (gfc_match (" %e ", &cp->vector_expr) != MATCH_YES)
643 return MATCH_ERROR;
644 }
645 else
646 gfc_fatal_error ("Unexpected OpenACC parallelism.");
647
648 return gfc_match (" )");
649 }
650
651 static match
652 gfc_match_oacc_clause_link (const char *str, gfc_omp_namelist **list)
653 {
654 gfc_omp_namelist *head = NULL;
655 gfc_omp_namelist *tail, *p;
656 locus old_loc;
657 char n[GFC_MAX_SYMBOL_LEN+1];
658 gfc_symbol *sym;
659 match m;
660 gfc_symtree *st;
661
662 old_loc = gfc_current_locus;
663
664 m = gfc_match (str);
665 if (m != MATCH_YES)
666 return m;
667
668 m = gfc_match (" (");
669
670 for (;;)
671 {
672 m = gfc_match_symbol (&sym, 0);
673 switch (m)
674 {
675 case MATCH_YES:
676 if (sym->attr.in_common)
677 {
678 gfc_error_now ("Variable at %C is an element of a COMMON block");
679 goto cleanup;
680 }
681 gfc_set_sym_referenced (sym);
682 p = gfc_get_omp_namelist ();
683 if (head == NULL)
684 head = tail = p;
685 else
686 {
687 tail->next = p;
688 tail = tail->next;
689 }
690 tail->sym = sym;
691 tail->expr = NULL;
692 tail->where = gfc_current_locus;
693 goto next_item;
694 case MATCH_NO:
695 break;
696
697 case MATCH_ERROR:
698 goto cleanup;
699 }
700
701 m = gfc_match (" / %n /", n);
702 if (m == MATCH_ERROR)
703 goto cleanup;
704 if (m == MATCH_NO || n[0] == '\0')
705 goto syntax;
706
707 st = gfc_find_symtree (gfc_current_ns->common_root, n);
708 if (st == NULL)
709 {
710 gfc_error ("COMMON block /%s/ not found at %C", n);
711 goto cleanup;
712 }
713
714 for (sym = st->n.common->head; sym; sym = sym->common_next)
715 {
716 gfc_set_sym_referenced (sym);
717 p = gfc_get_omp_namelist ();
718 if (head == NULL)
719 head = tail = p;
720 else
721 {
722 tail->next = p;
723 tail = tail->next;
724 }
725 tail->sym = sym;
726 tail->where = gfc_current_locus;
727 }
728
729 next_item:
730 if (gfc_match_char (')') == MATCH_YES)
731 break;
732 if (gfc_match_char (',') != MATCH_YES)
733 goto syntax;
734 }
735
736 if (gfc_match_omp_eos () != MATCH_YES)
737 {
738 gfc_error ("Unexpected junk after !$ACC DECLARE at %C");
739 goto cleanup;
740 }
741
742 while (*list)
743 list = &(*list)->next;
744 *list = head;
745 return MATCH_YES;
746
747 syntax:
748 gfc_error ("Syntax error in !$ACC DECLARE list at %C");
749
750 cleanup:
751 gfc_current_locus = old_loc;
752 return MATCH_ERROR;
753 }
754
755 /* OpenMP 4.5 clauses. */
756 enum omp_mask1
757 {
758 OMP_CLAUSE_PRIVATE,
759 OMP_CLAUSE_FIRSTPRIVATE,
760 OMP_CLAUSE_LASTPRIVATE,
761 OMP_CLAUSE_COPYPRIVATE,
762 OMP_CLAUSE_SHARED,
763 OMP_CLAUSE_COPYIN,
764 OMP_CLAUSE_REDUCTION,
765 OMP_CLAUSE_IF,
766 OMP_CLAUSE_NUM_THREADS,
767 OMP_CLAUSE_SCHEDULE,
768 OMP_CLAUSE_DEFAULT,
769 OMP_CLAUSE_ORDERED,
770 OMP_CLAUSE_COLLAPSE,
771 OMP_CLAUSE_UNTIED,
772 OMP_CLAUSE_FINAL,
773 OMP_CLAUSE_MERGEABLE,
774 OMP_CLAUSE_ALIGNED,
775 OMP_CLAUSE_DEPEND,
776 OMP_CLAUSE_INBRANCH,
777 OMP_CLAUSE_LINEAR,
778 OMP_CLAUSE_NOTINBRANCH,
779 OMP_CLAUSE_PROC_BIND,
780 OMP_CLAUSE_SAFELEN,
781 OMP_CLAUSE_SIMDLEN,
782 OMP_CLAUSE_UNIFORM,
783 OMP_CLAUSE_DEVICE,
784 OMP_CLAUSE_MAP,
785 OMP_CLAUSE_TO,
786 OMP_CLAUSE_FROM,
787 OMP_CLAUSE_NUM_TEAMS,
788 OMP_CLAUSE_THREAD_LIMIT,
789 OMP_CLAUSE_DIST_SCHEDULE,
790 OMP_CLAUSE_DEFAULTMAP,
791 OMP_CLAUSE_GRAINSIZE,
792 OMP_CLAUSE_HINT,
793 OMP_CLAUSE_IS_DEVICE_PTR,
794 OMP_CLAUSE_LINK,
795 OMP_CLAUSE_NOGROUP,
796 OMP_CLAUSE_NUM_TASKS,
797 OMP_CLAUSE_PRIORITY,
798 OMP_CLAUSE_SIMD,
799 OMP_CLAUSE_THREADS,
800 OMP_CLAUSE_USE_DEVICE_PTR,
801 OMP_CLAUSE_USE_DEVICE_ADDR, /* Actually, OpenMP 5.0. */
802 OMP_CLAUSE_NOWAIT,
803 /* This must come last. */
804 OMP_MASK1_LAST
805 };
806
807 /* OpenACC 2.0+ specific clauses. */
808 enum omp_mask2
809 {
810 OMP_CLAUSE_ASYNC,
811 OMP_CLAUSE_NUM_GANGS,
812 OMP_CLAUSE_NUM_WORKERS,
813 OMP_CLAUSE_VECTOR_LENGTH,
814 OMP_CLAUSE_COPY,
815 OMP_CLAUSE_COPYOUT,
816 OMP_CLAUSE_CREATE,
817 OMP_CLAUSE_NO_CREATE,
818 OMP_CLAUSE_PRESENT,
819 OMP_CLAUSE_DEVICEPTR,
820 OMP_CLAUSE_GANG,
821 OMP_CLAUSE_WORKER,
822 OMP_CLAUSE_VECTOR,
823 OMP_CLAUSE_SEQ,
824 OMP_CLAUSE_INDEPENDENT,
825 OMP_CLAUSE_USE_DEVICE,
826 OMP_CLAUSE_DEVICE_RESIDENT,
827 OMP_CLAUSE_HOST_SELF,
828 OMP_CLAUSE_WAIT,
829 OMP_CLAUSE_DELETE,
830 OMP_CLAUSE_AUTO,
831 OMP_CLAUSE_TILE,
832 OMP_CLAUSE_IF_PRESENT,
833 OMP_CLAUSE_FINALIZE,
834 OMP_CLAUSE_ATTACH,
835 OMP_CLAUSE_DETACH,
836 /* This must come last. */
837 OMP_MASK2_LAST
838 };
839
840 struct omp_inv_mask;
841
842 /* Customized bitset for up to 128-bits.
843 The two enums above provide bit numbers to use, and which of the
844 two enums it is determines which of the two mask fields is used.
845 Supported operations are defining a mask, like:
846 #define XXX_CLAUSES \
847 (omp_mask (OMP_CLAUSE_XXX) | OMP_CLAUSE_YYY | OMP_CLAUSE_ZZZ)
848 oring such bitsets together or removing selected bits:
849 (XXX_CLAUSES | YYY_CLAUSES) & ~(omp_mask (OMP_CLAUSE_VVV))
850 and testing individual bits:
851 if (mask & OMP_CLAUSE_UUU) */
852
853 struct omp_mask {
854 const uint64_t mask1;
855 const uint64_t mask2;
856 inline omp_mask ();
857 inline omp_mask (omp_mask1);
858 inline omp_mask (omp_mask2);
859 inline omp_mask (uint64_t, uint64_t);
860 inline omp_mask operator| (omp_mask1) const;
861 inline omp_mask operator| (omp_mask2) const;
862 inline omp_mask operator| (omp_mask) const;
863 inline omp_mask operator& (const omp_inv_mask &) const;
864 inline bool operator& (omp_mask1) const;
865 inline bool operator& (omp_mask2) const;
866 inline omp_inv_mask operator~ () const;
867 };
868
869 struct omp_inv_mask : public omp_mask {
870 inline omp_inv_mask (const omp_mask &);
871 };
872
873 omp_mask::omp_mask () : mask1 (0), mask2 (0)
874 {
875 }
876
877 omp_mask::omp_mask (omp_mask1 m) : mask1 (((uint64_t) 1) << m), mask2 (0)
878 {
879 }
880
881 omp_mask::omp_mask (omp_mask2 m) : mask1 (0), mask2 (((uint64_t) 1) << m)
882 {
883 }
884
885 omp_mask::omp_mask (uint64_t m1, uint64_t m2) : mask1 (m1), mask2 (m2)
886 {
887 }
888
889 omp_mask
890 omp_mask::operator| (omp_mask1 m) const
891 {
892 return omp_mask (mask1 | (((uint64_t) 1) << m), mask2);
893 }
894
895 omp_mask
896 omp_mask::operator| (omp_mask2 m) const
897 {
898 return omp_mask (mask1, mask2 | (((uint64_t) 1) << m));
899 }
900
901 omp_mask
902 omp_mask::operator| (omp_mask m) const
903 {
904 return omp_mask (mask1 | m.mask1, mask2 | m.mask2);
905 }
906
907 omp_mask
908 omp_mask::operator& (const omp_inv_mask &m) const
909 {
910 return omp_mask (mask1 & ~m.mask1, mask2 & ~m.mask2);
911 }
912
913 bool
914 omp_mask::operator& (omp_mask1 m) const
915 {
916 return (mask1 & (((uint64_t) 1) << m)) != 0;
917 }
918
919 bool
920 omp_mask::operator& (omp_mask2 m) const
921 {
922 return (mask2 & (((uint64_t) 1) << m)) != 0;
923 }
924
925 omp_inv_mask
926 omp_mask::operator~ () const
927 {
928 return omp_inv_mask (*this);
929 }
930
931 omp_inv_mask::omp_inv_mask (const omp_mask &m) : omp_mask (m)
932 {
933 }
934
935 /* Helper function for OpenACC and OpenMP clauses involving memory
936 mapping. */
937
938 static bool
939 gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op,
940 bool allow_common, bool allow_derived)
941 {
942 gfc_omp_namelist **head = NULL;
943 if (gfc_match_omp_variable_list ("", list, allow_common, NULL, &head, true,
944 allow_derived)
945 == MATCH_YES)
946 {
947 gfc_omp_namelist *n;
948 for (n = *head; n; n = n->next)
949 n->u.map_op = map_op;
950 return true;
951 }
952
953 return false;
954 }
955
956 /* Match OpenMP and OpenACC directive clauses. MASK is a bitmask of
957 clauses that are allowed for a particular directive. */
958
959 static match
960 gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
961 bool first = true, bool needs_space = true,
962 bool openacc = false)
963 {
964 gfc_omp_clauses *c = gfc_get_omp_clauses ();
965 locus old_loc;
966 /* Determine whether we're dealing with an OpenACC directive that permits
967 derived type member accesses. This in particular disallows
968 "!$acc declare" from using such accesses, because it's not clear if/how
969 that should work. */
970 bool allow_derived = (openacc
971 && ((mask & OMP_CLAUSE_ATTACH)
972 || (mask & OMP_CLAUSE_DETACH)
973 || (mask & OMP_CLAUSE_HOST_SELF)));
974
975 gcc_checking_assert (OMP_MASK1_LAST <= 64 && OMP_MASK2_LAST <= 64);
976 *cp = NULL;
977 while (1)
978 {
979 if ((first || gfc_match_char (',') != MATCH_YES)
980 && (needs_space && gfc_match_space () != MATCH_YES))
981 break;
982 needs_space = false;
983 first = false;
984 gfc_gobble_whitespace ();
985 bool end_colon;
986 gfc_omp_namelist **head;
987 old_loc = gfc_current_locus;
988 char pc = gfc_peek_ascii_char ();
989 switch (pc)
990 {
991 case 'a':
992 end_colon = false;
993 head = NULL;
994 if ((mask & OMP_CLAUSE_ALIGNED)
995 && gfc_match_omp_variable_list ("aligned (",
996 &c->lists[OMP_LIST_ALIGNED],
997 false, &end_colon,
998 &head) == MATCH_YES)
999 {
1000 gfc_expr *alignment = NULL;
1001 gfc_omp_namelist *n;
1002
1003 if (end_colon && gfc_match (" %e )", &alignment) != MATCH_YES)
1004 {
1005 gfc_free_omp_namelist (*head);
1006 gfc_current_locus = old_loc;
1007 *head = NULL;
1008 break;
1009 }
1010 for (n = *head; n; n = n->next)
1011 if (n->next && alignment)
1012 n->expr = gfc_copy_expr (alignment);
1013 else
1014 n->expr = alignment;
1015 continue;
1016 }
1017 if ((mask & OMP_CLAUSE_ASYNC)
1018 && !c->async
1019 && gfc_match ("async") == MATCH_YES)
1020 {
1021 c->async = true;
1022 match m = gfc_match (" ( %e )", &c->async_expr);
1023 if (m == MATCH_ERROR)
1024 {
1025 gfc_current_locus = old_loc;
1026 break;
1027 }
1028 else if (m == MATCH_NO)
1029 {
1030 c->async_expr
1031 = gfc_get_constant_expr (BT_INTEGER,
1032 gfc_default_integer_kind,
1033 &gfc_current_locus);
1034 mpz_set_si (c->async_expr->value.integer, GOMP_ASYNC_NOVAL);
1035 needs_space = true;
1036 }
1037 continue;
1038 }
1039 if ((mask & OMP_CLAUSE_AUTO)
1040 && !c->par_auto
1041 && gfc_match ("auto") == MATCH_YES)
1042 {
1043 c->par_auto = true;
1044 needs_space = true;
1045 continue;
1046 }
1047 if ((mask & OMP_CLAUSE_ATTACH)
1048 && gfc_match ("attach ( ") == MATCH_YES
1049 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1050 OMP_MAP_ATTACH, false,
1051 allow_derived))
1052 continue;
1053 break;
1054 case 'c':
1055 if ((mask & OMP_CLAUSE_COLLAPSE)
1056 && !c->collapse)
1057 {
1058 gfc_expr *cexpr = NULL;
1059 match m = gfc_match ("collapse ( %e )", &cexpr);
1060
1061 if (m == MATCH_YES)
1062 {
1063 int collapse;
1064 if (gfc_extract_int (cexpr, &collapse, -1))
1065 collapse = 1;
1066 else if (collapse <= 0)
1067 {
1068 gfc_error_now ("COLLAPSE clause argument not"
1069 " constant positive integer at %C");
1070 collapse = 1;
1071 }
1072 c->collapse = collapse;
1073 gfc_free_expr (cexpr);
1074 continue;
1075 }
1076 }
1077 if ((mask & OMP_CLAUSE_COPY)
1078 && gfc_match ("copy ( ") == MATCH_YES
1079 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1080 OMP_MAP_TOFROM, true,
1081 allow_derived))
1082 continue;
1083 if (mask & OMP_CLAUSE_COPYIN)
1084 {
1085 if (openacc)
1086 {
1087 if (gfc_match ("copyin ( ") == MATCH_YES
1088 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1089 OMP_MAP_TO, true,
1090 allow_derived))
1091 continue;
1092 }
1093 else if (gfc_match_omp_variable_list ("copyin (",
1094 &c->lists[OMP_LIST_COPYIN],
1095 true) == MATCH_YES)
1096 continue;
1097 }
1098 if ((mask & OMP_CLAUSE_COPYOUT)
1099 && gfc_match ("copyout ( ") == MATCH_YES
1100 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1101 OMP_MAP_FROM, true, allow_derived))
1102 continue;
1103 if ((mask & OMP_CLAUSE_COPYPRIVATE)
1104 && gfc_match_omp_variable_list ("copyprivate (",
1105 &c->lists[OMP_LIST_COPYPRIVATE],
1106 true) == MATCH_YES)
1107 continue;
1108 if ((mask & OMP_CLAUSE_CREATE)
1109 && gfc_match ("create ( ") == MATCH_YES
1110 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1111 OMP_MAP_ALLOC, true, allow_derived))
1112 continue;
1113 break;
1114 case 'd':
1115 if ((mask & OMP_CLAUSE_DEFAULT)
1116 && c->default_sharing == OMP_DEFAULT_UNKNOWN)
1117 {
1118 if (gfc_match ("default ( none )") == MATCH_YES)
1119 c->default_sharing = OMP_DEFAULT_NONE;
1120 else if (openacc)
1121 {
1122 if (gfc_match ("default ( present )") == MATCH_YES)
1123 c->default_sharing = OMP_DEFAULT_PRESENT;
1124 }
1125 else
1126 {
1127 if (gfc_match ("default ( firstprivate )") == MATCH_YES)
1128 c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE;
1129 else if (gfc_match ("default ( private )") == MATCH_YES)
1130 c->default_sharing = OMP_DEFAULT_PRIVATE;
1131 else if (gfc_match ("default ( shared )") == MATCH_YES)
1132 c->default_sharing = OMP_DEFAULT_SHARED;
1133 }
1134 if (c->default_sharing != OMP_DEFAULT_UNKNOWN)
1135 continue;
1136 }
1137 if ((mask & OMP_CLAUSE_DEFAULTMAP)
1138 && !c->defaultmap
1139 && gfc_match ("defaultmap ( tofrom : scalar )") == MATCH_YES)
1140 {
1141 c->defaultmap = true;
1142 continue;
1143 }
1144 if ((mask & OMP_CLAUSE_DELETE)
1145 && gfc_match ("delete ( ") == MATCH_YES
1146 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1147 OMP_MAP_RELEASE, true,
1148 allow_derived))
1149 continue;
1150 if ((mask & OMP_CLAUSE_DEPEND)
1151 && gfc_match ("depend ( ") == MATCH_YES)
1152 {
1153 match m = MATCH_YES;
1154 gfc_omp_depend_op depend_op = OMP_DEPEND_OUT;
1155 if (gfc_match ("inout") == MATCH_YES)
1156 depend_op = OMP_DEPEND_INOUT;
1157 else if (gfc_match ("in") == MATCH_YES)
1158 depend_op = OMP_DEPEND_IN;
1159 else if (gfc_match ("out") == MATCH_YES)
1160 depend_op = OMP_DEPEND_OUT;
1161 else if (!c->depend_source
1162 && gfc_match ("source )") == MATCH_YES)
1163 {
1164 c->depend_source = true;
1165 continue;
1166 }
1167 else if (gfc_match ("sink : ") == MATCH_YES)
1168 {
1169 if (gfc_match_omp_depend_sink (&c->lists[OMP_LIST_DEPEND])
1170 == MATCH_YES)
1171 continue;
1172 m = MATCH_NO;
1173 }
1174 else
1175 m = MATCH_NO;
1176 head = NULL;
1177 if (m == MATCH_YES
1178 && gfc_match_omp_variable_list (" : ",
1179 &c->lists[OMP_LIST_DEPEND],
1180 false, NULL, &head,
1181 true) == MATCH_YES)
1182 {
1183 gfc_omp_namelist *n;
1184 for (n = *head; n; n = n->next)
1185 n->u.depend_op = depend_op;
1186 continue;
1187 }
1188 else
1189 gfc_current_locus = old_loc;
1190 }
1191 if ((mask & OMP_CLAUSE_DETACH)
1192 && gfc_match ("detach ( ") == MATCH_YES
1193 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1194 OMP_MAP_DETACH, false,
1195 allow_derived))
1196 continue;
1197 if ((mask & OMP_CLAUSE_DEVICE)
1198 && !openacc
1199 && c->device == NULL
1200 && gfc_match ("device ( %e )", &c->device) == MATCH_YES)
1201 continue;
1202 if ((mask & OMP_CLAUSE_DEVICE)
1203 && openacc
1204 && gfc_match ("device ( ") == MATCH_YES
1205 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1206 OMP_MAP_FORCE_TO, true,
1207 allow_derived))
1208 continue;
1209 if ((mask & OMP_CLAUSE_DEVICEPTR)
1210 && gfc_match ("deviceptr ( ") == MATCH_YES
1211 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1212 OMP_MAP_FORCE_DEVICEPTR, false,
1213 allow_derived))
1214 continue;
1215 if ((mask & OMP_CLAUSE_DEVICE_RESIDENT)
1216 && gfc_match_omp_variable_list
1217 ("device_resident (",
1218 &c->lists[OMP_LIST_DEVICE_RESIDENT], true) == MATCH_YES)
1219 continue;
1220 if ((mask & OMP_CLAUSE_DIST_SCHEDULE)
1221 && c->dist_sched_kind == OMP_SCHED_NONE
1222 && gfc_match ("dist_schedule ( static") == MATCH_YES)
1223 {
1224 match m = MATCH_NO;
1225 c->dist_sched_kind = OMP_SCHED_STATIC;
1226 m = gfc_match (" , %e )", &c->dist_chunk_size);
1227 if (m != MATCH_YES)
1228 m = gfc_match_char (')');
1229 if (m != MATCH_YES)
1230 {
1231 c->dist_sched_kind = OMP_SCHED_NONE;
1232 gfc_current_locus = old_loc;
1233 }
1234 else
1235 continue;
1236 }
1237 break;
1238 case 'f':
1239 if ((mask & OMP_CLAUSE_FINAL)
1240 && c->final_expr == NULL
1241 && gfc_match ("final ( %e )", &c->final_expr) == MATCH_YES)
1242 continue;
1243 if ((mask & OMP_CLAUSE_FINALIZE)
1244 && !c->finalize
1245 && gfc_match ("finalize") == MATCH_YES)
1246 {
1247 c->finalize = true;
1248 needs_space = true;
1249 continue;
1250 }
1251 if ((mask & OMP_CLAUSE_FIRSTPRIVATE)
1252 && gfc_match_omp_variable_list ("firstprivate (",
1253 &c->lists[OMP_LIST_FIRSTPRIVATE],
1254 true) == MATCH_YES)
1255 continue;
1256 if ((mask & OMP_CLAUSE_FROM)
1257 && gfc_match_omp_variable_list ("from (",
1258 &c->lists[OMP_LIST_FROM], false,
1259 NULL, &head, true) == MATCH_YES)
1260 continue;
1261 break;
1262 case 'g':
1263 if ((mask & OMP_CLAUSE_GANG)
1264 && !c->gang
1265 && gfc_match ("gang") == MATCH_YES)
1266 {
1267 c->gang = true;
1268 match m = match_oacc_clause_gwv (c, GOMP_DIM_GANG);
1269 if (m == MATCH_ERROR)
1270 {
1271 gfc_current_locus = old_loc;
1272 break;
1273 }
1274 else if (m == MATCH_NO)
1275 needs_space = true;
1276 continue;
1277 }
1278 if ((mask & OMP_CLAUSE_GRAINSIZE)
1279 && c->grainsize == NULL
1280 && gfc_match ("grainsize ( %e )", &c->grainsize) == MATCH_YES)
1281 continue;
1282 break;
1283 case 'h':
1284 if ((mask & OMP_CLAUSE_HINT)
1285 && c->hint == NULL
1286 && gfc_match ("hint ( %e )", &c->hint) == MATCH_YES)
1287 continue;
1288 if ((mask & OMP_CLAUSE_HOST_SELF)
1289 && gfc_match ("host ( ") == MATCH_YES
1290 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1291 OMP_MAP_FORCE_FROM, true,
1292 allow_derived))
1293 continue;
1294 break;
1295 case 'i':
1296 if ((mask & OMP_CLAUSE_IF)
1297 && c->if_expr == NULL
1298 && gfc_match ("if ( ") == MATCH_YES)
1299 {
1300 if (gfc_match ("%e )", &c->if_expr) == MATCH_YES)
1301 continue;
1302 if (!openacc)
1303 {
1304 /* This should match the enum gfc_omp_if_kind order. */
1305 static const char *ifs[OMP_IF_LAST] = {
1306 " parallel : %e )",
1307 " task : %e )",
1308 " taskloop : %e )",
1309 " target : %e )",
1310 " target data : %e )",
1311 " target update : %e )",
1312 " target enter data : %e )",
1313 " target exit data : %e )" };
1314 int i;
1315 for (i = 0; i < OMP_IF_LAST; i++)
1316 if (c->if_exprs[i] == NULL
1317 && gfc_match (ifs[i], &c->if_exprs[i]) == MATCH_YES)
1318 break;
1319 if (i < OMP_IF_LAST)
1320 continue;
1321 }
1322 gfc_current_locus = old_loc;
1323 }
1324 if ((mask & OMP_CLAUSE_IF_PRESENT)
1325 && !c->if_present
1326 && gfc_match ("if_present") == MATCH_YES)
1327 {
1328 c->if_present = true;
1329 needs_space = true;
1330 continue;
1331 }
1332 if ((mask & OMP_CLAUSE_INBRANCH)
1333 && !c->inbranch
1334 && !c->notinbranch
1335 && gfc_match ("inbranch") == MATCH_YES)
1336 {
1337 c->inbranch = needs_space = true;
1338 continue;
1339 }
1340 if ((mask & OMP_CLAUSE_INDEPENDENT)
1341 && !c->independent
1342 && gfc_match ("independent") == MATCH_YES)
1343 {
1344 c->independent = true;
1345 needs_space = true;
1346 continue;
1347 }
1348 if ((mask & OMP_CLAUSE_IS_DEVICE_PTR)
1349 && gfc_match_omp_variable_list
1350 ("is_device_ptr (",
1351 &c->lists[OMP_LIST_IS_DEVICE_PTR], false) == MATCH_YES)
1352 continue;
1353 break;
1354 case 'l':
1355 if ((mask & OMP_CLAUSE_LASTPRIVATE)
1356 && gfc_match_omp_variable_list ("lastprivate (",
1357 &c->lists[OMP_LIST_LASTPRIVATE],
1358 true) == MATCH_YES)
1359 continue;
1360 end_colon = false;
1361 head = NULL;
1362 if ((mask & OMP_CLAUSE_LINEAR)
1363 && gfc_match ("linear (") == MATCH_YES)
1364 {
1365 gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
1366 gfc_expr *step = NULL;
1367
1368 if (gfc_match_omp_variable_list (" ref (",
1369 &c->lists[OMP_LIST_LINEAR],
1370 false, NULL, &head)
1371 == MATCH_YES)
1372 linear_op = OMP_LINEAR_REF;
1373 else if (gfc_match_omp_variable_list (" val (",
1374 &c->lists[OMP_LIST_LINEAR],
1375 false, NULL, &head)
1376 == MATCH_YES)
1377 linear_op = OMP_LINEAR_VAL;
1378 else if (gfc_match_omp_variable_list (" uval (",
1379 &c->lists[OMP_LIST_LINEAR],
1380 false, NULL, &head)
1381 == MATCH_YES)
1382 linear_op = OMP_LINEAR_UVAL;
1383 else if (gfc_match_omp_variable_list ("",
1384 &c->lists[OMP_LIST_LINEAR],
1385 false, &end_colon, &head)
1386 == MATCH_YES)
1387 linear_op = OMP_LINEAR_DEFAULT;
1388 else
1389 {
1390 gfc_current_locus = old_loc;
1391 break;
1392 }
1393 if (linear_op != OMP_LINEAR_DEFAULT)
1394 {
1395 if (gfc_match (" :") == MATCH_YES)
1396 end_colon = true;
1397 else if (gfc_match (" )") != MATCH_YES)
1398 {
1399 gfc_free_omp_namelist (*head);
1400 gfc_current_locus = old_loc;
1401 *head = NULL;
1402 break;
1403 }
1404 }
1405 if (end_colon && gfc_match (" %e )", &step) != MATCH_YES)
1406 {
1407 gfc_free_omp_namelist (*head);
1408 gfc_current_locus = old_loc;
1409 *head = NULL;
1410 break;
1411 }
1412 else if (!end_colon)
1413 {
1414 step = gfc_get_constant_expr (BT_INTEGER,
1415 gfc_default_integer_kind,
1416 &old_loc);
1417 mpz_set_si (step->value.integer, 1);
1418 }
1419 (*head)->expr = step;
1420 if (linear_op != OMP_LINEAR_DEFAULT)
1421 for (gfc_omp_namelist *n = *head; n; n = n->next)
1422 n->u.linear_op = linear_op;
1423 continue;
1424 }
1425 if ((mask & OMP_CLAUSE_LINK)
1426 && openacc
1427 && (gfc_match_oacc_clause_link ("link (",
1428 &c->lists[OMP_LIST_LINK])
1429 == MATCH_YES))
1430 continue;
1431 else if ((mask & OMP_CLAUSE_LINK)
1432 && !openacc
1433 && (gfc_match_omp_to_link ("link (",
1434 &c->lists[OMP_LIST_LINK])
1435 == MATCH_YES))
1436 continue;
1437 break;
1438 case 'm':
1439 if ((mask & OMP_CLAUSE_MAP)
1440 && gfc_match ("map ( ") == MATCH_YES)
1441 {
1442 locus old_loc2 = gfc_current_locus;
1443 bool always = false;
1444 gfc_omp_map_op map_op = OMP_MAP_TOFROM;
1445 if (gfc_match ("always , ") == MATCH_YES)
1446 always = true;
1447 if (gfc_match ("alloc : ") == MATCH_YES)
1448 map_op = OMP_MAP_ALLOC;
1449 else if (gfc_match ("tofrom : ") == MATCH_YES)
1450 map_op = always ? OMP_MAP_ALWAYS_TOFROM : OMP_MAP_TOFROM;
1451 else if (gfc_match ("to : ") == MATCH_YES)
1452 map_op = always ? OMP_MAP_ALWAYS_TO : OMP_MAP_TO;
1453 else if (gfc_match ("from : ") == MATCH_YES)
1454 map_op = always ? OMP_MAP_ALWAYS_FROM : OMP_MAP_FROM;
1455 else if (gfc_match ("release : ") == MATCH_YES)
1456 map_op = OMP_MAP_RELEASE;
1457 else if (gfc_match ("delete : ") == MATCH_YES)
1458 map_op = OMP_MAP_DELETE;
1459 else if (always)
1460 {
1461 gfc_current_locus = old_loc2;
1462 always = false;
1463 }
1464 head = NULL;
1465 if (gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_MAP],
1466 false, NULL, &head,
1467 true) == MATCH_YES)
1468 {
1469 gfc_omp_namelist *n;
1470 for (n = *head; n; n = n->next)
1471 n->u.map_op = map_op;
1472 continue;
1473 }
1474 else
1475 gfc_current_locus = old_loc;
1476 }
1477 if ((mask & OMP_CLAUSE_MERGEABLE) && !c->mergeable
1478 && gfc_match ("mergeable") == MATCH_YES)
1479 {
1480 c->mergeable = needs_space = true;
1481 continue;
1482 }
1483 break;
1484 case 'n':
1485 if ((mask & OMP_CLAUSE_NO_CREATE)
1486 && gfc_match ("no_create ( ") == MATCH_YES
1487 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1488 OMP_MAP_IF_PRESENT, true,
1489 allow_derived))
1490 continue;
1491 if ((mask & OMP_CLAUSE_NOGROUP)
1492 && !c->nogroup
1493 && gfc_match ("nogroup") == MATCH_YES)
1494 {
1495 c->nogroup = needs_space = true;
1496 continue;
1497 }
1498 if ((mask & OMP_CLAUSE_NOTINBRANCH)
1499 && !c->notinbranch
1500 && !c->inbranch
1501 && gfc_match ("notinbranch") == MATCH_YES)
1502 {
1503 c->notinbranch = needs_space = true;
1504 continue;
1505 }
1506 if ((mask & OMP_CLAUSE_NOWAIT)
1507 && !c->nowait
1508 && gfc_match ("nowait") == MATCH_YES)
1509 {
1510 c->nowait = needs_space = true;
1511 continue;
1512 }
1513 if ((mask & OMP_CLAUSE_NUM_GANGS)
1514 && c->num_gangs_expr == NULL
1515 && gfc_match ("num_gangs ( %e )",
1516 &c->num_gangs_expr) == MATCH_YES)
1517 continue;
1518 if ((mask & OMP_CLAUSE_NUM_TASKS)
1519 && c->num_tasks == NULL
1520 && gfc_match ("num_tasks ( %e )", &c->num_tasks) == MATCH_YES)
1521 continue;
1522 if ((mask & OMP_CLAUSE_NUM_TEAMS)
1523 && c->num_teams == NULL
1524 && gfc_match ("num_teams ( %e )", &c->num_teams) == MATCH_YES)
1525 continue;
1526 if ((mask & OMP_CLAUSE_NUM_THREADS)
1527 && c->num_threads == NULL
1528 && (gfc_match ("num_threads ( %e )", &c->num_threads)
1529 == MATCH_YES))
1530 continue;
1531 if ((mask & OMP_CLAUSE_NUM_WORKERS)
1532 && c->num_workers_expr == NULL
1533 && gfc_match ("num_workers ( %e )",
1534 &c->num_workers_expr) == MATCH_YES)
1535 continue;
1536 break;
1537 case 'o':
1538 if ((mask & OMP_CLAUSE_ORDERED)
1539 && !c->ordered
1540 && gfc_match ("ordered") == MATCH_YES)
1541 {
1542 gfc_expr *cexpr = NULL;
1543 match m = gfc_match (" ( %e )", &cexpr);
1544
1545 c->ordered = true;
1546 if (m == MATCH_YES)
1547 {
1548 int ordered = 0;
1549 if (gfc_extract_int (cexpr, &ordered, -1))
1550 ordered = 0;
1551 else if (ordered <= 0)
1552 {
1553 gfc_error_now ("ORDERED clause argument not"
1554 " constant positive integer at %C");
1555 ordered = 0;
1556 }
1557 c->orderedc = ordered;
1558 gfc_free_expr (cexpr);
1559 continue;
1560 }
1561
1562 needs_space = true;
1563 continue;
1564 }
1565 break;
1566 case 'p':
1567 if ((mask & OMP_CLAUSE_COPY)
1568 && gfc_match ("pcopy ( ") == MATCH_YES
1569 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1570 OMP_MAP_TOFROM, true, allow_derived))
1571 continue;
1572 if ((mask & OMP_CLAUSE_COPYIN)
1573 && gfc_match ("pcopyin ( ") == MATCH_YES
1574 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1575 OMP_MAP_TO, true, allow_derived))
1576 continue;
1577 if ((mask & OMP_CLAUSE_COPYOUT)
1578 && gfc_match ("pcopyout ( ") == MATCH_YES
1579 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1580 OMP_MAP_FROM, true, allow_derived))
1581 continue;
1582 if ((mask & OMP_CLAUSE_CREATE)
1583 && gfc_match ("pcreate ( ") == MATCH_YES
1584 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1585 OMP_MAP_ALLOC, true, allow_derived))
1586 continue;
1587 if ((mask & OMP_CLAUSE_PRESENT)
1588 && gfc_match ("present ( ") == MATCH_YES
1589 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1590 OMP_MAP_FORCE_PRESENT, false,
1591 allow_derived))
1592 continue;
1593 if ((mask & OMP_CLAUSE_COPY)
1594 && gfc_match ("present_or_copy ( ") == MATCH_YES
1595 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1596 OMP_MAP_TOFROM, true,
1597 allow_derived))
1598 continue;
1599 if ((mask & OMP_CLAUSE_COPYIN)
1600 && gfc_match ("present_or_copyin ( ") == MATCH_YES
1601 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1602 OMP_MAP_TO, true, allow_derived))
1603 continue;
1604 if ((mask & OMP_CLAUSE_COPYOUT)
1605 && gfc_match ("present_or_copyout ( ") == MATCH_YES
1606 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1607 OMP_MAP_FROM, true, allow_derived))
1608 continue;
1609 if ((mask & OMP_CLAUSE_CREATE)
1610 && gfc_match ("present_or_create ( ") == MATCH_YES
1611 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1612 OMP_MAP_ALLOC, true, allow_derived))
1613 continue;
1614 if ((mask & OMP_CLAUSE_PRIORITY)
1615 && c->priority == NULL
1616 && gfc_match ("priority ( %e )", &c->priority) == MATCH_YES)
1617 continue;
1618 if ((mask & OMP_CLAUSE_PRIVATE)
1619 && gfc_match_omp_variable_list ("private (",
1620 &c->lists[OMP_LIST_PRIVATE],
1621 true) == MATCH_YES)
1622 continue;
1623 if ((mask & OMP_CLAUSE_PROC_BIND)
1624 && c->proc_bind == OMP_PROC_BIND_UNKNOWN)
1625 {
1626 if (gfc_match ("proc_bind ( master )") == MATCH_YES)
1627 c->proc_bind = OMP_PROC_BIND_MASTER;
1628 else if (gfc_match ("proc_bind ( spread )") == MATCH_YES)
1629 c->proc_bind = OMP_PROC_BIND_SPREAD;
1630 else if (gfc_match ("proc_bind ( close )") == MATCH_YES)
1631 c->proc_bind = OMP_PROC_BIND_CLOSE;
1632 if (c->proc_bind != OMP_PROC_BIND_UNKNOWN)
1633 continue;
1634 }
1635 break;
1636 case 'r':
1637 if ((mask & OMP_CLAUSE_REDUCTION)
1638 && gfc_match ("reduction ( ") == MATCH_YES)
1639 {
1640 gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
1641 char buffer[GFC_MAX_SYMBOL_LEN + 3];
1642 if (gfc_match_char ('+') == MATCH_YES)
1643 rop = OMP_REDUCTION_PLUS;
1644 else if (gfc_match_char ('*') == MATCH_YES)
1645 rop = OMP_REDUCTION_TIMES;
1646 else if (gfc_match_char ('-') == MATCH_YES)
1647 rop = OMP_REDUCTION_MINUS;
1648 else if (gfc_match (".and.") == MATCH_YES)
1649 rop = OMP_REDUCTION_AND;
1650 else if (gfc_match (".or.") == MATCH_YES)
1651 rop = OMP_REDUCTION_OR;
1652 else if (gfc_match (".eqv.") == MATCH_YES)
1653 rop = OMP_REDUCTION_EQV;
1654 else if (gfc_match (".neqv.") == MATCH_YES)
1655 rop = OMP_REDUCTION_NEQV;
1656 if (rop != OMP_REDUCTION_NONE)
1657 snprintf (buffer, sizeof buffer, "operator %s",
1658 gfc_op2string ((gfc_intrinsic_op) rop));
1659 else if (gfc_match_defined_op_name (buffer + 1, 1) == MATCH_YES)
1660 {
1661 buffer[0] = '.';
1662 strcat (buffer, ".");
1663 }
1664 else if (gfc_match_name (buffer) == MATCH_YES)
1665 {
1666 gfc_symbol *sym;
1667 const char *n = buffer;
1668
1669 gfc_find_symbol (buffer, NULL, 1, &sym);
1670 if (sym != NULL)
1671 {
1672 if (sym->attr.intrinsic)
1673 n = sym->name;
1674 else if ((sym->attr.flavor != FL_UNKNOWN
1675 && sym->attr.flavor != FL_PROCEDURE)
1676 || sym->attr.external
1677 || sym->attr.generic
1678 || sym->attr.entry
1679 || sym->attr.result
1680 || sym->attr.dummy
1681 || sym->attr.subroutine
1682 || sym->attr.pointer
1683 || sym->attr.target
1684 || sym->attr.cray_pointer
1685 || sym->attr.cray_pointee
1686 || (sym->attr.proc != PROC_UNKNOWN
1687 && sym->attr.proc != PROC_INTRINSIC)
1688 || sym->attr.if_source != IFSRC_UNKNOWN
1689 || sym == sym->ns->proc_name)
1690 {
1691 sym = NULL;
1692 n = NULL;
1693 }
1694 else
1695 n = sym->name;
1696 }
1697 if (n == NULL)
1698 rop = OMP_REDUCTION_NONE;
1699 else if (strcmp (n, "max") == 0)
1700 rop = OMP_REDUCTION_MAX;
1701 else if (strcmp (n, "min") == 0)
1702 rop = OMP_REDUCTION_MIN;
1703 else if (strcmp (n, "iand") == 0)
1704 rop = OMP_REDUCTION_IAND;
1705 else if (strcmp (n, "ior") == 0)
1706 rop = OMP_REDUCTION_IOR;
1707 else if (strcmp (n, "ieor") == 0)
1708 rop = OMP_REDUCTION_IEOR;
1709 if (rop != OMP_REDUCTION_NONE
1710 && sym != NULL
1711 && ! sym->attr.intrinsic
1712 && ! sym->attr.use_assoc
1713 && ((sym->attr.flavor == FL_UNKNOWN
1714 && !gfc_add_flavor (&sym->attr, FL_PROCEDURE,
1715 sym->name, NULL))
1716 || !gfc_add_intrinsic (&sym->attr, NULL)))
1717 rop = OMP_REDUCTION_NONE;
1718 }
1719 else
1720 buffer[0] = '\0';
1721 gfc_omp_udr *udr
1722 = (buffer[0]
1723 ? gfc_find_omp_udr (gfc_current_ns, buffer, NULL) : NULL);
1724 gfc_omp_namelist **head = NULL;
1725 if (rop == OMP_REDUCTION_NONE && udr)
1726 rop = OMP_REDUCTION_USER;
1727
1728 if (gfc_match_omp_variable_list (" :",
1729 &c->lists[OMP_LIST_REDUCTION],
1730 false, NULL, &head, openacc,
1731 allow_derived) == MATCH_YES)
1732 {
1733 gfc_omp_namelist *n;
1734 if (rop == OMP_REDUCTION_NONE)
1735 {
1736 n = *head;
1737 *head = NULL;
1738 gfc_error_now ("!$OMP DECLARE REDUCTION %s not found "
1739 "at %L", buffer, &old_loc);
1740 gfc_free_omp_namelist (n);
1741 }
1742 else
1743 for (n = *head; n; n = n->next)
1744 {
1745 n->u.reduction_op = rop;
1746 if (udr)
1747 {
1748 n->udr = gfc_get_omp_namelist_udr ();
1749 n->udr->udr = udr;
1750 }
1751 }
1752 continue;
1753 }
1754 else
1755 gfc_current_locus = old_loc;
1756 }
1757 break;
1758 case 's':
1759 if ((mask & OMP_CLAUSE_SAFELEN)
1760 && c->safelen_expr == NULL
1761 && gfc_match ("safelen ( %e )", &c->safelen_expr) == MATCH_YES)
1762 continue;
1763 if ((mask & OMP_CLAUSE_SCHEDULE)
1764 && c->sched_kind == OMP_SCHED_NONE
1765 && gfc_match ("schedule ( ") == MATCH_YES)
1766 {
1767 int nmodifiers = 0;
1768 locus old_loc2 = gfc_current_locus;
1769 do
1770 {
1771 if (gfc_match ("simd") == MATCH_YES)
1772 {
1773 c->sched_simd = true;
1774 nmodifiers++;
1775 }
1776 else if (gfc_match ("monotonic") == MATCH_YES)
1777 {
1778 c->sched_monotonic = true;
1779 nmodifiers++;
1780 }
1781 else if (gfc_match ("nonmonotonic") == MATCH_YES)
1782 {
1783 c->sched_nonmonotonic = true;
1784 nmodifiers++;
1785 }
1786 else
1787 {
1788 if (nmodifiers)
1789 gfc_current_locus = old_loc2;
1790 break;
1791 }
1792 if (nmodifiers == 1
1793 && gfc_match (" , ") == MATCH_YES)
1794 continue;
1795 else if (gfc_match (" : ") == MATCH_YES)
1796 break;
1797 gfc_current_locus = old_loc2;
1798 break;
1799 }
1800 while (1);
1801 if (gfc_match ("static") == MATCH_YES)
1802 c->sched_kind = OMP_SCHED_STATIC;
1803 else if (gfc_match ("dynamic") == MATCH_YES)
1804 c->sched_kind = OMP_SCHED_DYNAMIC;
1805 else if (gfc_match ("guided") == MATCH_YES)
1806 c->sched_kind = OMP_SCHED_GUIDED;
1807 else if (gfc_match ("runtime") == MATCH_YES)
1808 c->sched_kind = OMP_SCHED_RUNTIME;
1809 else if (gfc_match ("auto") == MATCH_YES)
1810 c->sched_kind = OMP_SCHED_AUTO;
1811 if (c->sched_kind != OMP_SCHED_NONE)
1812 {
1813 match m = MATCH_NO;
1814 if (c->sched_kind != OMP_SCHED_RUNTIME
1815 && c->sched_kind != OMP_SCHED_AUTO)
1816 m = gfc_match (" , %e )", &c->chunk_size);
1817 if (m != MATCH_YES)
1818 m = gfc_match_char (')');
1819 if (m != MATCH_YES)
1820 c->sched_kind = OMP_SCHED_NONE;
1821 }
1822 if (c->sched_kind != OMP_SCHED_NONE)
1823 continue;
1824 else
1825 gfc_current_locus = old_loc;
1826 }
1827 if ((mask & OMP_CLAUSE_HOST_SELF)
1828 && gfc_match ("self ( ") == MATCH_YES
1829 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1830 OMP_MAP_FORCE_FROM, true,
1831 allow_derived))
1832 continue;
1833 if ((mask & OMP_CLAUSE_SEQ)
1834 && !c->seq
1835 && gfc_match ("seq") == MATCH_YES)
1836 {
1837 c->seq = true;
1838 needs_space = true;
1839 continue;
1840 }
1841 if ((mask & OMP_CLAUSE_SHARED)
1842 && gfc_match_omp_variable_list ("shared (",
1843 &c->lists[OMP_LIST_SHARED],
1844 true) == MATCH_YES)
1845 continue;
1846 if ((mask & OMP_CLAUSE_SIMDLEN)
1847 && c->simdlen_expr == NULL
1848 && gfc_match ("simdlen ( %e )", &c->simdlen_expr) == MATCH_YES)
1849 continue;
1850 if ((mask & OMP_CLAUSE_SIMD)
1851 && !c->simd
1852 && gfc_match ("simd") == MATCH_YES)
1853 {
1854 c->simd = needs_space = true;
1855 continue;
1856 }
1857 break;
1858 case 't':
1859 if ((mask & OMP_CLAUSE_THREAD_LIMIT)
1860 && c->thread_limit == NULL
1861 && gfc_match ("thread_limit ( %e )",
1862 &c->thread_limit) == MATCH_YES)
1863 continue;
1864 if ((mask & OMP_CLAUSE_THREADS)
1865 && !c->threads
1866 && gfc_match ("threads") == MATCH_YES)
1867 {
1868 c->threads = needs_space = true;
1869 continue;
1870 }
1871 if ((mask & OMP_CLAUSE_TILE)
1872 && !c->tile_list
1873 && match_oacc_expr_list ("tile (", &c->tile_list,
1874 true) == MATCH_YES)
1875 continue;
1876 if ((mask & OMP_CLAUSE_TO) && (mask & OMP_CLAUSE_LINK))
1877 {
1878 if (gfc_match_omp_to_link ("to (", &c->lists[OMP_LIST_TO])
1879 == MATCH_YES)
1880 continue;
1881 }
1882 else if ((mask & OMP_CLAUSE_TO)
1883 && gfc_match_omp_variable_list ("to (",
1884 &c->lists[OMP_LIST_TO], false,
1885 NULL, &head, true) == MATCH_YES)
1886 continue;
1887 break;
1888 case 'u':
1889 if ((mask & OMP_CLAUSE_UNIFORM)
1890 && gfc_match_omp_variable_list ("uniform (",
1891 &c->lists[OMP_LIST_UNIFORM],
1892 false) == MATCH_YES)
1893 continue;
1894 if ((mask & OMP_CLAUSE_UNTIED)
1895 && !c->untied
1896 && gfc_match ("untied") == MATCH_YES)
1897 {
1898 c->untied = needs_space = true;
1899 continue;
1900 }
1901 if ((mask & OMP_CLAUSE_USE_DEVICE)
1902 && gfc_match_omp_variable_list ("use_device (",
1903 &c->lists[OMP_LIST_USE_DEVICE],
1904 true) == MATCH_YES)
1905 continue;
1906 if ((mask & OMP_CLAUSE_USE_DEVICE_PTR)
1907 && gfc_match_omp_variable_list
1908 ("use_device_ptr (",
1909 &c->lists[OMP_LIST_USE_DEVICE_PTR], false) == MATCH_YES)
1910 continue;
1911 if ((mask & OMP_CLAUSE_USE_DEVICE_ADDR)
1912 && gfc_match_omp_variable_list
1913 ("use_device_addr (",
1914 &c->lists[OMP_LIST_USE_DEVICE_ADDR], false) == MATCH_YES)
1915 continue;
1916 break;
1917 case 'v':
1918 /* VECTOR_LENGTH must be matched before VECTOR, because the latter
1919 doesn't unconditionally match '('. */
1920 if ((mask & OMP_CLAUSE_VECTOR_LENGTH)
1921 && c->vector_length_expr == NULL
1922 && (gfc_match ("vector_length ( %e )", &c->vector_length_expr)
1923 == MATCH_YES))
1924 continue;
1925 if ((mask & OMP_CLAUSE_VECTOR)
1926 && !c->vector
1927 && gfc_match ("vector") == MATCH_YES)
1928 {
1929 c->vector = true;
1930 match m = match_oacc_clause_gwv (c, GOMP_DIM_VECTOR);
1931 if (m == MATCH_ERROR)
1932 {
1933 gfc_current_locus = old_loc;
1934 break;
1935 }
1936 if (m == MATCH_NO)
1937 needs_space = true;
1938 continue;
1939 }
1940 break;
1941 case 'w':
1942 if ((mask & OMP_CLAUSE_WAIT)
1943 && gfc_match ("wait") == MATCH_YES)
1944 {
1945 match m = match_oacc_expr_list (" (", &c->wait_list, false);
1946 if (m == MATCH_ERROR)
1947 {
1948 gfc_current_locus = old_loc;
1949 break;
1950 }
1951 else if (m == MATCH_NO)
1952 {
1953 gfc_expr *expr
1954 = gfc_get_constant_expr (BT_INTEGER,
1955 gfc_default_integer_kind,
1956 &gfc_current_locus);
1957 mpz_set_si (expr->value.integer, GOMP_ASYNC_NOVAL);
1958 gfc_expr_list **expr_list = &c->wait_list;
1959 while (*expr_list)
1960 expr_list = &(*expr_list)->next;
1961 *expr_list = gfc_get_expr_list ();
1962 (*expr_list)->expr = expr;
1963 needs_space = true;
1964 }
1965 continue;
1966 }
1967 if ((mask & OMP_CLAUSE_WORKER)
1968 && !c->worker
1969 && gfc_match ("worker") == MATCH_YES)
1970 {
1971 c->worker = true;
1972 match m = match_oacc_clause_gwv (c, GOMP_DIM_WORKER);
1973 if (m == MATCH_ERROR)
1974 {
1975 gfc_current_locus = old_loc;
1976 break;
1977 }
1978 else if (m == MATCH_NO)
1979 needs_space = true;
1980 continue;
1981 }
1982 break;
1983 }
1984 break;
1985 }
1986
1987 if (gfc_match_omp_eos () != MATCH_YES)
1988 {
1989 if (!gfc_error_flag_test ())
1990 gfc_error ("Failed to match clause at %C");
1991 gfc_free_omp_clauses (c);
1992 return MATCH_ERROR;
1993 }
1994
1995 *cp = c;
1996 return MATCH_YES;
1997 }
1998
1999
2000 #define OACC_PARALLEL_CLAUSES \
2001 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
2002 | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_REDUCTION \
2003 | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
2004 | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
2005 | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
2006 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH)
2007 #define OACC_KERNELS_CLAUSES \
2008 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
2009 | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_DEVICEPTR \
2010 | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
2011 | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
2012 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH)
2013 #define OACC_SERIAL_CLAUSES \
2014 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_REDUCTION \
2015 | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
2016 | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
2017 | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
2018 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH)
2019 #define OACC_DATA_CLAUSES \
2020 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_COPY \
2021 | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_CREATE \
2022 | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_ATTACH)
2023 #define OACC_LOOP_CLAUSES \
2024 (omp_mask (OMP_CLAUSE_COLLAPSE) | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER \
2025 | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ | OMP_CLAUSE_INDEPENDENT \
2026 | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_AUTO \
2027 | OMP_CLAUSE_TILE)
2028 #define OACC_PARALLEL_LOOP_CLAUSES \
2029 (OACC_LOOP_CLAUSES | OACC_PARALLEL_CLAUSES)
2030 #define OACC_KERNELS_LOOP_CLAUSES \
2031 (OACC_LOOP_CLAUSES | OACC_KERNELS_CLAUSES)
2032 #define OACC_SERIAL_LOOP_CLAUSES \
2033 (OACC_LOOP_CLAUSES | OACC_SERIAL_CLAUSES)
2034 #define OACC_HOST_DATA_CLAUSES \
2035 (omp_mask (OMP_CLAUSE_USE_DEVICE) \
2036 | OMP_CLAUSE_IF \
2037 | OMP_CLAUSE_IF_PRESENT)
2038 #define OACC_DECLARE_CLAUSES \
2039 (omp_mask (OMP_CLAUSE_COPY) | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
2040 | OMP_CLAUSE_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_DEVICE_RESIDENT \
2041 | OMP_CLAUSE_PRESENT \
2042 | OMP_CLAUSE_LINK)
2043 #define OACC_UPDATE_CLAUSES \
2044 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_HOST_SELF \
2045 | OMP_CLAUSE_DEVICE | OMP_CLAUSE_WAIT | OMP_CLAUSE_IF_PRESENT)
2046 #define OACC_ENTER_DATA_CLAUSES \
2047 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
2048 | OMP_CLAUSE_COPYIN | OMP_CLAUSE_CREATE | OMP_CLAUSE_ATTACH)
2049 #define OACC_EXIT_DATA_CLAUSES \
2050 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
2051 | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE | OMP_CLAUSE_FINALIZE \
2052 | OMP_CLAUSE_DETACH)
2053 #define OACC_WAIT_CLAUSES \
2054 omp_mask (OMP_CLAUSE_ASYNC)
2055 #define OACC_ROUTINE_CLAUSES \
2056 (omp_mask (OMP_CLAUSE_GANG) | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR \
2057 | OMP_CLAUSE_SEQ)
2058
2059
2060 static match
2061 match_acc (gfc_exec_op op, const omp_mask mask)
2062 {
2063 gfc_omp_clauses *c;
2064 if (gfc_match_omp_clauses (&c, mask, false, false, true) != MATCH_YES)
2065 return MATCH_ERROR;
2066 new_st.op = op;
2067 new_st.ext.omp_clauses = c;
2068 return MATCH_YES;
2069 }
2070
2071 match
2072 gfc_match_oacc_parallel_loop (void)
2073 {
2074 return match_acc (EXEC_OACC_PARALLEL_LOOP, OACC_PARALLEL_LOOP_CLAUSES);
2075 }
2076
2077
2078 match
2079 gfc_match_oacc_parallel (void)
2080 {
2081 return match_acc (EXEC_OACC_PARALLEL, OACC_PARALLEL_CLAUSES);
2082 }
2083
2084
2085 match
2086 gfc_match_oacc_kernels_loop (void)
2087 {
2088 return match_acc (EXEC_OACC_KERNELS_LOOP, OACC_KERNELS_LOOP_CLAUSES);
2089 }
2090
2091
2092 match
2093 gfc_match_oacc_kernels (void)
2094 {
2095 return match_acc (EXEC_OACC_KERNELS, OACC_KERNELS_CLAUSES);
2096 }
2097
2098
2099 match
2100 gfc_match_oacc_serial_loop (void)
2101 {
2102 return match_acc (EXEC_OACC_SERIAL_LOOP, OACC_SERIAL_LOOP_CLAUSES);
2103 }
2104
2105
2106 match
2107 gfc_match_oacc_serial (void)
2108 {
2109 return match_acc (EXEC_OACC_SERIAL, OACC_SERIAL_CLAUSES);
2110 }
2111
2112
2113 match
2114 gfc_match_oacc_data (void)
2115 {
2116 return match_acc (EXEC_OACC_DATA, OACC_DATA_CLAUSES);
2117 }
2118
2119
2120 match
2121 gfc_match_oacc_host_data (void)
2122 {
2123 return match_acc (EXEC_OACC_HOST_DATA, OACC_HOST_DATA_CLAUSES);
2124 }
2125
2126
2127 match
2128 gfc_match_oacc_loop (void)
2129 {
2130 return match_acc (EXEC_OACC_LOOP, OACC_LOOP_CLAUSES);
2131 }
2132
2133
2134 match
2135 gfc_match_oacc_declare (void)
2136 {
2137 gfc_omp_clauses *c;
2138 gfc_omp_namelist *n;
2139 gfc_namespace *ns = gfc_current_ns;
2140 gfc_oacc_declare *new_oc;
2141 bool module_var = false;
2142 locus where = gfc_current_locus;
2143
2144 if (gfc_match_omp_clauses (&c, OACC_DECLARE_CLAUSES, false, false, true)
2145 != MATCH_YES)
2146 return MATCH_ERROR;
2147
2148 for (n = c->lists[OMP_LIST_DEVICE_RESIDENT]; n != NULL; n = n->next)
2149 n->sym->attr.oacc_declare_device_resident = 1;
2150
2151 for (n = c->lists[OMP_LIST_LINK]; n != NULL; n = n->next)
2152 n->sym->attr.oacc_declare_link = 1;
2153
2154 for (n = c->lists[OMP_LIST_MAP]; n != NULL; n = n->next)
2155 {
2156 gfc_symbol *s = n->sym;
2157
2158 if (s->ns->proc_name && s->ns->proc_name->attr.proc == PROC_MODULE)
2159 {
2160 if (n->u.map_op != OMP_MAP_ALLOC && n->u.map_op != OMP_MAP_TO)
2161 {
2162 gfc_error ("Invalid clause in module with !$ACC DECLARE at %L",
2163 &where);
2164 return MATCH_ERROR;
2165 }
2166
2167 module_var = true;
2168 }
2169
2170 if (s->attr.use_assoc)
2171 {
2172 gfc_error ("Variable is USE-associated with !$ACC DECLARE at %L",
2173 &where);
2174 return MATCH_ERROR;
2175 }
2176
2177 if ((s->attr.dimension || s->attr.codimension)
2178 && s->attr.dummy && s->as->type != AS_EXPLICIT)
2179 {
2180 gfc_error ("Assumed-size dummy array with !$ACC DECLARE at %L",
2181 &where);
2182 return MATCH_ERROR;
2183 }
2184
2185 switch (n->u.map_op)
2186 {
2187 case OMP_MAP_FORCE_ALLOC:
2188 case OMP_MAP_ALLOC:
2189 s->attr.oacc_declare_create = 1;
2190 break;
2191
2192 case OMP_MAP_FORCE_TO:
2193 case OMP_MAP_TO:
2194 s->attr.oacc_declare_copyin = 1;
2195 break;
2196
2197 case OMP_MAP_FORCE_DEVICEPTR:
2198 s->attr.oacc_declare_deviceptr = 1;
2199 break;
2200
2201 default:
2202 break;
2203 }
2204 }
2205
2206 new_oc = gfc_get_oacc_declare ();
2207 new_oc->next = ns->oacc_declare;
2208 new_oc->module_var = module_var;
2209 new_oc->clauses = c;
2210 new_oc->loc = gfc_current_locus;
2211 ns->oacc_declare = new_oc;
2212
2213 return MATCH_YES;
2214 }
2215
2216
2217 match
2218 gfc_match_oacc_update (void)
2219 {
2220 gfc_omp_clauses *c;
2221 locus here = gfc_current_locus;
2222
2223 if (gfc_match_omp_clauses (&c, OACC_UPDATE_CLAUSES, false, false, true)
2224 != MATCH_YES)
2225 return MATCH_ERROR;
2226
2227 if (!c->lists[OMP_LIST_MAP])
2228 {
2229 gfc_error ("%<acc update%> must contain at least one "
2230 "%<device%> or %<host%> or %<self%> clause at %L", &here);
2231 return MATCH_ERROR;
2232 }
2233
2234 new_st.op = EXEC_OACC_UPDATE;
2235 new_st.ext.omp_clauses = c;
2236 return MATCH_YES;
2237 }
2238
2239
2240 match
2241 gfc_match_oacc_enter_data (void)
2242 {
2243 return match_acc (EXEC_OACC_ENTER_DATA, OACC_ENTER_DATA_CLAUSES);
2244 }
2245
2246
2247 match
2248 gfc_match_oacc_exit_data (void)
2249 {
2250 return match_acc (EXEC_OACC_EXIT_DATA, OACC_EXIT_DATA_CLAUSES);
2251 }
2252
2253
2254 match
2255 gfc_match_oacc_wait (void)
2256 {
2257 gfc_omp_clauses *c = gfc_get_omp_clauses ();
2258 gfc_expr_list *wait_list = NULL, *el;
2259 bool space = true;
2260 match m;
2261
2262 m = match_oacc_expr_list (" (", &wait_list, true);
2263 if (m == MATCH_ERROR)
2264 return m;
2265 else if (m == MATCH_YES)
2266 space = false;
2267
2268 if (gfc_match_omp_clauses (&c, OACC_WAIT_CLAUSES, space, space, true)
2269 == MATCH_ERROR)
2270 return MATCH_ERROR;
2271
2272 if (wait_list)
2273 for (el = wait_list; el; el = el->next)
2274 {
2275 if (el->expr == NULL)
2276 {
2277 gfc_error ("Invalid argument to !$ACC WAIT at %C");
2278 return MATCH_ERROR;
2279 }
2280
2281 if (!gfc_resolve_expr (el->expr)
2282 || el->expr->ts.type != BT_INTEGER || el->expr->rank != 0)
2283 {
2284 gfc_error ("WAIT clause at %L requires a scalar INTEGER expression",
2285 &el->expr->where);
2286
2287 return MATCH_ERROR;
2288 }
2289 }
2290 c->wait_list = wait_list;
2291 new_st.op = EXEC_OACC_WAIT;
2292 new_st.ext.omp_clauses = c;
2293 return MATCH_YES;
2294 }
2295
2296
2297 match
2298 gfc_match_oacc_cache (void)
2299 {
2300 gfc_omp_clauses *c = gfc_get_omp_clauses ();
2301 /* The OpenACC cache directive explicitly only allows "array elements or
2302 subarrays", which we're currently not checking here. Either check this
2303 after the call of gfc_match_omp_variable_list, or add something like a
2304 only_sections variant next to its allow_sections parameter. */
2305 match m = gfc_match_omp_variable_list (" (",
2306 &c->lists[OMP_LIST_CACHE], true,
2307 NULL, NULL, true);
2308 if (m != MATCH_YES)
2309 {
2310 gfc_free_omp_clauses(c);
2311 return m;
2312 }
2313
2314 if (gfc_current_state() != COMP_DO
2315 && gfc_current_state() != COMP_DO_CONCURRENT)
2316 {
2317 gfc_error ("ACC CACHE directive must be inside of loop %C");
2318 gfc_free_omp_clauses(c);
2319 return MATCH_ERROR;
2320 }
2321
2322 new_st.op = EXEC_OACC_CACHE;
2323 new_st.ext.omp_clauses = c;
2324 return MATCH_YES;
2325 }
2326
2327 /* Determine the OpenACC 'routine' directive's level of parallelism. */
2328
2329 static oacc_routine_lop
2330 gfc_oacc_routine_lop (gfc_omp_clauses *clauses)
2331 {
2332 oacc_routine_lop ret = OACC_ROUTINE_LOP_SEQ;
2333
2334 if (clauses)
2335 {
2336 unsigned n_lop_clauses = 0;
2337
2338 if (clauses->gang)
2339 {
2340 ++n_lop_clauses;
2341 ret = OACC_ROUTINE_LOP_GANG;
2342 }
2343 if (clauses->worker)
2344 {
2345 ++n_lop_clauses;
2346 ret = OACC_ROUTINE_LOP_WORKER;
2347 }
2348 if (clauses->vector)
2349 {
2350 ++n_lop_clauses;
2351 ret = OACC_ROUTINE_LOP_VECTOR;
2352 }
2353 if (clauses->seq)
2354 {
2355 ++n_lop_clauses;
2356 ret = OACC_ROUTINE_LOP_SEQ;
2357 }
2358
2359 if (n_lop_clauses > 1)
2360 ret = OACC_ROUTINE_LOP_ERROR;
2361 }
2362
2363 return ret;
2364 }
2365
2366 match
2367 gfc_match_oacc_routine (void)
2368 {
2369 locus old_loc;
2370 match m;
2371 gfc_intrinsic_sym *isym = NULL;
2372 gfc_symbol *sym = NULL;
2373 gfc_omp_clauses *c = NULL;
2374 gfc_oacc_routine_name *n = NULL;
2375 oacc_routine_lop lop = OACC_ROUTINE_LOP_NONE;
2376
2377 old_loc = gfc_current_locus;
2378
2379 m = gfc_match (" (");
2380
2381 if (gfc_current_ns->proc_name
2382 && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
2383 && m == MATCH_YES)
2384 {
2385 gfc_error ("Only the !$ACC ROUTINE form without "
2386 "list is allowed in interface block at %C");
2387 goto cleanup;
2388 }
2389
2390 if (m == MATCH_YES)
2391 {
2392 char buffer[GFC_MAX_SYMBOL_LEN + 1];
2393
2394 m = gfc_match_name (buffer);
2395 if (m == MATCH_YES)
2396 {
2397 gfc_symtree *st = NULL;
2398
2399 /* First look for an intrinsic symbol. */
2400 isym = gfc_find_function (buffer);
2401 if (!isym)
2402 isym = gfc_find_subroutine (buffer);
2403 /* If no intrinsic symbol found, search the current namespace. */
2404 if (!isym)
2405 st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);
2406 if (st)
2407 {
2408 sym = st->n.sym;
2409 /* If the name in a 'routine' directive refers to the containing
2410 subroutine or function, then make sure that we'll later handle
2411 this accordingly. */
2412 if (gfc_current_ns->proc_name != NULL
2413 && strcmp (sym->name, gfc_current_ns->proc_name->name) == 0)
2414 sym = NULL;
2415 }
2416
2417 if (isym == NULL && st == NULL)
2418 {
2419 gfc_error ("Invalid NAME %qs in !$ACC ROUTINE ( NAME ) at %C",
2420 buffer);
2421 gfc_current_locus = old_loc;
2422 return MATCH_ERROR;
2423 }
2424 }
2425 else
2426 {
2427 gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C");
2428 gfc_current_locus = old_loc;
2429 return MATCH_ERROR;
2430 }
2431
2432 if (gfc_match_char (')') != MATCH_YES)
2433 {
2434 gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting"
2435 " ')' after NAME");
2436 gfc_current_locus = old_loc;
2437 return MATCH_ERROR;
2438 }
2439 }
2440
2441 if (gfc_match_omp_eos () != MATCH_YES
2442 && (gfc_match_omp_clauses (&c, OACC_ROUTINE_CLAUSES, false, false, true)
2443 != MATCH_YES))
2444 return MATCH_ERROR;
2445
2446 lop = gfc_oacc_routine_lop (c);
2447 if (lop == OACC_ROUTINE_LOP_ERROR)
2448 {
2449 gfc_error ("Multiple loop axes specified for routine at %C");
2450 goto cleanup;
2451 }
2452
2453 if (isym != NULL)
2454 {
2455 /* Diagnose any OpenACC 'routine' directive that doesn't match the
2456 (implicit) one with a 'seq' clause. */
2457 if (c && (c->gang || c->worker || c->vector))
2458 {
2459 gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )"
2460 " at %C marked with incompatible GANG, WORKER, or VECTOR"
2461 " clause");
2462 goto cleanup;
2463 }
2464 }
2465 else if (sym != NULL)
2466 {
2467 bool add = true;
2468
2469 /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
2470 match the first one. */
2471 for (gfc_oacc_routine_name *n_p = gfc_current_ns->oacc_routine_names;
2472 n_p;
2473 n_p = n_p->next)
2474 if (n_p->sym == sym)
2475 {
2476 add = false;
2477 if (lop != gfc_oacc_routine_lop (n_p->clauses))
2478 {
2479 gfc_error ("!$ACC ROUTINE already applied at %C");
2480 goto cleanup;
2481 }
2482 }
2483
2484 if (add)
2485 {
2486 sym->attr.oacc_routine_lop = lop;
2487
2488 n = gfc_get_oacc_routine_name ();
2489 n->sym = sym;
2490 n->clauses = c;
2491 n->next = gfc_current_ns->oacc_routine_names;
2492 n->loc = old_loc;
2493 gfc_current_ns->oacc_routine_names = n;
2494 }
2495 }
2496 else if (gfc_current_ns->proc_name)
2497 {
2498 /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
2499 match the first one. */
2500 oacc_routine_lop lop_p = gfc_current_ns->proc_name->attr.oacc_routine_lop;
2501 if (lop_p != OACC_ROUTINE_LOP_NONE
2502 && lop != lop_p)
2503 {
2504 gfc_error ("!$ACC ROUTINE already applied at %C");
2505 goto cleanup;
2506 }
2507
2508 if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
2509 gfc_current_ns->proc_name->name,
2510 &old_loc))
2511 goto cleanup;
2512 gfc_current_ns->proc_name->attr.oacc_routine_lop = lop;
2513 }
2514 else
2515 /* Something has gone wrong, possibly a syntax error. */
2516 goto cleanup;
2517
2518 if (n)
2519 n->clauses = c;
2520 else if (gfc_current_ns->oacc_routine)
2521 gfc_current_ns->oacc_routine_clauses = c;
2522
2523 new_st.op = EXEC_OACC_ROUTINE;
2524 new_st.ext.omp_clauses = c;
2525 return MATCH_YES;
2526
2527 cleanup:
2528 gfc_current_locus = old_loc;
2529 return MATCH_ERROR;
2530 }
2531
2532
2533 #define OMP_PARALLEL_CLAUSES \
2534 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
2535 | OMP_CLAUSE_SHARED | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION \
2536 | OMP_CLAUSE_IF | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT \
2537 | OMP_CLAUSE_PROC_BIND)
2538 #define OMP_DECLARE_SIMD_CLAUSES \
2539 (omp_mask (OMP_CLAUSE_SIMDLEN) | OMP_CLAUSE_LINEAR \
2540 | OMP_CLAUSE_UNIFORM | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_INBRANCH \
2541 | OMP_CLAUSE_NOTINBRANCH)
2542 #define OMP_DO_CLAUSES \
2543 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
2544 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
2545 | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE \
2546 | OMP_CLAUSE_LINEAR)
2547 #define OMP_SECTIONS_CLAUSES \
2548 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
2549 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
2550 #define OMP_SIMD_CLAUSES \
2551 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_LASTPRIVATE \
2552 | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_SAFELEN \
2553 | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_SIMDLEN)
2554 #define OMP_TASK_CLAUSES \
2555 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
2556 | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT \
2557 | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE \
2558 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_PRIORITY)
2559 #define OMP_TASKLOOP_CLAUSES \
2560 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
2561 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF \
2562 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL \
2563 | OMP_CLAUSE_MERGEABLE | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_GRAINSIZE \
2564 | OMP_CLAUSE_NUM_TASKS | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_NOGROUP)
2565 #define OMP_TARGET_CLAUSES \
2566 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
2567 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_PRIVATE \
2568 | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULTMAP \
2569 | OMP_CLAUSE_IS_DEVICE_PTR)
2570 #define OMP_TARGET_DATA_CLAUSES \
2571 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
2572 | OMP_CLAUSE_USE_DEVICE_PTR | OMP_CLAUSE_USE_DEVICE_ADDR)
2573 #define OMP_TARGET_ENTER_DATA_CLAUSES \
2574 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
2575 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
2576 #define OMP_TARGET_EXIT_DATA_CLAUSES \
2577 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
2578 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
2579 #define OMP_TARGET_UPDATE_CLAUSES \
2580 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_IF | OMP_CLAUSE_TO \
2581 | OMP_CLAUSE_FROM | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
2582 #define OMP_TEAMS_CLAUSES \
2583 (omp_mask (OMP_CLAUSE_NUM_TEAMS) | OMP_CLAUSE_THREAD_LIMIT \
2584 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
2585 | OMP_CLAUSE_SHARED | OMP_CLAUSE_REDUCTION)
2586 #define OMP_DISTRIBUTE_CLAUSES \
2587 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
2588 | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_DIST_SCHEDULE)
2589 #define OMP_SINGLE_CLAUSES \
2590 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE)
2591 #define OMP_ORDERED_CLAUSES \
2592 (omp_mask (OMP_CLAUSE_THREADS) | OMP_CLAUSE_SIMD)
2593 #define OMP_DECLARE_TARGET_CLAUSES \
2594 (omp_mask (OMP_CLAUSE_TO) | OMP_CLAUSE_LINK)
2595
2596
2597 static match
2598 match_omp (gfc_exec_op op, const omp_mask mask)
2599 {
2600 gfc_omp_clauses *c;
2601 if (gfc_match_omp_clauses (&c, mask) != MATCH_YES)
2602 return MATCH_ERROR;
2603 new_st.op = op;
2604 new_st.ext.omp_clauses = c;
2605 return MATCH_YES;
2606 }
2607
2608
2609 match
2610 gfc_match_omp_critical (void)
2611 {
2612 char n[GFC_MAX_SYMBOL_LEN+1];
2613 gfc_omp_clauses *c = NULL;
2614
2615 if (gfc_match (" ( %n )", n) != MATCH_YES)
2616 {
2617 n[0] = '\0';
2618 if (gfc_match_omp_eos () != MATCH_YES)
2619 {
2620 gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
2621 return MATCH_ERROR;
2622 }
2623 }
2624 else if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_HINT)) != MATCH_YES)
2625 return MATCH_ERROR;
2626
2627 new_st.op = EXEC_OMP_CRITICAL;
2628 new_st.ext.omp_clauses = c;
2629 if (n[0])
2630 c->critical_name = xstrdup (n);
2631 return MATCH_YES;
2632 }
2633
2634
2635 match
2636 gfc_match_omp_end_critical (void)
2637 {
2638 char n[GFC_MAX_SYMBOL_LEN+1];
2639
2640 if (gfc_match (" ( %n )", n) != MATCH_YES)
2641 n[0] = '\0';
2642 if (gfc_match_omp_eos () != MATCH_YES)
2643 {
2644 gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
2645 return MATCH_ERROR;
2646 }
2647
2648 new_st.op = EXEC_OMP_END_CRITICAL;
2649 new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
2650 return MATCH_YES;
2651 }
2652
2653
2654 match
2655 gfc_match_omp_distribute (void)
2656 {
2657 return match_omp (EXEC_OMP_DISTRIBUTE, OMP_DISTRIBUTE_CLAUSES);
2658 }
2659
2660
2661 match
2662 gfc_match_omp_distribute_parallel_do (void)
2663 {
2664 return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO,
2665 (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
2666 | OMP_DO_CLAUSES)
2667 & ~(omp_mask (OMP_CLAUSE_ORDERED))
2668 & ~(omp_mask (OMP_CLAUSE_LINEAR)));
2669 }
2670
2671
2672 match
2673 gfc_match_omp_distribute_parallel_do_simd (void)
2674 {
2675 return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD,
2676 (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
2677 | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
2678 & ~(omp_mask (OMP_CLAUSE_ORDERED)));
2679 }
2680
2681
2682 match
2683 gfc_match_omp_distribute_simd (void)
2684 {
2685 return match_omp (EXEC_OMP_DISTRIBUTE_SIMD,
2686 OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
2687 }
2688
2689
2690 match
2691 gfc_match_omp_do (void)
2692 {
2693 return match_omp (EXEC_OMP_DO, OMP_DO_CLAUSES);
2694 }
2695
2696
2697 match
2698 gfc_match_omp_do_simd (void)
2699 {
2700 return match_omp (EXEC_OMP_DO_SIMD, OMP_DO_CLAUSES | OMP_SIMD_CLAUSES);
2701 }
2702
2703
2704 match
2705 gfc_match_omp_flush (void)
2706 {
2707 gfc_omp_namelist *list = NULL;
2708 gfc_match_omp_variable_list (" (", &list, true);
2709 if (gfc_match_omp_eos () != MATCH_YES)
2710 {
2711 gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
2712 gfc_free_omp_namelist (list);
2713 return MATCH_ERROR;
2714 }
2715 new_st.op = EXEC_OMP_FLUSH;
2716 new_st.ext.omp_namelist = list;
2717 return MATCH_YES;
2718 }
2719
2720
2721 match
2722 gfc_match_omp_declare_simd (void)
2723 {
2724 locus where = gfc_current_locus;
2725 gfc_symbol *proc_name;
2726 gfc_omp_clauses *c;
2727 gfc_omp_declare_simd *ods;
2728 bool needs_space = false;
2729
2730 switch (gfc_match (" ( %s ) ", &proc_name))
2731 {
2732 case MATCH_YES: break;
2733 case MATCH_NO: proc_name = NULL; needs_space = true; break;
2734 case MATCH_ERROR: return MATCH_ERROR;
2735 }
2736
2737 if (gfc_match_omp_clauses (&c, OMP_DECLARE_SIMD_CLAUSES, true,
2738 needs_space) != MATCH_YES)
2739 return MATCH_ERROR;
2740
2741 if (gfc_current_ns->is_block_data)
2742 {
2743 gfc_free_omp_clauses (c);
2744 return MATCH_YES;
2745 }
2746
2747 ods = gfc_get_omp_declare_simd ();
2748 ods->where = where;
2749 ods->proc_name = proc_name;
2750 ods->clauses = c;
2751 ods->next = gfc_current_ns->omp_declare_simd;
2752 gfc_current_ns->omp_declare_simd = ods;
2753 return MATCH_YES;
2754 }
2755
2756
2757 static bool
2758 match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2)
2759 {
2760 match m;
2761 locus old_loc = gfc_current_locus;
2762 char sname[GFC_MAX_SYMBOL_LEN + 1];
2763 gfc_symbol *sym;
2764 gfc_namespace *ns = gfc_current_ns;
2765 gfc_expr *lvalue = NULL, *rvalue = NULL;
2766 gfc_symtree *st;
2767 gfc_actual_arglist *arglist;
2768
2769 m = gfc_match (" %v =", &lvalue);
2770 if (m != MATCH_YES)
2771 gfc_current_locus = old_loc;
2772 else
2773 {
2774 m = gfc_match (" %e )", &rvalue);
2775 if (m == MATCH_YES)
2776 {
2777 ns->code = gfc_get_code (EXEC_ASSIGN);
2778 ns->code->expr1 = lvalue;
2779 ns->code->expr2 = rvalue;
2780 ns->code->loc = old_loc;
2781 return true;
2782 }
2783
2784 gfc_current_locus = old_loc;
2785 gfc_free_expr (lvalue);
2786 }
2787
2788 m = gfc_match (" %n", sname);
2789 if (m != MATCH_YES)
2790 return false;
2791
2792 if (strcmp (sname, omp_sym1->name) == 0
2793 || strcmp (sname, omp_sym2->name) == 0)
2794 return false;
2795
2796 gfc_current_ns = ns->parent;
2797 if (gfc_get_ha_sym_tree (sname, &st))
2798 return false;
2799
2800 sym = st->n.sym;
2801 if (sym->attr.flavor != FL_PROCEDURE
2802 && sym->attr.flavor != FL_UNKNOWN)
2803 return false;
2804
2805 if (!sym->attr.generic
2806 && !sym->attr.subroutine
2807 && !sym->attr.function)
2808 {
2809 if (!(sym->attr.external && !sym->attr.referenced))
2810 {
2811 /* ...create a symbol in this scope... */
2812 if (sym->ns != gfc_current_ns
2813 && gfc_get_sym_tree (sname, NULL, &st, false) == 1)
2814 return false;
2815
2816 if (sym != st->n.sym)
2817 sym = st->n.sym;
2818 }
2819
2820 /* ...and then to try to make the symbol into a subroutine. */
2821 if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
2822 return false;
2823 }
2824
2825 gfc_set_sym_referenced (sym);
2826 gfc_gobble_whitespace ();
2827 if (gfc_peek_ascii_char () != '(')
2828 return false;
2829
2830 gfc_current_ns = ns;
2831 m = gfc_match_actual_arglist (1, &arglist);
2832 if (m != MATCH_YES)
2833 return false;
2834
2835 if (gfc_match_char (')') != MATCH_YES)
2836 return false;
2837
2838 ns->code = gfc_get_code (EXEC_CALL);
2839 ns->code->symtree = st;
2840 ns->code->ext.actual = arglist;
2841 ns->code->loc = old_loc;
2842 return true;
2843 }
2844
2845 static bool
2846 gfc_omp_udr_predef (gfc_omp_reduction_op rop, const char *name,
2847 gfc_typespec *ts, const char **n)
2848 {
2849 if (!gfc_numeric_ts (ts) && ts->type != BT_LOGICAL)
2850 return false;
2851
2852 switch (rop)
2853 {
2854 case OMP_REDUCTION_PLUS:
2855 case OMP_REDUCTION_MINUS:
2856 case OMP_REDUCTION_TIMES:
2857 return ts->type != BT_LOGICAL;
2858 case OMP_REDUCTION_AND:
2859 case OMP_REDUCTION_OR:
2860 case OMP_REDUCTION_EQV:
2861 case OMP_REDUCTION_NEQV:
2862 return ts->type == BT_LOGICAL;
2863 case OMP_REDUCTION_USER:
2864 if (name[0] != '.' && (ts->type == BT_INTEGER || ts->type == BT_REAL))
2865 {
2866 gfc_symbol *sym;
2867
2868 gfc_find_symbol (name, NULL, 1, &sym);
2869 if (sym != NULL)
2870 {
2871 if (sym->attr.intrinsic)
2872 *n = sym->name;
2873 else if ((sym->attr.flavor != FL_UNKNOWN
2874 && sym->attr.flavor != FL_PROCEDURE)
2875 || sym->attr.external
2876 || sym->attr.generic
2877 || sym->attr.entry
2878 || sym->attr.result
2879 || sym->attr.dummy
2880 || sym->attr.subroutine
2881 || sym->attr.pointer
2882 || sym->attr.target
2883 || sym->attr.cray_pointer
2884 || sym->attr.cray_pointee
2885 || (sym->attr.proc != PROC_UNKNOWN
2886 && sym->attr.proc != PROC_INTRINSIC)
2887 || sym->attr.if_source != IFSRC_UNKNOWN
2888 || sym == sym->ns->proc_name)
2889 *n = NULL;
2890 else
2891 *n = sym->name;
2892 }
2893 else
2894 *n = name;
2895 if (*n
2896 && (strcmp (*n, "max") == 0 || strcmp (*n, "min") == 0))
2897 return true;
2898 else if (*n
2899 && ts->type == BT_INTEGER
2900 && (strcmp (*n, "iand") == 0
2901 || strcmp (*n, "ior") == 0
2902 || strcmp (*n, "ieor") == 0))
2903 return true;
2904 }
2905 break;
2906 default:
2907 break;
2908 }
2909 return false;
2910 }
2911
2912 gfc_omp_udr *
2913 gfc_omp_udr_find (gfc_symtree *st, gfc_typespec *ts)
2914 {
2915 gfc_omp_udr *omp_udr;
2916
2917 if (st == NULL)
2918 return NULL;
2919
2920 for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
2921 if (omp_udr->ts.type == ts->type
2922 || ((omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
2923 && (ts->type == BT_DERIVED || ts->type == BT_CLASS)))
2924 {
2925 if (omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
2926 {
2927 if (strcmp (omp_udr->ts.u.derived->name, ts->u.derived->name) == 0)
2928 return omp_udr;
2929 }
2930 else if (omp_udr->ts.kind == ts->kind)
2931 {
2932 if (omp_udr->ts.type == BT_CHARACTER)
2933 {
2934 if (omp_udr->ts.u.cl->length == NULL
2935 || ts->u.cl->length == NULL)
2936 return omp_udr;
2937 if (omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
2938 return omp_udr;
2939 if (ts->u.cl->length->expr_type != EXPR_CONSTANT)
2940 return omp_udr;
2941 if (omp_udr->ts.u.cl->length->ts.type != BT_INTEGER)
2942 return omp_udr;
2943 if (ts->u.cl->length->ts.type != BT_INTEGER)
2944 return omp_udr;
2945 if (gfc_compare_expr (omp_udr->ts.u.cl->length,
2946 ts->u.cl->length, INTRINSIC_EQ) != 0)
2947 continue;
2948 }
2949 return omp_udr;
2950 }
2951 }
2952 return NULL;
2953 }
2954
2955 match
2956 gfc_match_omp_declare_reduction (void)
2957 {
2958 match m;
2959 gfc_intrinsic_op op;
2960 char name[GFC_MAX_SYMBOL_LEN + 3];
2961 auto_vec<gfc_typespec, 5> tss;
2962 gfc_typespec ts;
2963 unsigned int i;
2964 gfc_symtree *st;
2965 locus where = gfc_current_locus;
2966 locus end_loc = gfc_current_locus;
2967 bool end_loc_set = false;
2968 gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
2969
2970 if (gfc_match_char ('(') != MATCH_YES)
2971 return MATCH_ERROR;
2972
2973 m = gfc_match (" %o : ", &op);
2974 if (m == MATCH_ERROR)
2975 return MATCH_ERROR;
2976 if (m == MATCH_YES)
2977 {
2978 snprintf (name, sizeof name, "operator %s", gfc_op2string (op));
2979 rop = (gfc_omp_reduction_op) op;
2980 }
2981 else
2982 {
2983 m = gfc_match_defined_op_name (name + 1, 1);
2984 if (m == MATCH_ERROR)
2985 return MATCH_ERROR;
2986 if (m == MATCH_YES)
2987 {
2988 name[0] = '.';
2989 strcat (name, ".");
2990 if (gfc_match (" : ") != MATCH_YES)
2991 return MATCH_ERROR;
2992 }
2993 else
2994 {
2995 if (gfc_match (" %n : ", name) != MATCH_YES)
2996 return MATCH_ERROR;
2997 }
2998 rop = OMP_REDUCTION_USER;
2999 }
3000
3001 m = gfc_match_type_spec (&ts);
3002 if (m != MATCH_YES)
3003 return MATCH_ERROR;
3004 /* Treat len=: the same as len=*. */
3005 if (ts.type == BT_CHARACTER)
3006 ts.deferred = false;
3007 tss.safe_push (ts);
3008
3009 while (gfc_match_char (',') == MATCH_YES)
3010 {
3011 m = gfc_match_type_spec (&ts);
3012 if (m != MATCH_YES)
3013 return MATCH_ERROR;
3014 tss.safe_push (ts);
3015 }
3016 if (gfc_match_char (':') != MATCH_YES)
3017 return MATCH_ERROR;
3018
3019 st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
3020 for (i = 0; i < tss.length (); i++)
3021 {
3022 gfc_symtree *omp_out, *omp_in;
3023 gfc_symtree *omp_priv = NULL, *omp_orig = NULL;
3024 gfc_namespace *combiner_ns, *initializer_ns = NULL;
3025 gfc_omp_udr *prev_udr, *omp_udr;
3026 const char *predef_name = NULL;
3027
3028 omp_udr = gfc_get_omp_udr ();
3029 omp_udr->name = gfc_get_string ("%s", name);
3030 omp_udr->rop = rop;
3031 omp_udr->ts = tss[i];
3032 omp_udr->where = where;
3033
3034 gfc_current_ns = combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
3035 combiner_ns->proc_name = combiner_ns->parent->proc_name;
3036
3037 gfc_get_sym_tree ("omp_out", combiner_ns, &omp_out, false);
3038 gfc_get_sym_tree ("omp_in", combiner_ns, &omp_in, false);
3039 combiner_ns->omp_udr_ns = 1;
3040 omp_out->n.sym->ts = tss[i];
3041 omp_in->n.sym->ts = tss[i];
3042 omp_out->n.sym->attr.omp_udr_artificial_var = 1;
3043 omp_in->n.sym->attr.omp_udr_artificial_var = 1;
3044 omp_out->n.sym->attr.flavor = FL_VARIABLE;
3045 omp_in->n.sym->attr.flavor = FL_VARIABLE;
3046 gfc_commit_symbols ();
3047 omp_udr->combiner_ns = combiner_ns;
3048 omp_udr->omp_out = omp_out->n.sym;
3049 omp_udr->omp_in = omp_in->n.sym;
3050
3051 locus old_loc = gfc_current_locus;
3052
3053 if (!match_udr_expr (omp_out, omp_in))
3054 {
3055 syntax:
3056 gfc_current_locus = old_loc;
3057 gfc_current_ns = combiner_ns->parent;
3058 gfc_undo_symbols ();
3059 gfc_free_omp_udr (omp_udr);
3060 return MATCH_ERROR;
3061 }
3062
3063 if (gfc_match (" initializer ( ") == MATCH_YES)
3064 {
3065 gfc_current_ns = combiner_ns->parent;
3066 initializer_ns = gfc_get_namespace (gfc_current_ns, 1);
3067 gfc_current_ns = initializer_ns;
3068 initializer_ns->proc_name = initializer_ns->parent->proc_name;
3069
3070 gfc_get_sym_tree ("omp_priv", initializer_ns, &omp_priv, false);
3071 gfc_get_sym_tree ("omp_orig", initializer_ns, &omp_orig, false);
3072 initializer_ns->omp_udr_ns = 1;
3073 omp_priv->n.sym->ts = tss[i];
3074 omp_orig->n.sym->ts = tss[i];
3075 omp_priv->n.sym->attr.omp_udr_artificial_var = 1;
3076 omp_orig->n.sym->attr.omp_udr_artificial_var = 1;
3077 omp_priv->n.sym->attr.flavor = FL_VARIABLE;
3078 omp_orig->n.sym->attr.flavor = FL_VARIABLE;
3079 gfc_commit_symbols ();
3080 omp_udr->initializer_ns = initializer_ns;
3081 omp_udr->omp_priv = omp_priv->n.sym;
3082 omp_udr->omp_orig = omp_orig->n.sym;
3083
3084 if (!match_udr_expr (omp_priv, omp_orig))
3085 goto syntax;
3086 }
3087
3088 gfc_current_ns = combiner_ns->parent;
3089 if (!end_loc_set)
3090 {
3091 end_loc_set = true;
3092 end_loc = gfc_current_locus;
3093 }
3094 gfc_current_locus = old_loc;
3095
3096 prev_udr = gfc_omp_udr_find (st, &tss[i]);
3097 if (gfc_omp_udr_predef (rop, name, &tss[i], &predef_name)
3098 /* Don't error on !$omp declare reduction (min : integer : ...)
3099 just yet, there could be integer :: min afterwards,
3100 making it valid. When the UDR is resolved, we'll get
3101 to it again. */
3102 && (rop != OMP_REDUCTION_USER || name[0] == '.'))
3103 {
3104 if (predef_name)
3105 gfc_error_now ("Redefinition of predefined %s "
3106 "!$OMP DECLARE REDUCTION at %L",
3107 predef_name, &where);
3108 else
3109 gfc_error_now ("Redefinition of predefined "
3110 "!$OMP DECLARE REDUCTION at %L", &where);
3111 }
3112 else if (prev_udr)
3113 {
3114 gfc_error_now ("Redefinition of !$OMP DECLARE REDUCTION at %L",
3115 &where);
3116 gfc_error_now ("Previous !$OMP DECLARE REDUCTION at %L",
3117 &prev_udr->where);
3118 }
3119 else if (st)
3120 {
3121 omp_udr->next = st->n.omp_udr;
3122 st->n.omp_udr = omp_udr;
3123 }
3124 else
3125 {
3126 st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name);
3127 st->n.omp_udr = omp_udr;
3128 }
3129 }
3130
3131 if (end_loc_set)
3132 {
3133 gfc_current_locus = end_loc;
3134 if (gfc_match_omp_eos () != MATCH_YES)
3135 {
3136 gfc_error ("Unexpected junk after !$OMP DECLARE REDUCTION at %C");
3137 gfc_current_locus = where;
3138 return MATCH_ERROR;
3139 }
3140
3141 return MATCH_YES;
3142 }
3143 gfc_clear_error ();
3144 return MATCH_ERROR;
3145 }
3146
3147
3148 match
3149 gfc_match_omp_declare_target (void)
3150 {
3151 locus old_loc;
3152 match m;
3153 gfc_omp_clauses *c = NULL;
3154 int list;
3155 gfc_omp_namelist *n;
3156 gfc_symbol *s;
3157
3158 old_loc = gfc_current_locus;
3159
3160 if (gfc_current_ns->proc_name
3161 && gfc_match_omp_eos () == MATCH_YES)
3162 {
3163 if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
3164 gfc_current_ns->proc_name->name,
3165 &old_loc))
3166 goto cleanup;
3167 return MATCH_YES;
3168 }
3169
3170 if (gfc_current_ns->proc_name
3171 && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY)
3172 {
3173 gfc_error ("Only the !$OMP DECLARE TARGET form without "
3174 "clauses is allowed in interface block at %C");
3175 goto cleanup;
3176 }
3177
3178 m = gfc_match (" (");
3179 if (m == MATCH_YES)
3180 {
3181 c = gfc_get_omp_clauses ();
3182 gfc_current_locus = old_loc;
3183 m = gfc_match_omp_to_link (" (", &c->lists[OMP_LIST_TO]);
3184 if (m != MATCH_YES)
3185 goto syntax;
3186 if (gfc_match_omp_eos () != MATCH_YES)
3187 {
3188 gfc_error ("Unexpected junk after !$OMP DECLARE TARGET at %C");
3189 goto cleanup;
3190 }
3191 }
3192 else if (gfc_match_omp_clauses (&c, OMP_DECLARE_TARGET_CLAUSES) != MATCH_YES)
3193 return MATCH_ERROR;
3194
3195 gfc_buffer_error (false);
3196
3197 for (list = OMP_LIST_TO; list != OMP_LIST_NUM;
3198 list = (list == OMP_LIST_TO ? OMP_LIST_LINK : OMP_LIST_NUM))
3199 for (n = c->lists[list]; n; n = n->next)
3200 if (n->sym)
3201 n->sym->mark = 0;
3202 else if (n->u.common->head)
3203 n->u.common->head->mark = 0;
3204
3205 for (list = OMP_LIST_TO; list != OMP_LIST_NUM;
3206 list = (list == OMP_LIST_TO ? OMP_LIST_LINK : OMP_LIST_NUM))
3207 for (n = c->lists[list]; n; n = n->next)
3208 if (n->sym)
3209 {
3210 if (n->sym->attr.in_common)
3211 gfc_error_now ("OMP DECLARE TARGET variable at %L is an "
3212 "element of a COMMON block", &n->where);
3213 else if (n->sym->attr.omp_declare_target
3214 && n->sym->attr.omp_declare_target_link
3215 && list != OMP_LIST_LINK)
3216 gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
3217 "mentioned in LINK clause and later in TO clause",
3218 &n->where);
3219 else if (n->sym->attr.omp_declare_target
3220 && !n->sym->attr.omp_declare_target_link
3221 && list == OMP_LIST_LINK)
3222 gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
3223 "mentioned in TO clause and later in LINK clause",
3224 &n->where);
3225 else if (n->sym->mark)
3226 gfc_error_now ("Variable at %L mentioned multiple times in "
3227 "clauses of the same OMP DECLARE TARGET directive",
3228 &n->where);
3229 else if (gfc_add_omp_declare_target (&n->sym->attr, n->sym->name,
3230 &n->sym->declared_at))
3231 {
3232 if (list == OMP_LIST_LINK)
3233 gfc_add_omp_declare_target_link (&n->sym->attr, n->sym->name,
3234 &n->sym->declared_at);
3235 }
3236 n->sym->mark = 1;
3237 }
3238 else if (n->u.common->omp_declare_target
3239 && n->u.common->omp_declare_target_link
3240 && list != OMP_LIST_LINK)
3241 gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously "
3242 "mentioned in LINK clause and later in TO clause",
3243 &n->where);
3244 else if (n->u.common->omp_declare_target
3245 && !n->u.common->omp_declare_target_link
3246 && list == OMP_LIST_LINK)
3247 gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously "
3248 "mentioned in TO clause and later in LINK clause",
3249 &n->where);
3250 else if (n->u.common->head && n->u.common->head->mark)
3251 gfc_error_now ("COMMON at %L mentioned multiple times in "
3252 "clauses of the same OMP DECLARE TARGET directive",
3253 &n->where);
3254 else
3255 {
3256 n->u.common->omp_declare_target = 1;
3257 n->u.common->omp_declare_target_link = (list == OMP_LIST_LINK);
3258 for (s = n->u.common->head; s; s = s->common_next)
3259 {
3260 s->mark = 1;
3261 if (gfc_add_omp_declare_target (&s->attr, s->name,
3262 &s->declared_at))
3263 {
3264 if (list == OMP_LIST_LINK)
3265 gfc_add_omp_declare_target_link (&s->attr, s->name,
3266 &s->declared_at);
3267 }
3268 }
3269 }
3270
3271 gfc_buffer_error (true);
3272
3273 if (c)
3274 gfc_free_omp_clauses (c);
3275 return MATCH_YES;
3276
3277 syntax:
3278 gfc_error ("Syntax error in !$OMP DECLARE TARGET list at %C");
3279
3280 cleanup:
3281 gfc_current_locus = old_loc;
3282 if (c)
3283 gfc_free_omp_clauses (c);
3284 return MATCH_ERROR;
3285 }
3286
3287
3288 match
3289 gfc_match_omp_threadprivate (void)
3290 {
3291 locus old_loc;
3292 char n[GFC_MAX_SYMBOL_LEN+1];
3293 gfc_symbol *sym;
3294 match m;
3295 gfc_symtree *st;
3296
3297 old_loc = gfc_current_locus;
3298
3299 m = gfc_match (" (");
3300 if (m != MATCH_YES)
3301 return m;
3302
3303 for (;;)
3304 {
3305 m = gfc_match_symbol (&sym, 0);
3306 switch (m)
3307 {
3308 case MATCH_YES:
3309 if (sym->attr.in_common)
3310 gfc_error_now ("Threadprivate variable at %C is an element of "
3311 "a COMMON block");
3312 else if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at))
3313 goto cleanup;
3314 goto next_item;
3315 case MATCH_NO:
3316 break;
3317 case MATCH_ERROR:
3318 goto cleanup;
3319 }
3320
3321 m = gfc_match (" / %n /", n);
3322 if (m == MATCH_ERROR)
3323 goto cleanup;
3324 if (m == MATCH_NO || n[0] == '\0')
3325 goto syntax;
3326
3327 st = gfc_find_symtree (gfc_current_ns->common_root, n);
3328 if (st == NULL)
3329 {
3330 gfc_error ("COMMON block /%s/ not found at %C", n);
3331 goto cleanup;
3332 }
3333 st->n.common->threadprivate = 1;
3334 for (sym = st->n.common->head; sym; sym = sym->common_next)
3335 if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at))
3336 goto cleanup;
3337
3338 next_item:
3339 if (gfc_match_char (')') == MATCH_YES)
3340 break;
3341 if (gfc_match_char (',') != MATCH_YES)
3342 goto syntax;
3343 }
3344
3345 if (gfc_match_omp_eos () != MATCH_YES)
3346 {
3347 gfc_error ("Unexpected junk after OMP THREADPRIVATE at %C");
3348 goto cleanup;
3349 }
3350
3351 return MATCH_YES;
3352
3353 syntax:
3354 gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C");
3355
3356 cleanup:
3357 gfc_current_locus = old_loc;
3358 return MATCH_ERROR;
3359 }
3360
3361
3362 match
3363 gfc_match_omp_parallel (void)
3364 {
3365 return match_omp (EXEC_OMP_PARALLEL, OMP_PARALLEL_CLAUSES);
3366 }
3367
3368
3369 match
3370 gfc_match_omp_parallel_do (void)
3371 {
3372 return match_omp (EXEC_OMP_PARALLEL_DO,
3373 OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES);
3374 }
3375
3376
3377 match
3378 gfc_match_omp_parallel_do_simd (void)
3379 {
3380 return match_omp (EXEC_OMP_PARALLEL_DO_SIMD,
3381 OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES);
3382 }
3383
3384
3385 match
3386 gfc_match_omp_parallel_sections (void)
3387 {
3388 return match_omp (EXEC_OMP_PARALLEL_SECTIONS,
3389 OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES);
3390 }
3391
3392
3393 match
3394 gfc_match_omp_parallel_workshare (void)
3395 {
3396 return match_omp (EXEC_OMP_PARALLEL_WORKSHARE, OMP_PARALLEL_CLAUSES);
3397 }
3398
3399
3400 match
3401 gfc_match_omp_sections (void)
3402 {
3403 return match_omp (EXEC_OMP_SECTIONS, OMP_SECTIONS_CLAUSES);
3404 }
3405
3406
3407 match
3408 gfc_match_omp_simd (void)
3409 {
3410 return match_omp (EXEC_OMP_SIMD, OMP_SIMD_CLAUSES);
3411 }
3412
3413
3414 match
3415 gfc_match_omp_single (void)
3416 {
3417 return match_omp (EXEC_OMP_SINGLE, OMP_SINGLE_CLAUSES);
3418 }
3419
3420
3421 match
3422 gfc_match_omp_target (void)
3423 {
3424 return match_omp (EXEC_OMP_TARGET, OMP_TARGET_CLAUSES);
3425 }
3426
3427
3428 match
3429 gfc_match_omp_target_data (void)
3430 {
3431 return match_omp (EXEC_OMP_TARGET_DATA, OMP_TARGET_DATA_CLAUSES);
3432 }
3433
3434
3435 match
3436 gfc_match_omp_target_enter_data (void)
3437 {
3438 return match_omp (EXEC_OMP_TARGET_ENTER_DATA, OMP_TARGET_ENTER_DATA_CLAUSES);
3439 }
3440
3441
3442 match
3443 gfc_match_omp_target_exit_data (void)
3444 {
3445 return match_omp (EXEC_OMP_TARGET_EXIT_DATA, OMP_TARGET_EXIT_DATA_CLAUSES);
3446 }
3447
3448
3449 match
3450 gfc_match_omp_target_parallel (void)
3451 {
3452 return match_omp (EXEC_OMP_TARGET_PARALLEL,
3453 (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES)
3454 & ~(omp_mask (OMP_CLAUSE_COPYIN)));
3455 }
3456
3457
3458 match
3459 gfc_match_omp_target_parallel_do (void)
3460 {
3461 return match_omp (EXEC_OMP_TARGET_PARALLEL_DO,
3462 (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES
3463 | OMP_DO_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN)));
3464 }
3465
3466
3467 match
3468 gfc_match_omp_target_parallel_do_simd (void)
3469 {
3470 return match_omp (EXEC_OMP_TARGET_PARALLEL_DO_SIMD,
3471 (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
3472 | OMP_SIMD_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN)));
3473 }
3474
3475
3476 match
3477 gfc_match_omp_target_simd (void)
3478 {
3479 return match_omp (EXEC_OMP_TARGET_SIMD,
3480 OMP_TARGET_CLAUSES | OMP_SIMD_CLAUSES);
3481 }
3482
3483
3484 match
3485 gfc_match_omp_target_teams (void)
3486 {
3487 return match_omp (EXEC_OMP_TARGET_TEAMS,
3488 OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES);
3489 }
3490
3491
3492 match
3493 gfc_match_omp_target_teams_distribute (void)
3494 {
3495 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE,
3496 OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
3497 | OMP_DISTRIBUTE_CLAUSES);
3498 }
3499
3500
3501 match
3502 gfc_match_omp_target_teams_distribute_parallel_do (void)
3503 {
3504 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO,
3505 (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
3506 | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
3507 | OMP_DO_CLAUSES)
3508 & ~(omp_mask (OMP_CLAUSE_ORDERED))
3509 & ~(omp_mask (OMP_CLAUSE_LINEAR)));
3510 }
3511
3512
3513 match
3514 gfc_match_omp_target_teams_distribute_parallel_do_simd (void)
3515 {
3516 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
3517 (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
3518 | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
3519 | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
3520 & ~(omp_mask (OMP_CLAUSE_ORDERED)));
3521 }
3522
3523
3524 match
3525 gfc_match_omp_target_teams_distribute_simd (void)
3526 {
3527 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD,
3528 OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
3529 | OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
3530 }
3531
3532
3533 match
3534 gfc_match_omp_target_update (void)
3535 {
3536 return match_omp (EXEC_OMP_TARGET_UPDATE, OMP_TARGET_UPDATE_CLAUSES);
3537 }
3538
3539
3540 match
3541 gfc_match_omp_task (void)
3542 {
3543 return match_omp (EXEC_OMP_TASK, OMP_TASK_CLAUSES);
3544 }
3545
3546
3547 match
3548 gfc_match_omp_taskloop (void)
3549 {
3550 return match_omp (EXEC_OMP_TASKLOOP, OMP_TASKLOOP_CLAUSES);
3551 }
3552
3553
3554 match
3555 gfc_match_omp_taskloop_simd (void)
3556 {
3557 return match_omp (EXEC_OMP_TASKLOOP_SIMD,
3558 (OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES)
3559 & ~(omp_mask (OMP_CLAUSE_REDUCTION)));
3560 }
3561
3562
3563 match
3564 gfc_match_omp_taskwait (void)
3565 {
3566 if (gfc_match_omp_eos () != MATCH_YES)
3567 {
3568 gfc_error ("Unexpected junk after TASKWAIT clause at %C");
3569 return MATCH_ERROR;
3570 }
3571 new_st.op = EXEC_OMP_TASKWAIT;
3572 new_st.ext.omp_clauses = NULL;
3573 return MATCH_YES;
3574 }
3575
3576
3577 match
3578 gfc_match_omp_taskyield (void)
3579 {
3580 if (gfc_match_omp_eos () != MATCH_YES)
3581 {
3582 gfc_error ("Unexpected junk after TASKYIELD clause at %C");
3583 return MATCH_ERROR;
3584 }
3585 new_st.op = EXEC_OMP_TASKYIELD;
3586 new_st.ext.omp_clauses = NULL;
3587 return MATCH_YES;
3588 }
3589
3590
3591 match
3592 gfc_match_omp_teams (void)
3593 {
3594 return match_omp (EXEC_OMP_TEAMS, OMP_TEAMS_CLAUSES);
3595 }
3596
3597
3598 match
3599 gfc_match_omp_teams_distribute (void)
3600 {
3601 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE,
3602 OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES);
3603 }
3604
3605
3606 match
3607 gfc_match_omp_teams_distribute_parallel_do (void)
3608 {
3609 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO,
3610 (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
3611 | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
3612 & ~(omp_mask (OMP_CLAUSE_ORDERED))
3613 & ~(omp_mask (OMP_CLAUSE_LINEAR)));
3614 }
3615
3616
3617 match
3618 gfc_match_omp_teams_distribute_parallel_do_simd (void)
3619 {
3620 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
3621 (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
3622 | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
3623 | OMP_SIMD_CLAUSES) & ~(omp_mask (OMP_CLAUSE_ORDERED)));
3624 }
3625
3626
3627 match
3628 gfc_match_omp_teams_distribute_simd (void)
3629 {
3630 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_SIMD,
3631 OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
3632 | OMP_SIMD_CLAUSES);
3633 }
3634
3635
3636 match
3637 gfc_match_omp_workshare (void)
3638 {
3639 if (gfc_match_omp_eos () != MATCH_YES)
3640 {
3641 gfc_error ("Unexpected junk after $OMP WORKSHARE statement at %C");
3642 return MATCH_ERROR;
3643 }
3644 new_st.op = EXEC_OMP_WORKSHARE;
3645 new_st.ext.omp_clauses = gfc_get_omp_clauses ();
3646 return MATCH_YES;
3647 }
3648
3649
3650 match
3651 gfc_match_omp_master (void)
3652 {
3653 if (gfc_match_omp_eos () != MATCH_YES)
3654 {
3655 gfc_error ("Unexpected junk after $OMP MASTER statement at %C");
3656 return MATCH_ERROR;
3657 }
3658 new_st.op = EXEC_OMP_MASTER;
3659 new_st.ext.omp_clauses = NULL;
3660 return MATCH_YES;
3661 }
3662
3663
3664 match
3665 gfc_match_omp_ordered (void)
3666 {
3667 return match_omp (EXEC_OMP_ORDERED, OMP_ORDERED_CLAUSES);
3668 }
3669
3670
3671 match
3672 gfc_match_omp_ordered_depend (void)
3673 {
3674 return match_omp (EXEC_OMP_ORDERED, omp_mask (OMP_CLAUSE_DEPEND));
3675 }
3676
3677
3678 static match
3679 gfc_match_omp_oacc_atomic (bool omp_p)
3680 {
3681 gfc_omp_atomic_op op = GFC_OMP_ATOMIC_UPDATE;
3682 int seq_cst = 0;
3683 if (gfc_match ("% seq_cst") == MATCH_YES)
3684 seq_cst = 1;
3685 locus old_loc = gfc_current_locus;
3686 if (seq_cst && gfc_match_char (',') == MATCH_YES)
3687 seq_cst = 2;
3688 if (seq_cst == 2
3689 || gfc_match_space () == MATCH_YES)
3690 {
3691 gfc_gobble_whitespace ();
3692 if (gfc_match ("update") == MATCH_YES)
3693 op = GFC_OMP_ATOMIC_UPDATE;
3694 else if (gfc_match ("read") == MATCH_YES)
3695 op = GFC_OMP_ATOMIC_READ;
3696 else if (gfc_match ("write") == MATCH_YES)
3697 op = GFC_OMP_ATOMIC_WRITE;
3698 else if (gfc_match ("capture") == MATCH_YES)
3699 op = GFC_OMP_ATOMIC_CAPTURE;
3700 else
3701 {
3702 if (seq_cst == 2)
3703 gfc_current_locus = old_loc;
3704 goto finish;
3705 }
3706 if (!seq_cst
3707 && (gfc_match (", seq_cst") == MATCH_YES
3708 || gfc_match ("% seq_cst") == MATCH_YES))
3709 seq_cst = 1;
3710 }
3711 finish:
3712 if (gfc_match_omp_eos () != MATCH_YES)
3713 {
3714 gfc_error ("Unexpected junk after $OMP ATOMIC statement at %C");
3715 return MATCH_ERROR;
3716 }
3717 new_st.op = (omp_p ? EXEC_OMP_ATOMIC : EXEC_OACC_ATOMIC);
3718 if (seq_cst)
3719 op = (gfc_omp_atomic_op) (op | GFC_OMP_ATOMIC_SEQ_CST);
3720 new_st.ext.omp_atomic = op;
3721 return MATCH_YES;
3722 }
3723
3724 match
3725 gfc_match_oacc_atomic (void)
3726 {
3727 return gfc_match_omp_oacc_atomic (false);
3728 }
3729
3730 match
3731 gfc_match_omp_atomic (void)
3732 {
3733 return gfc_match_omp_oacc_atomic (true);
3734 }
3735
3736 match
3737 gfc_match_omp_barrier (void)
3738 {
3739 if (gfc_match_omp_eos () != MATCH_YES)
3740 {
3741 gfc_error ("Unexpected junk after $OMP BARRIER statement at %C");
3742 return MATCH_ERROR;
3743 }
3744 new_st.op = EXEC_OMP_BARRIER;
3745 new_st.ext.omp_clauses = NULL;
3746 return MATCH_YES;
3747 }
3748
3749
3750 match
3751 gfc_match_omp_taskgroup (void)
3752 {
3753 if (gfc_match_omp_eos () != MATCH_YES)
3754 {
3755 gfc_error ("Unexpected junk after $OMP TASKGROUP statement at %C");
3756 return MATCH_ERROR;
3757 }
3758 new_st.op = EXEC_OMP_TASKGROUP;
3759 return MATCH_YES;
3760 }
3761
3762
3763 static enum gfc_omp_cancel_kind
3764 gfc_match_omp_cancel_kind (void)
3765 {
3766 if (gfc_match_space () != MATCH_YES)
3767 return OMP_CANCEL_UNKNOWN;
3768 if (gfc_match ("parallel") == MATCH_YES)
3769 return OMP_CANCEL_PARALLEL;
3770 if (gfc_match ("sections") == MATCH_YES)
3771 return OMP_CANCEL_SECTIONS;
3772 if (gfc_match ("do") == MATCH_YES)
3773 return OMP_CANCEL_DO;
3774 if (gfc_match ("taskgroup") == MATCH_YES)
3775 return OMP_CANCEL_TASKGROUP;
3776 return OMP_CANCEL_UNKNOWN;
3777 }
3778
3779
3780 match
3781 gfc_match_omp_cancel (void)
3782 {
3783 gfc_omp_clauses *c;
3784 enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
3785 if (kind == OMP_CANCEL_UNKNOWN)
3786 return MATCH_ERROR;
3787 if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_IF), false) != MATCH_YES)
3788 return MATCH_ERROR;
3789 c->cancel = kind;
3790 new_st.op = EXEC_OMP_CANCEL;
3791 new_st.ext.omp_clauses = c;
3792 return MATCH_YES;
3793 }
3794
3795
3796 match
3797 gfc_match_omp_cancellation_point (void)
3798 {
3799 gfc_omp_clauses *c;
3800 enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
3801 if (kind == OMP_CANCEL_UNKNOWN)
3802 return MATCH_ERROR;
3803 if (gfc_match_omp_eos () != MATCH_YES)
3804 {
3805 gfc_error ("Unexpected junk after $OMP CANCELLATION POINT statement "
3806 "at %C");
3807 return MATCH_ERROR;
3808 }
3809 c = gfc_get_omp_clauses ();
3810 c->cancel = kind;
3811 new_st.op = EXEC_OMP_CANCELLATION_POINT;
3812 new_st.ext.omp_clauses = c;
3813 return MATCH_YES;
3814 }
3815
3816
3817 match
3818 gfc_match_omp_end_nowait (void)
3819 {
3820 bool nowait = false;
3821 if (gfc_match ("% nowait") == MATCH_YES)
3822 nowait = true;
3823 if (gfc_match_omp_eos () != MATCH_YES)
3824 {
3825 gfc_error ("Unexpected junk after NOWAIT clause at %C");
3826 return MATCH_ERROR;
3827 }
3828 new_st.op = EXEC_OMP_END_NOWAIT;
3829 new_st.ext.omp_bool = nowait;
3830 return MATCH_YES;
3831 }
3832
3833
3834 match
3835 gfc_match_omp_end_single (void)
3836 {
3837 gfc_omp_clauses *c;
3838 if (gfc_match ("% nowait") == MATCH_YES)
3839 {
3840 new_st.op = EXEC_OMP_END_NOWAIT;
3841 new_st.ext.omp_bool = true;
3842 return MATCH_YES;
3843 }
3844 if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_COPYPRIVATE))
3845 != MATCH_YES)
3846 return MATCH_ERROR;
3847 new_st.op = EXEC_OMP_END_SINGLE;
3848 new_st.ext.omp_clauses = c;
3849 return MATCH_YES;
3850 }
3851
3852
3853 static bool
3854 oacc_is_loop (gfc_code *code)
3855 {
3856 return code->op == EXEC_OACC_PARALLEL_LOOP
3857 || code->op == EXEC_OACC_KERNELS_LOOP
3858 || code->op == EXEC_OACC_SERIAL_LOOP
3859 || code->op == EXEC_OACC_LOOP;
3860 }
3861
3862 static void
3863 resolve_scalar_int_expr (gfc_expr *expr, const char *clause)
3864 {
3865 if (!gfc_resolve_expr (expr)
3866 || expr->ts.type != BT_INTEGER
3867 || expr->rank != 0)
3868 gfc_error ("%s clause at %L requires a scalar INTEGER expression",
3869 clause, &expr->where);
3870 }
3871
3872 static void
3873 resolve_positive_int_expr (gfc_expr *expr, const char *clause)
3874 {
3875 resolve_scalar_int_expr (expr, clause);
3876 if (expr->expr_type == EXPR_CONSTANT
3877 && expr->ts.type == BT_INTEGER
3878 && mpz_sgn (expr->value.integer) <= 0)
3879 gfc_warning (0, "INTEGER expression of %s clause at %L must be positive",
3880 clause, &expr->where);
3881 }
3882
3883 static void
3884 resolve_nonnegative_int_expr (gfc_expr *expr, const char *clause)
3885 {
3886 resolve_scalar_int_expr (expr, clause);
3887 if (expr->expr_type == EXPR_CONSTANT
3888 && expr->ts.type == BT_INTEGER
3889 && mpz_sgn (expr->value.integer) < 0)
3890 gfc_warning (0, "INTEGER expression of %s clause at %L must be "
3891 "non-negative", clause, &expr->where);
3892 }
3893
3894 /* Emits error when symbol is pointer, cray pointer or cray pointee
3895 of derived of polymorphic type. */
3896
3897 static void
3898 check_symbol_not_pointer (gfc_symbol *sym, locus loc, const char *name)
3899 {
3900 if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointer)
3901 gfc_error ("Cray pointer object %qs of derived type in %s clause at %L",
3902 sym->name, name, &loc);
3903 if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointee)
3904 gfc_error ("Cray pointee object %qs of derived type in %s clause at %L",
3905 sym->name, name, &loc);
3906
3907 if ((sym->ts.type == BT_ASSUMED && sym->attr.pointer)
3908 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
3909 && CLASS_DATA (sym)->attr.pointer))
3910 gfc_error ("POINTER object %qs of polymorphic type in %s clause at %L",
3911 sym->name, name, &loc);
3912 if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointer)
3913 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
3914 && CLASS_DATA (sym)->attr.cray_pointer))
3915 gfc_error ("Cray pointer object %qs of polymorphic type in %s clause at %L",
3916 sym->name, name, &loc);
3917 if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointee)
3918 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
3919 && CLASS_DATA (sym)->attr.cray_pointee))
3920 gfc_error ("Cray pointee object %qs of polymorphic type in %s clause at %L",
3921 sym->name, name, &loc);
3922 }
3923
3924 /* Emits error when symbol represents assumed size/rank array. */
3925
3926 static void
3927 check_array_not_assumed (gfc_symbol *sym, locus loc, const char *name)
3928 {
3929 if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
3930 gfc_error ("Assumed size array %qs in %s clause at %L",
3931 sym->name, name, &loc);
3932 if (sym->as && sym->as->type == AS_ASSUMED_RANK)
3933 gfc_error ("Assumed rank array %qs in %s clause at %L",
3934 sym->name, name, &loc);
3935 }
3936
3937 static void
3938 resolve_oacc_data_clauses (gfc_symbol *sym, locus loc, const char *name)
3939 {
3940 check_array_not_assumed (sym, loc, name);
3941 }
3942
3943 static void
3944 resolve_oacc_deviceptr_clause (gfc_symbol *sym, locus loc, const char *name)
3945 {
3946 if (sym->attr.pointer
3947 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
3948 && CLASS_DATA (sym)->attr.class_pointer))
3949 gfc_error ("POINTER object %qs in %s clause at %L",
3950 sym->name, name, &loc);
3951 if (sym->attr.cray_pointer
3952 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
3953 && CLASS_DATA (sym)->attr.cray_pointer))
3954 gfc_error ("Cray pointer object %qs in %s clause at %L",
3955 sym->name, name, &loc);
3956 if (sym->attr.cray_pointee
3957 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
3958 && CLASS_DATA (sym)->attr.cray_pointee))
3959 gfc_error ("Cray pointee object %qs in %s clause at %L",
3960 sym->name, name, &loc);
3961 if (sym->attr.allocatable
3962 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
3963 && CLASS_DATA (sym)->attr.allocatable))
3964 gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
3965 sym->name, name, &loc);
3966 if (sym->attr.value)
3967 gfc_error ("VALUE object %qs in %s clause at %L",
3968 sym->name, name, &loc);
3969 check_array_not_assumed (sym, loc, name);
3970 }
3971
3972
3973 struct resolve_omp_udr_callback_data
3974 {
3975 gfc_symbol *sym1, *sym2;
3976 };
3977
3978
3979 static int
3980 resolve_omp_udr_callback (gfc_expr **e, int *, void *data)
3981 {
3982 struct resolve_omp_udr_callback_data *rcd
3983 = (struct resolve_omp_udr_callback_data *) data;
3984 if ((*e)->expr_type == EXPR_VARIABLE
3985 && ((*e)->symtree->n.sym == rcd->sym1
3986 || (*e)->symtree->n.sym == rcd->sym2))
3987 {
3988 gfc_ref *ref = gfc_get_ref ();
3989 ref->type = REF_ARRAY;
3990 ref->u.ar.where = (*e)->where;
3991 ref->u.ar.as = (*e)->symtree->n.sym->as;
3992 ref->u.ar.type = AR_FULL;
3993 ref->u.ar.dimen = 0;
3994 ref->next = (*e)->ref;
3995 (*e)->ref = ref;
3996 }
3997 return 0;
3998 }
3999
4000
4001 static int
4002 resolve_omp_udr_callback2 (gfc_expr **e, int *, void *)
4003 {
4004 if ((*e)->expr_type == EXPR_FUNCTION
4005 && (*e)->value.function.isym == NULL)
4006 {
4007 gfc_symbol *sym = (*e)->symtree->n.sym;
4008 if (!sym->attr.intrinsic
4009 && sym->attr.if_source == IFSRC_UNKNOWN)
4010 gfc_error ("Implicitly declared function %s used in "
4011 "!$OMP DECLARE REDUCTION at %L", sym->name, &(*e)->where);
4012 }
4013 return 0;
4014 }
4015
4016
4017 static gfc_code *
4018 resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns,
4019 gfc_symbol *sym1, gfc_symbol *sym2)
4020 {
4021 gfc_code *copy;
4022 gfc_symbol sym1_copy, sym2_copy;
4023
4024 if (ns->code->op == EXEC_ASSIGN)
4025 {
4026 copy = gfc_get_code (EXEC_ASSIGN);
4027 copy->expr1 = gfc_copy_expr (ns->code->expr1);
4028 copy->expr2 = gfc_copy_expr (ns->code->expr2);
4029 }
4030 else
4031 {
4032 copy = gfc_get_code (EXEC_CALL);
4033 copy->symtree = ns->code->symtree;
4034 copy->ext.actual = gfc_copy_actual_arglist (ns->code->ext.actual);
4035 }
4036 copy->loc = ns->code->loc;
4037 sym1_copy = *sym1;
4038 sym2_copy = *sym2;
4039 *sym1 = *n->sym;
4040 *sym2 = *n->sym;
4041 sym1->name = sym1_copy.name;
4042 sym2->name = sym2_copy.name;
4043 ns->proc_name = ns->parent->proc_name;
4044 if (n->sym->attr.dimension)
4045 {
4046 struct resolve_omp_udr_callback_data rcd;
4047 rcd.sym1 = sym1;
4048 rcd.sym2 = sym2;
4049 gfc_code_walker (&copy, gfc_dummy_code_callback,
4050 resolve_omp_udr_callback, &rcd);
4051 }
4052 gfc_resolve_code (copy, gfc_current_ns);
4053 if (copy->op == EXEC_CALL && copy->resolved_isym == NULL)
4054 {
4055 gfc_symbol *sym = copy->resolved_sym;
4056 if (sym
4057 && !sym->attr.intrinsic
4058 && sym->attr.if_source == IFSRC_UNKNOWN)
4059 gfc_error ("Implicitly declared subroutine %s used in "
4060 "!$OMP DECLARE REDUCTION at %L", sym->name,
4061 &copy->loc);
4062 }
4063 gfc_code_walker (&copy, gfc_dummy_code_callback,
4064 resolve_omp_udr_callback2, NULL);
4065 *sym1 = sym1_copy;
4066 *sym2 = sym2_copy;
4067 return copy;
4068 }
4069
4070 /* OpenMP directive resolving routines. */
4071
4072 static void
4073 resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
4074 gfc_namespace *ns, bool openacc = false)
4075 {
4076 gfc_omp_namelist *n;
4077 gfc_expr_list *el;
4078 int list;
4079 int ifc;
4080 bool if_without_mod = false;
4081 gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
4082 static const char *clause_names[]
4083 = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
4084 "COPYIN", "UNIFORM", "ALIGNED", "LINEAR", "DEPEND", "MAP",
4085 "TO", "FROM", "REDUCTION", "DEVICE_RESIDENT", "LINK", "USE_DEVICE",
4086 "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR" };
4087
4088 if (omp_clauses == NULL)
4089 return;
4090
4091 if (omp_clauses->orderedc && omp_clauses->orderedc < omp_clauses->collapse)
4092 gfc_error ("ORDERED clause parameter is less than COLLAPSE at %L",
4093 &code->loc);
4094
4095 if (omp_clauses->if_expr)
4096 {
4097 gfc_expr *expr = omp_clauses->if_expr;
4098 if (!gfc_resolve_expr (expr)
4099 || expr->ts.type != BT_LOGICAL || expr->rank != 0)
4100 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
4101 &expr->where);
4102 if_without_mod = true;
4103 }
4104 for (ifc = 0; ifc < OMP_IF_LAST; ifc++)
4105 if (omp_clauses->if_exprs[ifc])
4106 {
4107 gfc_expr *expr = omp_clauses->if_exprs[ifc];
4108 bool ok = true;
4109 if (!gfc_resolve_expr (expr)
4110 || expr->ts.type != BT_LOGICAL || expr->rank != 0)
4111 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
4112 &expr->where);
4113 else if (if_without_mod)
4114 {
4115 gfc_error ("IF clause without modifier at %L used together with "
4116 "IF clauses with modifiers",
4117 &omp_clauses->if_expr->where);
4118 if_without_mod = false;
4119 }
4120 else
4121 switch (code->op)
4122 {
4123 case EXEC_OMP_PARALLEL:
4124 case EXEC_OMP_PARALLEL_DO:
4125 case EXEC_OMP_PARALLEL_SECTIONS:
4126 case EXEC_OMP_PARALLEL_WORKSHARE:
4127 case EXEC_OMP_PARALLEL_DO_SIMD:
4128 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
4129 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
4130 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
4131 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4132 ok = ifc == OMP_IF_PARALLEL;
4133 break;
4134
4135 case EXEC_OMP_TASK:
4136 ok = ifc == OMP_IF_TASK;
4137 break;
4138
4139 case EXEC_OMP_TASKLOOP:
4140 case EXEC_OMP_TASKLOOP_SIMD:
4141 ok = ifc == OMP_IF_TASKLOOP;
4142 break;
4143
4144 case EXEC_OMP_TARGET:
4145 case EXEC_OMP_TARGET_TEAMS:
4146 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
4147 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
4148 case EXEC_OMP_TARGET_SIMD:
4149 ok = ifc == OMP_IF_TARGET;
4150 break;
4151
4152 case EXEC_OMP_TARGET_DATA:
4153 ok = ifc == OMP_IF_TARGET_DATA;
4154 break;
4155
4156 case EXEC_OMP_TARGET_UPDATE:
4157 ok = ifc == OMP_IF_TARGET_UPDATE;
4158 break;
4159
4160 case EXEC_OMP_TARGET_ENTER_DATA:
4161 ok = ifc == OMP_IF_TARGET_ENTER_DATA;
4162 break;
4163
4164 case EXEC_OMP_TARGET_EXIT_DATA:
4165 ok = ifc == OMP_IF_TARGET_EXIT_DATA;
4166 break;
4167
4168 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
4169 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4170 case EXEC_OMP_TARGET_PARALLEL:
4171 case EXEC_OMP_TARGET_PARALLEL_DO:
4172 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
4173 ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_PARALLEL;
4174 break;
4175
4176 default:
4177 ok = false;
4178 break;
4179 }
4180 if (!ok)
4181 {
4182 static const char *ifs[] = {
4183 "PARALLEL",
4184 "TASK",
4185 "TASKLOOP",
4186 "TARGET",
4187 "TARGET DATA",
4188 "TARGET UPDATE",
4189 "TARGET ENTER DATA",
4190 "TARGET EXIT DATA"
4191 };
4192 gfc_error ("IF clause modifier %s at %L not appropriate for "
4193 "the current OpenMP construct", ifs[ifc], &expr->where);
4194 }
4195 }
4196
4197 if (omp_clauses->final_expr)
4198 {
4199 gfc_expr *expr = omp_clauses->final_expr;
4200 if (!gfc_resolve_expr (expr)
4201 || expr->ts.type != BT_LOGICAL || expr->rank != 0)
4202 gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression",
4203 &expr->where);
4204 }
4205 if (omp_clauses->num_threads)
4206 resolve_positive_int_expr (omp_clauses->num_threads, "NUM_THREADS");
4207 if (omp_clauses->chunk_size)
4208 {
4209 gfc_expr *expr = omp_clauses->chunk_size;
4210 if (!gfc_resolve_expr (expr)
4211 || expr->ts.type != BT_INTEGER || expr->rank != 0)
4212 gfc_error ("SCHEDULE clause's chunk_size at %L requires "
4213 "a scalar INTEGER expression", &expr->where);
4214 else if (expr->expr_type == EXPR_CONSTANT
4215 && expr->ts.type == BT_INTEGER
4216 && mpz_sgn (expr->value.integer) <= 0)
4217 gfc_warning (0, "INTEGER expression of SCHEDULE clause's chunk_size "
4218 "at %L must be positive", &expr->where);
4219 }
4220 if (omp_clauses->sched_kind != OMP_SCHED_NONE
4221 && omp_clauses->sched_nonmonotonic)
4222 {
4223 if (omp_clauses->sched_kind != OMP_SCHED_DYNAMIC
4224 && omp_clauses->sched_kind != OMP_SCHED_GUIDED)
4225 {
4226 const char *p;
4227 switch (omp_clauses->sched_kind)
4228 {
4229 case OMP_SCHED_STATIC: p = "STATIC"; break;
4230 case OMP_SCHED_RUNTIME: p = "RUNTIME"; break;
4231 case OMP_SCHED_AUTO: p = "AUTO"; break;
4232 default: gcc_unreachable ();
4233 }
4234 gfc_error ("NONMONOTONIC modifier specified for %s schedule kind "
4235 "at %L", p, &code->loc);
4236 }
4237 else if (omp_clauses->sched_monotonic)
4238 gfc_error ("Both MONOTONIC and NONMONOTONIC schedule modifiers "
4239 "specified at %L", &code->loc);
4240 else if (omp_clauses->ordered)
4241 gfc_error ("NONMONOTONIC schedule modifier specified with ORDERED "
4242 "clause at %L", &code->loc);
4243 }
4244
4245 /* Check that no symbol appears on multiple clauses, except that
4246 a symbol can appear on both firstprivate and lastprivate. */
4247 for (list = 0; list < OMP_LIST_NUM; list++)
4248 for (n = omp_clauses->lists[list]; n; n = n->next)
4249 {
4250 n->sym->mark = 0;
4251 n->sym->comp_mark = 0;
4252 if (n->sym->attr.flavor == FL_VARIABLE
4253 || n->sym->attr.proc_pointer
4254 || (!code && (!n->sym->attr.dummy || n->sym->ns != ns)))
4255 {
4256 if (!code && (!n->sym->attr.dummy || n->sym->ns != ns))
4257 gfc_error ("Variable %qs is not a dummy argument at %L",
4258 n->sym->name, &n->where);
4259 continue;
4260 }
4261 if (n->sym->attr.flavor == FL_PROCEDURE
4262 && n->sym->result == n->sym
4263 && n->sym->attr.function)
4264 {
4265 if (gfc_current_ns->proc_name == n->sym
4266 || (gfc_current_ns->parent
4267 && gfc_current_ns->parent->proc_name == n->sym))
4268 continue;
4269 if (gfc_current_ns->proc_name->attr.entry_master)
4270 {
4271 gfc_entry_list *el = gfc_current_ns->entries;
4272 for (; el; el = el->next)
4273 if (el->sym == n->sym)
4274 break;
4275 if (el)
4276 continue;
4277 }
4278 if (gfc_current_ns->parent
4279 && gfc_current_ns->parent->proc_name->attr.entry_master)
4280 {
4281 gfc_entry_list *el = gfc_current_ns->parent->entries;
4282 for (; el; el = el->next)
4283 if (el->sym == n->sym)
4284 break;
4285 if (el)
4286 continue;
4287 }
4288 }
4289 if (list == OMP_LIST_MAP
4290 && n->sym->attr.flavor == FL_PARAMETER)
4291 {
4292 if (openacc)
4293 gfc_error ("Object %qs is not a variable at %L; parameters"
4294 " cannot be and need not be copied", n->sym->name,
4295 &n->where);
4296 else
4297 gfc_error ("Object %qs is not a variable at %L; parameters"
4298 " cannot be and need not be mapped", n->sym->name,
4299 &n->where);
4300 }
4301 else
4302 gfc_error ("Object %qs is not a variable at %L", n->sym->name,
4303 &n->where);
4304 }
4305
4306 for (list = 0; list < OMP_LIST_NUM; list++)
4307 if (list != OMP_LIST_FIRSTPRIVATE
4308 && list != OMP_LIST_LASTPRIVATE
4309 && list != OMP_LIST_ALIGNED
4310 && list != OMP_LIST_DEPEND
4311 && (list != OMP_LIST_MAP || openacc)
4312 && list != OMP_LIST_FROM
4313 && list != OMP_LIST_TO
4314 && (list != OMP_LIST_REDUCTION || !openacc))
4315 for (n = omp_clauses->lists[list]; n; n = n->next)
4316 {
4317 bool component_ref_p = false;
4318
4319 /* Allow multiple components of the same (e.g. derived-type)
4320 variable here. Duplicate components are detected elsewhere. */
4321 if (n->expr && n->expr->expr_type == EXPR_VARIABLE)
4322 for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
4323 if (ref->type == REF_COMPONENT)
4324 component_ref_p = true;
4325 if ((!component_ref_p && n->sym->comp_mark)
4326 || (component_ref_p && n->sym->mark))
4327 gfc_error ("Symbol %qs has mixed component and non-component "
4328 "accesses at %L", n->sym->name, &n->where);
4329 else if (n->sym->mark)
4330 gfc_error ("Symbol %qs present on multiple clauses at %L",
4331 n->sym->name, &n->where);
4332 else
4333 {
4334 if (component_ref_p)
4335 n->sym->comp_mark = 1;
4336 else
4337 n->sym->mark = 1;
4338 }
4339 }
4340
4341 gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1);
4342 for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE; list++)
4343 for (n = omp_clauses->lists[list]; n; n = n->next)
4344 if (n->sym->mark)
4345 {
4346 gfc_error ("Symbol %qs present on multiple clauses at %L",
4347 n->sym->name, &n->where);
4348 n->sym->mark = 0;
4349 }
4350
4351 for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next)
4352 {
4353 if (n->sym->mark)
4354 gfc_error ("Symbol %qs present on multiple clauses at %L",
4355 n->sym->name, &n->where);
4356 else
4357 n->sym->mark = 1;
4358 }
4359 for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
4360 n->sym->mark = 0;
4361
4362 for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
4363 {
4364 if (n->sym->mark)
4365 gfc_error ("Symbol %qs present on multiple clauses at %L",
4366 n->sym->name, &n->where);
4367 else
4368 n->sym->mark = 1;
4369 }
4370
4371 for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
4372 n->sym->mark = 0;
4373
4374 for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
4375 {
4376 if (n->sym->mark)
4377 gfc_error ("Symbol %qs present on multiple clauses at %L",
4378 n->sym->name, &n->where);
4379 else
4380 n->sym->mark = 1;
4381 }
4382
4383 /* OpenACC reductions. */
4384 if (openacc)
4385 {
4386 for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next)
4387 n->sym->mark = 0;
4388
4389 for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next)
4390 {
4391 if (n->sym->mark)
4392 gfc_error ("Symbol %qs present on multiple clauses at %L",
4393 n->sym->name, &n->where);
4394 else
4395 n->sym->mark = 1;
4396
4397 /* OpenACC does not support reductions on arrays. */
4398 if (n->sym->as)
4399 gfc_error ("Array %qs is not permitted in reduction at %L",
4400 n->sym->name, &n->where);
4401 }
4402 }
4403
4404 for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
4405 n->sym->mark = 0;
4406 for (n = omp_clauses->lists[OMP_LIST_FROM]; n; n = n->next)
4407 if (n->expr == NULL)
4408 n->sym->mark = 1;
4409 for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
4410 {
4411 if (n->expr == NULL && n->sym->mark)
4412 gfc_error ("Symbol %qs present on both FROM and TO clauses at %L",
4413 n->sym->name, &n->where);
4414 else
4415 n->sym->mark = 1;
4416 }
4417
4418 for (list = 0; list < OMP_LIST_NUM; list++)
4419 if ((n = omp_clauses->lists[list]) != NULL)
4420 {
4421 const char *name;
4422
4423 if (list < OMP_LIST_NUM)
4424 name = clause_names[list];
4425 else
4426 gcc_unreachable ();
4427
4428 switch (list)
4429 {
4430 case OMP_LIST_COPYIN:
4431 for (; n != NULL; n = n->next)
4432 {
4433 if (!n->sym->attr.threadprivate)
4434 gfc_error ("Non-THREADPRIVATE object %qs in COPYIN clause"
4435 " at %L", n->sym->name, &n->where);
4436 }
4437 break;
4438 case OMP_LIST_COPYPRIVATE:
4439 for (; n != NULL; n = n->next)
4440 {
4441 if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
4442 gfc_error ("Assumed size array %qs in COPYPRIVATE clause "
4443 "at %L", n->sym->name, &n->where);
4444 if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
4445 gfc_error ("INTENT(IN) POINTER %qs in COPYPRIVATE clause "
4446 "at %L", n->sym->name, &n->where);
4447 }
4448 break;
4449 case OMP_LIST_SHARED:
4450 for (; n != NULL; n = n->next)
4451 {
4452 if (n->sym->attr.threadprivate)
4453 gfc_error ("THREADPRIVATE object %qs in SHARED clause at "
4454 "%L", n->sym->name, &n->where);
4455 if (n->sym->attr.cray_pointee)
4456 gfc_error ("Cray pointee %qs in SHARED clause at %L",
4457 n->sym->name, &n->where);
4458 if (n->sym->attr.associate_var)
4459 gfc_error ("ASSOCIATE name %qs in SHARED clause at %L",
4460 n->sym->name, &n->where);
4461 }
4462 break;
4463 case OMP_LIST_ALIGNED:
4464 for (; n != NULL; n = n->next)
4465 {
4466 if (!n->sym->attr.pointer
4467 && !n->sym->attr.allocatable
4468 && !n->sym->attr.cray_pointer
4469 && (n->sym->ts.type != BT_DERIVED
4470 || (n->sym->ts.u.derived->from_intmod
4471 != INTMOD_ISO_C_BINDING)
4472 || (n->sym->ts.u.derived->intmod_sym_id
4473 != ISOCBINDING_PTR)))
4474 gfc_error ("%qs in ALIGNED clause must be POINTER, "
4475 "ALLOCATABLE, Cray pointer or C_PTR at %L",
4476 n->sym->name, &n->where);
4477 else if (n->expr)
4478 {
4479 gfc_expr *expr = n->expr;
4480 int alignment = 0;
4481 if (!gfc_resolve_expr (expr)
4482 || expr->ts.type != BT_INTEGER
4483 || expr->rank != 0
4484 || gfc_extract_int (expr, &alignment)
4485 || alignment <= 0)
4486 gfc_error ("%qs in ALIGNED clause at %L requires a scalar "
4487 "positive constant integer alignment "
4488 "expression", n->sym->name, &n->where);
4489 }
4490 }
4491 break;
4492 case OMP_LIST_DEPEND:
4493 case OMP_LIST_MAP:
4494 case OMP_LIST_TO:
4495 case OMP_LIST_FROM:
4496 case OMP_LIST_CACHE:
4497 for (; n != NULL; n = n->next)
4498 {
4499 if (list == OMP_LIST_DEPEND)
4500 {
4501 if (n->u.depend_op == OMP_DEPEND_SINK_FIRST
4502 || n->u.depend_op == OMP_DEPEND_SINK)
4503 {
4504 if (code->op != EXEC_OMP_ORDERED)
4505 gfc_error ("SINK dependence type only allowed "
4506 "on ORDERED directive at %L", &n->where);
4507 else if (omp_clauses->depend_source)
4508 {
4509 gfc_error ("DEPEND SINK used together with "
4510 "DEPEND SOURCE on the same construct "
4511 "at %L", &n->where);
4512 omp_clauses->depend_source = false;
4513 }
4514 else if (n->expr)
4515 {
4516 if (!gfc_resolve_expr (n->expr)
4517 || n->expr->ts.type != BT_INTEGER
4518 || n->expr->rank != 0)
4519 gfc_error ("SINK addend not a constant integer "
4520 "at %L", &n->where);
4521 }
4522 continue;
4523 }
4524 else if (code->op == EXEC_OMP_ORDERED)
4525 gfc_error ("Only SOURCE or SINK dependence types "
4526 "are allowed on ORDERED directive at %L",
4527 &n->where);
4528 }
4529 gfc_ref *array_ref = NULL;
4530 bool resolved = false;
4531 if (n->expr)
4532 {
4533 array_ref = n->expr->ref;
4534 resolved = gfc_resolve_expr (n->expr);
4535
4536 /* Look through component refs to find last array
4537 reference. */
4538 if (openacc && resolved)
4539 {
4540 /* The "!$acc cache" directive allows rectangular
4541 subarrays to be specified, with some restrictions
4542 on the form of bounds (not implemented).
4543 Only raise an error here if we're really sure the
4544 array isn't contiguous. An expression such as
4545 arr(-n:n,-n:n) could be contiguous even if it looks
4546 like it may not be. */
4547 if (list != OMP_LIST_CACHE
4548 && !gfc_is_simply_contiguous (n->expr, false, true)
4549 && gfc_is_not_contiguous (n->expr))
4550 gfc_error ("Array is not contiguous at %L",
4551 &n->where);
4552
4553 while (array_ref
4554 && (array_ref->type == REF_COMPONENT
4555 || (array_ref->type == REF_ARRAY
4556 && array_ref->next
4557 && (array_ref->next->type
4558 == REF_COMPONENT))))
4559 array_ref = array_ref->next;
4560 }
4561 }
4562 if (array_ref
4563 || (n->expr
4564 && (!resolved || n->expr->expr_type != EXPR_VARIABLE)))
4565 {
4566 if (!resolved
4567 || n->expr->expr_type != EXPR_VARIABLE
4568 || array_ref->next
4569 || array_ref->type != REF_ARRAY)
4570 gfc_error ("%qs in %s clause at %L is not a proper "
4571 "array section", n->sym->name, name,
4572 &n->where);
4573 else
4574 {
4575 int i;
4576 gfc_array_ref *ar = &array_ref->u.ar;
4577 for (i = 0; i < ar->dimen; i++)
4578 if (ar->stride[i])
4579 {
4580 gfc_error ("Stride should not be specified for "
4581 "array section in %s clause at %L",
4582 name, &n->where);
4583 break;
4584 }
4585 else if (ar->dimen_type[i] != DIMEN_ELEMENT
4586 && ar->dimen_type[i] != DIMEN_RANGE)
4587 {
4588 gfc_error ("%qs in %s clause at %L is not a "
4589 "proper array section",
4590 n->sym->name, name, &n->where);
4591 break;
4592 }
4593 else if (list == OMP_LIST_DEPEND
4594 && ar->start[i]
4595 && ar->start[i]->expr_type == EXPR_CONSTANT
4596 && ar->end[i]
4597 && ar->end[i]->expr_type == EXPR_CONSTANT
4598 && mpz_cmp (ar->start[i]->value.integer,
4599 ar->end[i]->value.integer) > 0)
4600 {
4601 gfc_error ("%qs in DEPEND clause at %L is a "
4602 "zero size array section",
4603 n->sym->name, &n->where);
4604 break;
4605 }
4606 }
4607 }
4608 else if (openacc)
4609 {
4610 if (list == OMP_LIST_MAP
4611 && n->u.map_op == OMP_MAP_FORCE_DEVICEPTR)
4612 resolve_oacc_deviceptr_clause (n->sym, n->where, name);
4613 else
4614 resolve_oacc_data_clauses (n->sym, n->where, name);
4615 }
4616 else if (list != OMP_LIST_DEPEND
4617 && n->sym->as
4618 && n->sym->as->type == AS_ASSUMED_SIZE)
4619 gfc_error ("Assumed size array %qs in %s clause at %L",
4620 n->sym->name, name, &n->where);
4621 if (list == OMP_LIST_MAP && !openacc)
4622 switch (code->op)
4623 {
4624 case EXEC_OMP_TARGET:
4625 case EXEC_OMP_TARGET_DATA:
4626 switch (n->u.map_op)
4627 {
4628 case OMP_MAP_TO:
4629 case OMP_MAP_ALWAYS_TO:
4630 case OMP_MAP_FROM:
4631 case OMP_MAP_ALWAYS_FROM:
4632 case OMP_MAP_TOFROM:
4633 case OMP_MAP_ALWAYS_TOFROM:
4634 case OMP_MAP_ALLOC:
4635 break;
4636 default:
4637 gfc_error ("TARGET%s with map-type other than TO, "
4638 "FROM, TOFROM, or ALLOC on MAP clause "
4639 "at %L",
4640 code->op == EXEC_OMP_TARGET
4641 ? "" : " DATA", &n->where);
4642 break;
4643 }
4644 break;
4645 case EXEC_OMP_TARGET_ENTER_DATA:
4646 switch (n->u.map_op)
4647 {
4648 case OMP_MAP_TO:
4649 case OMP_MAP_ALWAYS_TO:
4650 case OMP_MAP_ALLOC:
4651 break;
4652 default:
4653 gfc_error ("TARGET ENTER DATA with map-type other "
4654 "than TO, or ALLOC on MAP clause at %L",
4655 &n->where);
4656 break;
4657 }
4658 break;
4659 case EXEC_OMP_TARGET_EXIT_DATA:
4660 switch (n->u.map_op)
4661 {
4662 case OMP_MAP_FROM:
4663 case OMP_MAP_ALWAYS_FROM:
4664 case OMP_MAP_RELEASE:
4665 case OMP_MAP_DELETE:
4666 break;
4667 default:
4668 gfc_error ("TARGET EXIT DATA with map-type other "
4669 "than FROM, RELEASE, or DELETE on MAP "
4670 "clause at %L", &n->where);
4671 break;
4672 }
4673 break;
4674 default:
4675 break;
4676 }
4677 }
4678
4679 if (list != OMP_LIST_DEPEND)
4680 for (n = omp_clauses->lists[list]; n != NULL; n = n->next)
4681 {
4682 n->sym->attr.referenced = 1;
4683 if (n->sym->attr.threadprivate)
4684 gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
4685 n->sym->name, name, &n->where);
4686 if (n->sym->attr.cray_pointee)
4687 gfc_error ("Cray pointee %qs in %s clause at %L",
4688 n->sym->name, name, &n->where);
4689 }
4690 break;
4691 case OMP_LIST_IS_DEVICE_PTR:
4692 if (!n->sym->attr.dummy)
4693 gfc_error ("Non-dummy object %qs in %s clause at %L",
4694 n->sym->name, name, &n->where);
4695 if (n->sym->attr.allocatable
4696 || (n->sym->ts.type == BT_CLASS
4697 && CLASS_DATA (n->sym)->attr.allocatable))
4698 gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
4699 n->sym->name, name, &n->where);
4700 if (n->sym->attr.pointer
4701 || (n->sym->ts.type == BT_CLASS
4702 && CLASS_DATA (n->sym)->attr.pointer))
4703 gfc_error ("POINTER object %qs in %s clause at %L",
4704 n->sym->name, name, &n->where);
4705 if (n->sym->attr.value)
4706 gfc_error ("VALUE object %qs in %s clause at %L",
4707 n->sym->name, name, &n->where);
4708 break;
4709 case OMP_LIST_USE_DEVICE_PTR:
4710 case OMP_LIST_USE_DEVICE_ADDR:
4711 /* FIXME: Handle OMP_LIST_USE_DEVICE_PTR. */
4712 break;
4713 default:
4714 for (; n != NULL; n = n->next)
4715 {
4716 bool bad = false;
4717 if (n->sym->attr.threadprivate)
4718 gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
4719 n->sym->name, name, &n->where);
4720 if (n->sym->attr.cray_pointee)
4721 gfc_error ("Cray pointee %qs in %s clause at %L",
4722 n->sym->name, name, &n->where);
4723 if (n->sym->attr.associate_var)
4724 gfc_error ("ASSOCIATE name %qs in %s clause at %L",
4725 n->sym->name, name, &n->where);
4726 if (list != OMP_LIST_PRIVATE)
4727 {
4728 if (n->sym->attr.proc_pointer && list == OMP_LIST_REDUCTION)
4729 gfc_error ("Procedure pointer %qs in %s clause at %L",
4730 n->sym->name, name, &n->where);
4731 if (n->sym->attr.pointer && list == OMP_LIST_REDUCTION)
4732 gfc_error ("POINTER object %qs in %s clause at %L",
4733 n->sym->name, name, &n->where);
4734 if (n->sym->attr.cray_pointer && list == OMP_LIST_REDUCTION)
4735 gfc_error ("Cray pointer %qs in %s clause at %L",
4736 n->sym->name, name, &n->where);
4737 }
4738 if (code
4739 && (oacc_is_loop (code)
4740 || code->op == EXEC_OACC_PARALLEL
4741 || code->op == EXEC_OACC_SERIAL))
4742 check_array_not_assumed (n->sym, n->where, name);
4743 else if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
4744 gfc_error ("Assumed size array %qs in %s clause at %L",
4745 n->sym->name, name, &n->where);
4746 if (n->sym->attr.in_namelist && list != OMP_LIST_REDUCTION)
4747 gfc_error ("Variable %qs in %s clause is used in "
4748 "NAMELIST statement at %L",
4749 n->sym->name, name, &n->where);
4750 if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
4751 switch (list)
4752 {
4753 case OMP_LIST_PRIVATE:
4754 case OMP_LIST_LASTPRIVATE:
4755 case OMP_LIST_LINEAR:
4756 /* case OMP_LIST_REDUCTION: */
4757 gfc_error ("INTENT(IN) POINTER %qs in %s clause at %L",
4758 n->sym->name, name, &n->where);
4759 break;
4760 default:
4761 break;
4762 }
4763
4764 switch (list)
4765 {
4766 case OMP_LIST_REDUCTION:
4767 switch (n->u.reduction_op)
4768 {
4769 case OMP_REDUCTION_PLUS:
4770 case OMP_REDUCTION_TIMES:
4771 case OMP_REDUCTION_MINUS:
4772 if (!gfc_numeric_ts (&n->sym->ts))
4773 bad = true;
4774 break;
4775 case OMP_REDUCTION_AND:
4776 case OMP_REDUCTION_OR:
4777 case OMP_REDUCTION_EQV:
4778 case OMP_REDUCTION_NEQV:
4779 if (n->sym->ts.type != BT_LOGICAL)
4780 bad = true;
4781 break;
4782 case OMP_REDUCTION_MAX:
4783 case OMP_REDUCTION_MIN:
4784 if (n->sym->ts.type != BT_INTEGER
4785 && n->sym->ts.type != BT_REAL)
4786 bad = true;
4787 break;
4788 case OMP_REDUCTION_IAND:
4789 case OMP_REDUCTION_IOR:
4790 case OMP_REDUCTION_IEOR:
4791 if (n->sym->ts.type != BT_INTEGER)
4792 bad = true;
4793 break;
4794 case OMP_REDUCTION_USER:
4795 bad = true;
4796 break;
4797 default:
4798 break;
4799 }
4800 if (!bad)
4801 n->udr = NULL;
4802 else
4803 {
4804 const char *udr_name = NULL;
4805 if (n->udr)
4806 {
4807 udr_name = n->udr->udr->name;
4808 n->udr->udr
4809 = gfc_find_omp_udr (NULL, udr_name,
4810 &n->sym->ts);
4811 if (n->udr->udr == NULL)
4812 {
4813 free (n->udr);
4814 n->udr = NULL;
4815 }
4816 }
4817 if (n->udr == NULL)
4818 {
4819 if (udr_name == NULL)
4820 switch (n->u.reduction_op)
4821 {
4822 case OMP_REDUCTION_PLUS:
4823 case OMP_REDUCTION_TIMES:
4824 case OMP_REDUCTION_MINUS:
4825 case OMP_REDUCTION_AND:
4826 case OMP_REDUCTION_OR:
4827 case OMP_REDUCTION_EQV:
4828 case OMP_REDUCTION_NEQV:
4829 udr_name = gfc_op2string ((gfc_intrinsic_op)
4830 n->u.reduction_op);
4831 break;
4832 case OMP_REDUCTION_MAX:
4833 udr_name = "max";
4834 break;
4835 case OMP_REDUCTION_MIN:
4836 udr_name = "min";
4837 break;
4838 case OMP_REDUCTION_IAND:
4839 udr_name = "iand";
4840 break;
4841 case OMP_REDUCTION_IOR:
4842 udr_name = "ior";
4843 break;
4844 case OMP_REDUCTION_IEOR:
4845 udr_name = "ieor";
4846 break;
4847 default:
4848 gcc_unreachable ();
4849 }
4850 gfc_error ("!$OMP DECLARE REDUCTION %s not found "
4851 "for type %s at %L", udr_name,
4852 gfc_typename (&n->sym->ts), &n->where);
4853 }
4854 else
4855 {
4856 gfc_omp_udr *udr = n->udr->udr;
4857 n->u.reduction_op = OMP_REDUCTION_USER;
4858 n->udr->combiner
4859 = resolve_omp_udr_clause (n, udr->combiner_ns,
4860 udr->omp_out,
4861 udr->omp_in);
4862 if (udr->initializer_ns)
4863 n->udr->initializer
4864 = resolve_omp_udr_clause (n,
4865 udr->initializer_ns,
4866 udr->omp_priv,
4867 udr->omp_orig);
4868 }
4869 }
4870 break;
4871 case OMP_LIST_LINEAR:
4872 if (code
4873 && n->u.linear_op != OMP_LINEAR_DEFAULT
4874 && n->u.linear_op != linear_op)
4875 {
4876 gfc_error ("LINEAR clause modifier used on DO or SIMD"
4877 " construct at %L", &n->where);
4878 linear_op = n->u.linear_op;
4879 }
4880 else if (omp_clauses->orderedc)
4881 gfc_error ("LINEAR clause specified together with "
4882 "ORDERED clause with argument at %L",
4883 &n->where);
4884 else if (n->u.linear_op != OMP_LINEAR_REF
4885 && n->sym->ts.type != BT_INTEGER)
4886 gfc_error ("LINEAR variable %qs must be INTEGER "
4887 "at %L", n->sym->name, &n->where);
4888 else if ((n->u.linear_op == OMP_LINEAR_REF
4889 || n->u.linear_op == OMP_LINEAR_UVAL)
4890 && n->sym->attr.value)
4891 gfc_error ("LINEAR dummy argument %qs with VALUE "
4892 "attribute with %s modifier at %L",
4893 n->sym->name,
4894 n->u.linear_op == OMP_LINEAR_REF
4895 ? "REF" : "UVAL", &n->where);
4896 else if (n->expr)
4897 {
4898 gfc_expr *expr = n->expr;
4899 if (!gfc_resolve_expr (expr)
4900 || expr->ts.type != BT_INTEGER
4901 || expr->rank != 0)
4902 gfc_error ("%qs in LINEAR clause at %L requires "
4903 "a scalar integer linear-step expression",
4904 n->sym->name, &n->where);
4905 else if (!code && expr->expr_type != EXPR_CONSTANT)
4906 {
4907 if (expr->expr_type == EXPR_VARIABLE
4908 && expr->symtree->n.sym->attr.dummy
4909 && expr->symtree->n.sym->ns == ns)
4910 {
4911 gfc_omp_namelist *n2;
4912 for (n2 = omp_clauses->lists[OMP_LIST_UNIFORM];
4913 n2; n2 = n2->next)
4914 if (n2->sym == expr->symtree->n.sym)
4915 break;
4916 if (n2)
4917 break;
4918 }
4919 gfc_error ("%qs in LINEAR clause at %L requires "
4920 "a constant integer linear-step "
4921 "expression or dummy argument "
4922 "specified in UNIFORM clause",
4923 n->sym->name, &n->where);
4924 }
4925 }
4926 break;
4927 /* Workaround for PR middle-end/26316, nothing really needs
4928 to be done here for OMP_LIST_PRIVATE. */
4929 case OMP_LIST_PRIVATE:
4930 gcc_assert (code && code->op != EXEC_NOP);
4931 break;
4932 case OMP_LIST_USE_DEVICE:
4933 if (n->sym->attr.allocatable
4934 || (n->sym->ts.type == BT_CLASS && CLASS_DATA (n->sym)
4935 && CLASS_DATA (n->sym)->attr.allocatable))
4936 gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
4937 n->sym->name, name, &n->where);
4938 if (n->sym->ts.type == BT_CLASS
4939 && CLASS_DATA (n->sym)
4940 && CLASS_DATA (n->sym)->attr.class_pointer)
4941 gfc_error ("POINTER object %qs of polymorphic type in "
4942 "%s clause at %L", n->sym->name, name,
4943 &n->where);
4944 if (n->sym->attr.cray_pointer)
4945 gfc_error ("Cray pointer object %qs in %s clause at %L",
4946 n->sym->name, name, &n->where);
4947 else if (n->sym->attr.cray_pointee)
4948 gfc_error ("Cray pointee object %qs in %s clause at %L",
4949 n->sym->name, name, &n->where);
4950 else if (n->sym->attr.flavor == FL_VARIABLE
4951 && !n->sym->as
4952 && !n->sym->attr.pointer)
4953 gfc_error ("%s clause variable %qs at %L is neither "
4954 "a POINTER nor an array", name,
4955 n->sym->name, &n->where);
4956 /* FALLTHRU */
4957 case OMP_LIST_DEVICE_RESIDENT:
4958 check_symbol_not_pointer (n->sym, n->where, name);
4959 check_array_not_assumed (n->sym, n->where, name);
4960 break;
4961 default:
4962 break;
4963 }
4964 }
4965 break;
4966 }
4967 }
4968 if (omp_clauses->safelen_expr)
4969 resolve_positive_int_expr (omp_clauses->safelen_expr, "SAFELEN");
4970 if (omp_clauses->simdlen_expr)
4971 resolve_positive_int_expr (omp_clauses->simdlen_expr, "SIMDLEN");
4972 if (omp_clauses->num_teams)
4973 resolve_positive_int_expr (omp_clauses->num_teams, "NUM_TEAMS");
4974 if (omp_clauses->device)
4975 resolve_nonnegative_int_expr (omp_clauses->device, "DEVICE");
4976 if (omp_clauses->hint)
4977 resolve_scalar_int_expr (omp_clauses->hint, "HINT");
4978 if (omp_clauses->priority)
4979 resolve_nonnegative_int_expr (omp_clauses->priority, "PRIORITY");
4980 if (omp_clauses->dist_chunk_size)
4981 {
4982 gfc_expr *expr = omp_clauses->dist_chunk_size;
4983 if (!gfc_resolve_expr (expr)
4984 || expr->ts.type != BT_INTEGER || expr->rank != 0)
4985 gfc_error ("DIST_SCHEDULE clause's chunk_size at %L requires "
4986 "a scalar INTEGER expression", &expr->where);
4987 }
4988 if (omp_clauses->thread_limit)
4989 resolve_positive_int_expr (omp_clauses->thread_limit, "THREAD_LIMIT");
4990 if (omp_clauses->grainsize)
4991 resolve_positive_int_expr (omp_clauses->grainsize, "GRAINSIZE");
4992 if (omp_clauses->num_tasks)
4993 resolve_positive_int_expr (omp_clauses->num_tasks, "NUM_TASKS");
4994 if (omp_clauses->async)
4995 if (omp_clauses->async_expr)
4996 resolve_scalar_int_expr (omp_clauses->async_expr, "ASYNC");
4997 if (omp_clauses->num_gangs_expr)
4998 resolve_positive_int_expr (omp_clauses->num_gangs_expr, "NUM_GANGS");
4999 if (omp_clauses->num_workers_expr)
5000 resolve_positive_int_expr (omp_clauses->num_workers_expr, "NUM_WORKERS");
5001 if (omp_clauses->vector_length_expr)
5002 resolve_positive_int_expr (omp_clauses->vector_length_expr,
5003 "VECTOR_LENGTH");
5004 if (omp_clauses->gang_num_expr)
5005 resolve_positive_int_expr (omp_clauses->gang_num_expr, "GANG");
5006 if (omp_clauses->gang_static_expr)
5007 resolve_positive_int_expr (omp_clauses->gang_static_expr, "GANG");
5008 if (omp_clauses->worker_expr)
5009 resolve_positive_int_expr (omp_clauses->worker_expr, "WORKER");
5010 if (omp_clauses->vector_expr)
5011 resolve_positive_int_expr (omp_clauses->vector_expr, "VECTOR");
5012 for (el = omp_clauses->wait_list; el; el = el->next)
5013 resolve_scalar_int_expr (el->expr, "WAIT");
5014 if (omp_clauses->collapse && omp_clauses->tile_list)
5015 gfc_error ("Incompatible use of TILE and COLLAPSE at %L", &code->loc);
5016 if (omp_clauses->depend_source && code->op != EXEC_OMP_ORDERED)
5017 gfc_error ("SOURCE dependence type only allowed "
5018 "on ORDERED directive at %L", &code->loc);
5019 if (!openacc && code && omp_clauses->lists[OMP_LIST_MAP] == NULL)
5020 {
5021 const char *p = NULL;
5022 switch (code->op)
5023 {
5024 case EXEC_OMP_TARGET_DATA: p = "TARGET DATA"; break;
5025 case EXEC_OMP_TARGET_ENTER_DATA: p = "TARGET ENTER DATA"; break;
5026 case EXEC_OMP_TARGET_EXIT_DATA: p = "TARGET EXIT DATA"; break;
5027 default: break;
5028 }
5029 if (p)
5030 gfc_error ("%s must contain at least one MAP clause at %L",
5031 p, &code->loc);
5032 }
5033 }
5034
5035
5036 /* Return true if SYM is ever referenced in EXPR except in the SE node. */
5037
5038 static bool
5039 expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
5040 {
5041 gfc_actual_arglist *arg;
5042 if (e == NULL || e == se)
5043 return false;
5044 switch (e->expr_type)
5045 {
5046 case EXPR_CONSTANT:
5047 case EXPR_NULL:
5048 case EXPR_VARIABLE:
5049 case EXPR_STRUCTURE:
5050 case EXPR_ARRAY:
5051 if (e->symtree != NULL
5052 && e->symtree->n.sym == s)
5053 return true;
5054 return false;
5055 case EXPR_SUBSTRING:
5056 if (e->ref != NULL
5057 && (expr_references_sym (e->ref->u.ss.start, s, se)
5058 || expr_references_sym (e->ref->u.ss.end, s, se)))
5059 return true;
5060 return false;
5061 case EXPR_OP:
5062 if (expr_references_sym (e->value.op.op2, s, se))
5063 return true;
5064 return expr_references_sym (e->value.op.op1, s, se);
5065 case EXPR_FUNCTION:
5066 for (arg = e->value.function.actual; arg; arg = arg->next)
5067 if (expr_references_sym (arg->expr, s, se))
5068 return true;
5069 return false;
5070 default:
5071 gcc_unreachable ();
5072 }
5073 }
5074
5075
5076 /* If EXPR is a conversion function that widens the type
5077 if WIDENING is true or narrows the type if WIDENING is false,
5078 return the inner expression, otherwise return NULL. */
5079
5080 static gfc_expr *
5081 is_conversion (gfc_expr *expr, bool widening)
5082 {
5083 gfc_typespec *ts1, *ts2;
5084
5085 if (expr->expr_type != EXPR_FUNCTION
5086 || expr->value.function.isym == NULL
5087 || expr->value.function.esym != NULL
5088 || expr->value.function.isym->id != GFC_ISYM_CONVERSION)
5089 return NULL;
5090
5091 if (widening)
5092 {
5093 ts1 = &expr->ts;
5094 ts2 = &expr->value.function.actual->expr->ts;
5095 }
5096 else
5097 {
5098 ts1 = &expr->value.function.actual->expr->ts;
5099 ts2 = &expr->ts;
5100 }
5101
5102 if (ts1->type > ts2->type
5103 || (ts1->type == ts2->type && ts1->kind > ts2->kind))
5104 return expr->value.function.actual->expr;
5105
5106 return NULL;
5107 }
5108
5109
5110 static void
5111 resolve_omp_atomic (gfc_code *code)
5112 {
5113 gfc_code *atomic_code = code;
5114 gfc_symbol *var;
5115 gfc_expr *expr2, *expr2_tmp;
5116 gfc_omp_atomic_op aop
5117 = (gfc_omp_atomic_op) (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK);
5118
5119 code = code->block->next;
5120 /* resolve_blocks asserts this is initially EXEC_ASSIGN.
5121 If it changed to EXEC_NOP, assume an error has been emitted already. */
5122 if (code->op == EXEC_NOP)
5123 return;
5124 if (code->op != EXEC_ASSIGN)
5125 {
5126 unexpected:
5127 gfc_error ("unexpected !$OMP ATOMIC expression at %L", &code->loc);
5128 return;
5129 }
5130 if (aop != GFC_OMP_ATOMIC_CAPTURE)
5131 {
5132 if (code->next != NULL)
5133 goto unexpected;
5134 }
5135 else
5136 {
5137 if (code->next == NULL)
5138 goto unexpected;
5139 if (code->next->op == EXEC_NOP)
5140 return;
5141 if (code->next->op != EXEC_ASSIGN || code->next->next)
5142 {
5143 code = code->next;
5144 goto unexpected;
5145 }
5146 }
5147
5148 if (code->expr1->expr_type != EXPR_VARIABLE
5149 || code->expr1->symtree == NULL
5150 || code->expr1->rank != 0
5151 || (code->expr1->ts.type != BT_INTEGER
5152 && code->expr1->ts.type != BT_REAL
5153 && code->expr1->ts.type != BT_COMPLEX
5154 && code->expr1->ts.type != BT_LOGICAL))
5155 {
5156 gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
5157 "intrinsic type at %L", &code->loc);
5158 return;
5159 }
5160
5161 var = code->expr1->symtree->n.sym;
5162 expr2 = is_conversion (code->expr2, false);
5163 if (expr2 == NULL)
5164 {
5165 if (aop == GFC_OMP_ATOMIC_READ || aop == GFC_OMP_ATOMIC_WRITE)
5166 expr2 = is_conversion (code->expr2, true);
5167 if (expr2 == NULL)
5168 expr2 = code->expr2;
5169 }
5170
5171 switch (aop)
5172 {
5173 case GFC_OMP_ATOMIC_READ:
5174 if (expr2->expr_type != EXPR_VARIABLE
5175 || expr2->symtree == NULL
5176 || expr2->rank != 0
5177 || (expr2->ts.type != BT_INTEGER
5178 && expr2->ts.type != BT_REAL
5179 && expr2->ts.type != BT_COMPLEX
5180 && expr2->ts.type != BT_LOGICAL))
5181 gfc_error ("!$OMP ATOMIC READ statement must read from a scalar "
5182 "variable of intrinsic type at %L", &expr2->where);
5183 return;
5184 case GFC_OMP_ATOMIC_WRITE:
5185 if (expr2->rank != 0 || expr_references_sym (code->expr2, var, NULL))
5186 gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr "
5187 "must be scalar and cannot reference var at %L",
5188 &expr2->where);
5189 return;
5190 case GFC_OMP_ATOMIC_CAPTURE:
5191 expr2_tmp = expr2;
5192 if (expr2 == code->expr2)
5193 {
5194 expr2_tmp = is_conversion (code->expr2, true);
5195 if (expr2_tmp == NULL)
5196 expr2_tmp = expr2;
5197 }
5198 if (expr2_tmp->expr_type == EXPR_VARIABLE)
5199 {
5200 if (expr2_tmp->symtree == NULL
5201 || expr2_tmp->rank != 0
5202 || (expr2_tmp->ts.type != BT_INTEGER
5203 && expr2_tmp->ts.type != BT_REAL
5204 && expr2_tmp->ts.type != BT_COMPLEX
5205 && expr2_tmp->ts.type != BT_LOGICAL)
5206 || expr2_tmp->symtree->n.sym == var)
5207 {
5208 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read from "
5209 "a scalar variable of intrinsic type at %L",
5210 &expr2_tmp->where);
5211 return;
5212 }
5213 var = expr2_tmp->symtree->n.sym;
5214 code = code->next;
5215 if (code->expr1->expr_type != EXPR_VARIABLE
5216 || code->expr1->symtree == NULL
5217 || code->expr1->rank != 0
5218 || (code->expr1->ts.type != BT_INTEGER
5219 && code->expr1->ts.type != BT_REAL
5220 && code->expr1->ts.type != BT_COMPLEX
5221 && code->expr1->ts.type != BT_LOGICAL))
5222 {
5223 gfc_error ("!$OMP ATOMIC CAPTURE update statement must set "
5224 "a scalar variable of intrinsic type at %L",
5225 &code->expr1->where);
5226 return;
5227 }
5228 if (code->expr1->symtree->n.sym != var)
5229 {
5230 gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
5231 "different variable than update statement writes "
5232 "into at %L", &code->expr1->where);
5233 return;
5234 }
5235 expr2 = is_conversion (code->expr2, false);
5236 if (expr2 == NULL)
5237 expr2 = code->expr2;
5238 }
5239 break;
5240 default:
5241 break;
5242 }
5243
5244 if (gfc_expr_attr (code->expr1).allocatable)
5245 {
5246 gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L",
5247 &code->loc);
5248 return;
5249 }
5250
5251 if (aop == GFC_OMP_ATOMIC_CAPTURE
5252 && code->next == NULL
5253 && code->expr2->rank == 0
5254 && !expr_references_sym (code->expr2, var, NULL))
5255 atomic_code->ext.omp_atomic
5256 = (gfc_omp_atomic_op) (atomic_code->ext.omp_atomic
5257 | GFC_OMP_ATOMIC_SWAP);
5258 else if (expr2->expr_type == EXPR_OP)
5259 {
5260 gfc_expr *v = NULL, *e, *c;
5261 gfc_intrinsic_op op = expr2->value.op.op;
5262 gfc_intrinsic_op alt_op = INTRINSIC_NONE;
5263
5264 switch (op)
5265 {
5266 case INTRINSIC_PLUS:
5267 alt_op = INTRINSIC_MINUS;
5268 break;
5269 case INTRINSIC_TIMES:
5270 alt_op = INTRINSIC_DIVIDE;
5271 break;
5272 case INTRINSIC_MINUS:
5273 alt_op = INTRINSIC_PLUS;
5274 break;
5275 case INTRINSIC_DIVIDE:
5276 alt_op = INTRINSIC_TIMES;
5277 break;
5278 case INTRINSIC_AND:
5279 case INTRINSIC_OR:
5280 break;
5281 case INTRINSIC_EQV:
5282 alt_op = INTRINSIC_NEQV;
5283 break;
5284 case INTRINSIC_NEQV:
5285 alt_op = INTRINSIC_EQV;
5286 break;
5287 default:
5288 gfc_error ("!$OMP ATOMIC assignment operator must be binary "
5289 "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
5290 &expr2->where);
5291 return;
5292 }
5293
5294 /* Check for var = var op expr resp. var = expr op var where
5295 expr doesn't reference var and var op expr is mathematically
5296 equivalent to var op (expr) resp. expr op var equivalent to
5297 (expr) op var. We rely here on the fact that the matcher
5298 for x op1 y op2 z where op1 and op2 have equal precedence
5299 returns (x op1 y) op2 z. */
5300 e = expr2->value.op.op2;
5301 if (e->expr_type == EXPR_VARIABLE
5302 && e->symtree != NULL
5303 && e->symtree->n.sym == var)
5304 v = e;
5305 else if ((c = is_conversion (e, true)) != NULL
5306 && c->expr_type == EXPR_VARIABLE
5307 && c->symtree != NULL
5308 && c->symtree->n.sym == var)
5309 v = c;
5310 else
5311 {
5312 gfc_expr **p = NULL, **q;
5313 for (q = &expr2->value.op.op1; (e = *q) != NULL; )
5314 if (e->expr_type == EXPR_VARIABLE
5315 && e->symtree != NULL
5316 && e->symtree->n.sym == var)
5317 {
5318 v = e;
5319 break;
5320 }
5321 else if ((c = is_conversion (e, true)) != NULL)
5322 q = &e->value.function.actual->expr;
5323 else if (e->expr_type != EXPR_OP
5324 || (e->value.op.op != op
5325 && e->value.op.op != alt_op)
5326 || e->rank != 0)
5327 break;
5328 else
5329 {
5330 p = q;
5331 q = &e->value.op.op1;
5332 }
5333
5334 if (v == NULL)
5335 {
5336 gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
5337 "or var = expr op var at %L", &expr2->where);
5338 return;
5339 }
5340
5341 if (p != NULL)
5342 {
5343 e = *p;
5344 switch (e->value.op.op)
5345 {
5346 case INTRINSIC_MINUS:
5347 case INTRINSIC_DIVIDE:
5348 case INTRINSIC_EQV:
5349 case INTRINSIC_NEQV:
5350 gfc_error ("!$OMP ATOMIC var = var op expr not "
5351 "mathematically equivalent to var = var op "
5352 "(expr) at %L", &expr2->where);
5353 break;
5354 default:
5355 break;
5356 }
5357
5358 /* Canonicalize into var = var op (expr). */
5359 *p = e->value.op.op2;
5360 e->value.op.op2 = expr2;
5361 e->ts = expr2->ts;
5362 if (code->expr2 == expr2)
5363 code->expr2 = expr2 = e;
5364 else
5365 code->expr2->value.function.actual->expr = expr2 = e;
5366
5367 if (!gfc_compare_types (&expr2->value.op.op1->ts, &expr2->ts))
5368 {
5369 for (p = &expr2->value.op.op1; *p != v;
5370 p = &(*p)->value.function.actual->expr)
5371 ;
5372 *p = NULL;
5373 gfc_free_expr (expr2->value.op.op1);
5374 expr2->value.op.op1 = v;
5375 gfc_convert_type (v, &expr2->ts, 2);
5376 }
5377 }
5378 }
5379
5380 if (e->rank != 0 || expr_references_sym (code->expr2, var, v))
5381 {
5382 gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
5383 "must be scalar and cannot reference var at %L",
5384 &expr2->where);
5385 return;
5386 }
5387 }
5388 else if (expr2->expr_type == EXPR_FUNCTION
5389 && expr2->value.function.isym != NULL
5390 && expr2->value.function.esym == NULL
5391 && expr2->value.function.actual != NULL
5392 && expr2->value.function.actual->next != NULL)
5393 {
5394 gfc_actual_arglist *arg, *var_arg;
5395
5396 switch (expr2->value.function.isym->id)
5397 {
5398 case GFC_ISYM_MIN:
5399 case GFC_ISYM_MAX:
5400 break;
5401 case GFC_ISYM_IAND:
5402 case GFC_ISYM_IOR:
5403 case GFC_ISYM_IEOR:
5404 if (expr2->value.function.actual->next->next != NULL)
5405 {
5406 gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
5407 "or IEOR must have two arguments at %L",
5408 &expr2->where);
5409 return;
5410 }
5411 break;
5412 default:
5413 gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
5414 "MIN, MAX, IAND, IOR or IEOR at %L",
5415 &expr2->where);
5416 return;
5417 }
5418
5419 var_arg = NULL;
5420 for (arg = expr2->value.function.actual; arg; arg = arg->next)
5421 {
5422 if ((arg == expr2->value.function.actual
5423 || (var_arg == NULL && arg->next == NULL))
5424 && arg->expr->expr_type == EXPR_VARIABLE
5425 && arg->expr->symtree != NULL
5426 && arg->expr->symtree->n.sym == var)
5427 var_arg = arg;
5428 else if (expr_references_sym (arg->expr, var, NULL))
5429 {
5430 gfc_error ("!$OMP ATOMIC intrinsic arguments except one must "
5431 "not reference %qs at %L",
5432 var->name, &arg->expr->where);
5433 return;
5434 }
5435 if (arg->expr->rank != 0)
5436 {
5437 gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
5438 "at %L", &arg->expr->where);
5439 return;
5440 }
5441 }
5442
5443 if (var_arg == NULL)
5444 {
5445 gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
5446 "be %qs at %L", var->name, &expr2->where);
5447 return;
5448 }
5449
5450 if (var_arg != expr2->value.function.actual)
5451 {
5452 /* Canonicalize, so that var comes first. */
5453 gcc_assert (var_arg->next == NULL);
5454 for (arg = expr2->value.function.actual;
5455 arg->next != var_arg; arg = arg->next)
5456 ;
5457 var_arg->next = expr2->value.function.actual;
5458 expr2->value.function.actual = var_arg;
5459 arg->next = NULL;
5460 }
5461 }
5462 else
5463 gfc_error ("!$OMP ATOMIC assignment must have an operator or "
5464 "intrinsic on right hand side at %L", &expr2->where);
5465
5466 if (aop == GFC_OMP_ATOMIC_CAPTURE && code->next)
5467 {
5468 code = code->next;
5469 if (code->expr1->expr_type != EXPR_VARIABLE
5470 || code->expr1->symtree == NULL
5471 || code->expr1->rank != 0
5472 || (code->expr1->ts.type != BT_INTEGER
5473 && code->expr1->ts.type != BT_REAL
5474 && code->expr1->ts.type != BT_COMPLEX
5475 && code->expr1->ts.type != BT_LOGICAL))
5476 {
5477 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must set "
5478 "a scalar variable of intrinsic type at %L",
5479 &code->expr1->where);
5480 return;
5481 }
5482
5483 expr2 = is_conversion (code->expr2, false);
5484 if (expr2 == NULL)
5485 {
5486 expr2 = is_conversion (code->expr2, true);
5487 if (expr2 == NULL)
5488 expr2 = code->expr2;
5489 }
5490
5491 if (expr2->expr_type != EXPR_VARIABLE
5492 || expr2->symtree == NULL
5493 || expr2->rank != 0
5494 || (expr2->ts.type != BT_INTEGER
5495 && expr2->ts.type != BT_REAL
5496 && expr2->ts.type != BT_COMPLEX
5497 && expr2->ts.type != BT_LOGICAL))
5498 {
5499 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read "
5500 "from a scalar variable of intrinsic type at %L",
5501 &expr2->where);
5502 return;
5503 }
5504 if (expr2->symtree->n.sym != var)
5505 {
5506 gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
5507 "different variable than update statement writes "
5508 "into at %L", &expr2->where);
5509 return;
5510 }
5511 }
5512 }
5513
5514
5515 static struct fortran_omp_context
5516 {
5517 gfc_code *code;
5518 hash_set<gfc_symbol *> *sharing_clauses;
5519 hash_set<gfc_symbol *> *private_iterators;
5520 struct fortran_omp_context *previous;
5521 bool is_openmp;
5522 } *omp_current_ctx;
5523 static gfc_code *omp_current_do_code;
5524 static int omp_current_do_collapse;
5525
5526 void
5527 gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
5528 {
5529 if (code->block->next && code->block->next->op == EXEC_DO)
5530 {
5531 int i;
5532 gfc_code *c;
5533
5534 omp_current_do_code = code->block->next;
5535 if (code->ext.omp_clauses->orderedc)
5536 omp_current_do_collapse = code->ext.omp_clauses->orderedc;
5537 else
5538 omp_current_do_collapse = code->ext.omp_clauses->collapse;
5539 for (i = 1, c = omp_current_do_code; i < omp_current_do_collapse; i++)
5540 {
5541 c = c->block;
5542 if (c->op != EXEC_DO || c->next == NULL)
5543 break;
5544 c = c->next;
5545 if (c->op != EXEC_DO)
5546 break;
5547 }
5548 if (i < omp_current_do_collapse || omp_current_do_collapse <= 0)
5549 omp_current_do_collapse = 1;
5550 }
5551 gfc_resolve_blocks (code->block, ns);
5552 omp_current_do_collapse = 0;
5553 omp_current_do_code = NULL;
5554 }
5555
5556
5557 void
5558 gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
5559 {
5560 struct fortran_omp_context ctx;
5561 gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
5562 gfc_omp_namelist *n;
5563 int list;
5564
5565 ctx.code = code;
5566 ctx.sharing_clauses = new hash_set<gfc_symbol *>;
5567 ctx.private_iterators = new hash_set<gfc_symbol *>;
5568 ctx.previous = omp_current_ctx;
5569 ctx.is_openmp = true;
5570 omp_current_ctx = &ctx;
5571
5572 for (list = 0; list < OMP_LIST_NUM; list++)
5573 switch (list)
5574 {
5575 case OMP_LIST_SHARED:
5576 case OMP_LIST_PRIVATE:
5577 case OMP_LIST_FIRSTPRIVATE:
5578 case OMP_LIST_LASTPRIVATE:
5579 case OMP_LIST_REDUCTION:
5580 case OMP_LIST_LINEAR:
5581 for (n = omp_clauses->lists[list]; n; n = n->next)
5582 ctx.sharing_clauses->add (n->sym);
5583 break;
5584 default:
5585 break;
5586 }
5587
5588 switch (code->op)
5589 {
5590 case EXEC_OMP_PARALLEL_DO:
5591 case EXEC_OMP_PARALLEL_DO_SIMD:
5592 case EXEC_OMP_TARGET_PARALLEL_DO:
5593 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
5594 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
5595 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
5596 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5597 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
5598 case EXEC_OMP_TASKLOOP:
5599 case EXEC_OMP_TASKLOOP_SIMD:
5600 case EXEC_OMP_TEAMS_DISTRIBUTE:
5601 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
5602 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5603 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
5604 gfc_resolve_omp_do_blocks (code, ns);
5605 break;
5606 default:
5607 gfc_resolve_blocks (code->block, ns);
5608 }
5609
5610 omp_current_ctx = ctx.previous;
5611 delete ctx.sharing_clauses;
5612 delete ctx.private_iterators;
5613 }
5614
5615
5616 /* Save and clear openmp.c private state. */
5617
5618 void
5619 gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *state)
5620 {
5621 state->ptrs[0] = omp_current_ctx;
5622 state->ptrs[1] = omp_current_do_code;
5623 state->ints[0] = omp_current_do_collapse;
5624 omp_current_ctx = NULL;
5625 omp_current_do_code = NULL;
5626 omp_current_do_collapse = 0;
5627 }
5628
5629
5630 /* Restore openmp.c private state from the saved state. */
5631
5632 void
5633 gfc_omp_restore_state (struct gfc_omp_saved_state *state)
5634 {
5635 omp_current_ctx = (struct fortran_omp_context *) state->ptrs[0];
5636 omp_current_do_code = (gfc_code *) state->ptrs[1];
5637 omp_current_do_collapse = state->ints[0];
5638 }
5639
5640
5641 /* Note a DO iterator variable. This is special in !$omp parallel
5642 construct, where they are predetermined private. */
5643
5644 void
5645 gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym, bool add_clause)
5646 {
5647 if (omp_current_ctx == NULL)
5648 return;
5649
5650 int i = omp_current_do_collapse;
5651 gfc_code *c = omp_current_do_code;
5652
5653 if (sym->attr.threadprivate)
5654 return;
5655
5656 /* !$omp do and !$omp parallel do iteration variable is predetermined
5657 private just in the !$omp do resp. !$omp parallel do construct,
5658 with no implications for the outer parallel constructs. */
5659
5660 while (i-- >= 1)
5661 {
5662 if (code == c)
5663 return;
5664
5665 c = c->block->next;
5666 }
5667
5668 /* An openacc context may represent a data clause. Abort if so. */
5669 if (!omp_current_ctx->is_openmp && !oacc_is_loop (omp_current_ctx->code))
5670 return;
5671
5672 if (omp_current_ctx->sharing_clauses->contains (sym))
5673 return;
5674
5675 if (! omp_current_ctx->private_iterators->add (sym) && add_clause)
5676 {
5677 gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses;
5678 gfc_omp_namelist *p;
5679
5680 p = gfc_get_omp_namelist ();
5681 p->sym = sym;
5682 p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
5683 omp_clauses->lists[OMP_LIST_PRIVATE] = p;
5684 }
5685 }
5686
5687 static void
5688 handle_local_var (gfc_symbol *sym)
5689 {
5690 if (sym->attr.flavor != FL_VARIABLE
5691 || sym->as != NULL
5692 || (sym->ts.type != BT_INTEGER && sym->ts.type != BT_REAL))
5693 return;
5694 gfc_resolve_do_iterator (sym->ns->code, sym, false);
5695 }
5696
5697 void
5698 gfc_resolve_omp_local_vars (gfc_namespace *ns)
5699 {
5700 if (omp_current_ctx)
5701 gfc_traverse_ns (ns, handle_local_var);
5702 }
5703
5704 static void
5705 resolve_omp_do (gfc_code *code)
5706 {
5707 gfc_code *do_code, *c;
5708 int list, i, collapse;
5709 gfc_omp_namelist *n;
5710 gfc_symbol *dovar;
5711 const char *name;
5712 bool is_simd = false;
5713
5714 switch (code->op)
5715 {
5716 case EXEC_OMP_DISTRIBUTE: name = "!$OMP DISTRIBUTE"; break;
5717 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
5718 name = "!$OMP DISTRIBUTE PARALLEL DO";
5719 break;
5720 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
5721 name = "!$OMP DISTRIBUTE PARALLEL DO SIMD";
5722 is_simd = true;
5723 break;
5724 case EXEC_OMP_DISTRIBUTE_SIMD:
5725 name = "!$OMP DISTRIBUTE SIMD";
5726 is_simd = true;
5727 break;
5728 case EXEC_OMP_DO: name = "!$OMP DO"; break;
5729 case EXEC_OMP_DO_SIMD: name = "!$OMP DO SIMD"; is_simd = true; break;
5730 case EXEC_OMP_PARALLEL_DO: name = "!$OMP PARALLEL DO"; break;
5731 case EXEC_OMP_PARALLEL_DO_SIMD:
5732 name = "!$OMP PARALLEL DO SIMD";
5733 is_simd = true;
5734 break;
5735 case EXEC_OMP_SIMD: name = "!$OMP SIMD"; is_simd = true; break;
5736 case EXEC_OMP_TARGET_PARALLEL_DO: name = "!$OMP TARGET PARALLEL DO"; break;
5737 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
5738 name = "!$OMP TARGET PARALLEL DO SIMD";
5739 is_simd = true;
5740 break;
5741 case EXEC_OMP_TARGET_SIMD:
5742 name = "!$OMP TARGET SIMD";
5743 is_simd = true;
5744 break;
5745 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
5746 name = "!$OMP TARGET TEAMS DISTRIBUTE";
5747 break;
5748 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
5749 name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
5750 break;
5751 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5752 name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
5753 is_simd = true;
5754 break;
5755 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
5756 name = "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
5757 is_simd = true;
5758 break;
5759 case EXEC_OMP_TASKLOOP: name = "!$OMP TASKLOOP"; break;
5760 case EXEC_OMP_TASKLOOP_SIMD:
5761 name = "!$OMP TASKLOOP SIMD";
5762 is_simd = true;
5763 break;
5764 case EXEC_OMP_TEAMS_DISTRIBUTE: name = "!$OMP TEAMS DISTRIBUTE"; break;
5765 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
5766 name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
5767 break;
5768 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5769 name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
5770 is_simd = true;
5771 break;
5772 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
5773 name = "!$OMP TEAMS DISTRIBUTE SIMD";
5774 is_simd = true;
5775 break;
5776 default: gcc_unreachable ();
5777 }
5778
5779 if (code->ext.omp_clauses)
5780 resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
5781
5782 do_code = code->block->next;
5783 if (code->ext.omp_clauses->orderedc)
5784 collapse = code->ext.omp_clauses->orderedc;
5785 else
5786 {
5787 collapse = code->ext.omp_clauses->collapse;
5788 if (collapse <= 0)
5789 collapse = 1;
5790 }
5791 for (i = 1; i <= collapse; i++)
5792 {
5793 if (do_code->op == EXEC_DO_WHILE)
5794 {
5795 gfc_error ("%s cannot be a DO WHILE or DO without loop control "
5796 "at %L", name, &do_code->loc);
5797 break;
5798 }
5799 if (do_code->op == EXEC_DO_CONCURRENT)
5800 {
5801 gfc_error ("%s cannot be a DO CONCURRENT loop at %L", name,
5802 &do_code->loc);
5803 break;
5804 }
5805 gcc_assert (do_code->op == EXEC_DO);
5806 if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
5807 gfc_error ("%s iteration variable must be of type integer at %L",
5808 name, &do_code->loc);
5809 dovar = do_code->ext.iterator->var->symtree->n.sym;
5810 if (dovar->attr.threadprivate)
5811 gfc_error ("%s iteration variable must not be THREADPRIVATE "
5812 "at %L", name, &do_code->loc);
5813 if (code->ext.omp_clauses)
5814 for (list = 0; list < OMP_LIST_NUM; list++)
5815 if (!is_simd
5816 ? (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE)
5817 : code->ext.omp_clauses->collapse > 1
5818 ? (list != OMP_LIST_LASTPRIVATE)
5819 : (list != OMP_LIST_LINEAR))
5820 for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
5821 if (dovar == n->sym)
5822 {
5823 if (!is_simd)
5824 gfc_error ("%s iteration variable present on clause "
5825 "other than PRIVATE or LASTPRIVATE at %L",
5826 name, &do_code->loc);
5827 else if (code->ext.omp_clauses->collapse > 1)
5828 gfc_error ("%s iteration variable present on clause "
5829 "other than LASTPRIVATE at %L",
5830 name, &do_code->loc);
5831 else
5832 gfc_error ("%s iteration variable present on clause "
5833 "other than LINEAR at %L",
5834 name, &do_code->loc);
5835 break;
5836 }
5837 if (i > 1)
5838 {
5839 gfc_code *do_code2 = code->block->next;
5840 int j;
5841
5842 for (j = 1; j < i; j++)
5843 {
5844 gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
5845 if (dovar == ivar
5846 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
5847 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
5848 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
5849 {
5850 gfc_error ("%s collapsed loops don't form rectangular "
5851 "iteration space at %L", name, &do_code->loc);
5852 break;
5853 }
5854 do_code2 = do_code2->block->next;
5855 }
5856 }
5857 if (i == collapse)
5858 break;
5859 for (c = do_code->next; c; c = c->next)
5860 if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
5861 {
5862 gfc_error ("collapsed %s loops not perfectly nested at %L",
5863 name, &c->loc);
5864 break;
5865 }
5866 if (c)
5867 break;
5868 do_code = do_code->block;
5869 if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE)
5870 {
5871 gfc_error ("not enough DO loops for collapsed %s at %L",
5872 name, &code->loc);
5873 break;
5874 }
5875 do_code = do_code->next;
5876 if (do_code == NULL
5877 || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE))
5878 {
5879 gfc_error ("not enough DO loops for collapsed %s at %L",
5880 name, &code->loc);
5881 break;
5882 }
5883 }
5884 }
5885
5886 static bool
5887 oacc_is_parallel (gfc_code *code)
5888 {
5889 return code->op == EXEC_OACC_PARALLEL || code->op == EXEC_OACC_PARALLEL_LOOP;
5890 }
5891
5892 static gfc_statement
5893 omp_code_to_statement (gfc_code *code)
5894 {
5895 switch (code->op)
5896 {
5897 case EXEC_OMP_PARALLEL:
5898 return ST_OMP_PARALLEL;
5899 case EXEC_OMP_PARALLEL_SECTIONS:
5900 return ST_OMP_PARALLEL_SECTIONS;
5901 case EXEC_OMP_SECTIONS:
5902 return ST_OMP_SECTIONS;
5903 case EXEC_OMP_ORDERED:
5904 return ST_OMP_ORDERED;
5905 case EXEC_OMP_CRITICAL:
5906 return ST_OMP_CRITICAL;
5907 case EXEC_OMP_MASTER:
5908 return ST_OMP_MASTER;
5909 case EXEC_OMP_SINGLE:
5910 return ST_OMP_SINGLE;
5911 case EXEC_OMP_TASK:
5912 return ST_OMP_TASK;
5913 case EXEC_OMP_WORKSHARE:
5914 return ST_OMP_WORKSHARE;
5915 case EXEC_OMP_PARALLEL_WORKSHARE:
5916 return ST_OMP_PARALLEL_WORKSHARE;
5917 case EXEC_OMP_DO:
5918 return ST_OMP_DO;
5919 case EXEC_OMP_ATOMIC:
5920 return ST_OMP_ATOMIC;
5921 case EXEC_OMP_BARRIER:
5922 return ST_OMP_BARRIER;
5923 case EXEC_OMP_CANCEL:
5924 return ST_OMP_CANCEL;
5925 case EXEC_OMP_CANCELLATION_POINT:
5926 return ST_OMP_CANCELLATION_POINT;
5927 case EXEC_OMP_FLUSH:
5928 return ST_OMP_FLUSH;
5929 case EXEC_OMP_DISTRIBUTE:
5930 return ST_OMP_DISTRIBUTE;
5931 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
5932 return ST_OMP_DISTRIBUTE_PARALLEL_DO;
5933 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
5934 return ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD;
5935 case EXEC_OMP_DISTRIBUTE_SIMD:
5936 return ST_OMP_DISTRIBUTE_SIMD;
5937 case EXEC_OMP_DO_SIMD:
5938 return ST_OMP_DO_SIMD;
5939 case EXEC_OMP_SIMD:
5940 return ST_OMP_SIMD;
5941 case EXEC_OMP_TARGET:
5942 return ST_OMP_TARGET;
5943 case EXEC_OMP_TARGET_DATA:
5944 return ST_OMP_TARGET_DATA;
5945 case EXEC_OMP_TARGET_ENTER_DATA:
5946 return ST_OMP_TARGET_ENTER_DATA;
5947 case EXEC_OMP_TARGET_EXIT_DATA:
5948 return ST_OMP_TARGET_EXIT_DATA;
5949 case EXEC_OMP_TARGET_PARALLEL:
5950 return ST_OMP_TARGET_PARALLEL;
5951 case EXEC_OMP_TARGET_PARALLEL_DO:
5952 return ST_OMP_TARGET_PARALLEL_DO;
5953 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
5954 return ST_OMP_TARGET_PARALLEL_DO_SIMD;
5955 case EXEC_OMP_TARGET_SIMD:
5956 return ST_OMP_TARGET_SIMD;
5957 case EXEC_OMP_TARGET_TEAMS:
5958 return ST_OMP_TARGET_TEAMS;
5959 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
5960 return ST_OMP_TARGET_TEAMS_DISTRIBUTE;
5961 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
5962 return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
5963 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5964 return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
5965 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
5966 return ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD;
5967 case EXEC_OMP_TARGET_UPDATE:
5968 return ST_OMP_TARGET_UPDATE;
5969 case EXEC_OMP_TASKGROUP:
5970 return ST_OMP_TASKGROUP;
5971 case EXEC_OMP_TASKLOOP:
5972 return ST_OMP_TASKLOOP;
5973 case EXEC_OMP_TASKLOOP_SIMD:
5974 return ST_OMP_TASKLOOP_SIMD;
5975 case EXEC_OMP_TASKWAIT:
5976 return ST_OMP_TASKWAIT;
5977 case EXEC_OMP_TASKYIELD:
5978 return ST_OMP_TASKYIELD;
5979 case EXEC_OMP_TEAMS:
5980 return ST_OMP_TEAMS;
5981 case EXEC_OMP_TEAMS_DISTRIBUTE:
5982 return ST_OMP_TEAMS_DISTRIBUTE;
5983 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
5984 return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO;
5985 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5986 return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
5987 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
5988 return ST_OMP_TEAMS_DISTRIBUTE_SIMD;
5989 case EXEC_OMP_PARALLEL_DO:
5990 return ST_OMP_PARALLEL_DO;
5991 case EXEC_OMP_PARALLEL_DO_SIMD:
5992 return ST_OMP_PARALLEL_DO_SIMD;
5993
5994 default:
5995 gcc_unreachable ();
5996 }
5997 }
5998
5999 static gfc_statement
6000 oacc_code_to_statement (gfc_code *code)
6001 {
6002 switch (code->op)
6003 {
6004 case EXEC_OACC_PARALLEL:
6005 return ST_OACC_PARALLEL;
6006 case EXEC_OACC_KERNELS:
6007 return ST_OACC_KERNELS;
6008 case EXEC_OACC_SERIAL:
6009 return ST_OACC_SERIAL;
6010 case EXEC_OACC_DATA:
6011 return ST_OACC_DATA;
6012 case EXEC_OACC_HOST_DATA:
6013 return ST_OACC_HOST_DATA;
6014 case EXEC_OACC_PARALLEL_LOOP:
6015 return ST_OACC_PARALLEL_LOOP;
6016 case EXEC_OACC_KERNELS_LOOP:
6017 return ST_OACC_KERNELS_LOOP;
6018 case EXEC_OACC_SERIAL_LOOP:
6019 return ST_OACC_SERIAL_LOOP;
6020 case EXEC_OACC_LOOP:
6021 return ST_OACC_LOOP;
6022 case EXEC_OACC_ATOMIC:
6023 return ST_OACC_ATOMIC;
6024 case EXEC_OACC_ROUTINE:
6025 return ST_OACC_ROUTINE;
6026 case EXEC_OACC_UPDATE:
6027 return ST_OACC_UPDATE;
6028 case EXEC_OACC_WAIT:
6029 return ST_OACC_WAIT;
6030 case EXEC_OACC_CACHE:
6031 return ST_OACC_CACHE;
6032 case EXEC_OACC_ENTER_DATA:
6033 return ST_OACC_ENTER_DATA;
6034 case EXEC_OACC_EXIT_DATA:
6035 return ST_OACC_EXIT_DATA;
6036 case EXEC_OACC_DECLARE:
6037 return ST_OACC_DECLARE;
6038 default:
6039 gcc_unreachable ();
6040 }
6041 }
6042
6043 static void
6044 resolve_oacc_directive_inside_omp_region (gfc_code *code)
6045 {
6046 if (omp_current_ctx != NULL && omp_current_ctx->is_openmp)
6047 {
6048 gfc_statement st = omp_code_to_statement (omp_current_ctx->code);
6049 gfc_statement oacc_st = oacc_code_to_statement (code);
6050 gfc_error ("The %s directive cannot be specified within "
6051 "a %s region at %L", gfc_ascii_statement (oacc_st),
6052 gfc_ascii_statement (st), &code->loc);
6053 }
6054 }
6055
6056 static void
6057 resolve_omp_directive_inside_oacc_region (gfc_code *code)
6058 {
6059 if (omp_current_ctx != NULL && !omp_current_ctx->is_openmp)
6060 {
6061 gfc_statement st = oacc_code_to_statement (omp_current_ctx->code);
6062 gfc_statement omp_st = omp_code_to_statement (code);
6063 gfc_error ("The %s directive cannot be specified within "
6064 "a %s region at %L", gfc_ascii_statement (omp_st),
6065 gfc_ascii_statement (st), &code->loc);
6066 }
6067 }
6068
6069
6070 static void
6071 resolve_oacc_nested_loops (gfc_code *code, gfc_code* do_code, int collapse,
6072 const char *clause)
6073 {
6074 gfc_symbol *dovar;
6075 gfc_code *c;
6076 int i;
6077
6078 for (i = 1; i <= collapse; i++)
6079 {
6080 if (do_code->op == EXEC_DO_WHILE)
6081 {
6082 gfc_error ("!$ACC LOOP cannot be a DO WHILE or DO without loop control "
6083 "at %L", &do_code->loc);
6084 break;
6085 }
6086 if (do_code->op == EXEC_DO_CONCURRENT)
6087 {
6088 gfc_error ("!$ACC LOOP cannot be a DO CONCURRENT loop at %L",
6089 &do_code->loc);
6090 break;
6091 }
6092 gcc_assert (do_code->op == EXEC_DO);
6093 if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
6094 gfc_error ("!$ACC LOOP iteration variable must be of type integer at %L",
6095 &do_code->loc);
6096 dovar = do_code->ext.iterator->var->symtree->n.sym;
6097 if (i > 1)
6098 {
6099 gfc_code *do_code2 = code->block->next;
6100 int j;
6101
6102 for (j = 1; j < i; j++)
6103 {
6104 gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
6105 if (dovar == ivar
6106 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
6107 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
6108 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
6109 {
6110 gfc_error ("!$ACC LOOP %s loops don't form rectangular "
6111 "iteration space at %L", clause, &do_code->loc);
6112 break;
6113 }
6114 do_code2 = do_code2->block->next;
6115 }
6116 }
6117 if (i == collapse)
6118 break;
6119 for (c = do_code->next; c; c = c->next)
6120 if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
6121 {
6122 gfc_error ("%s !$ACC LOOP loops not perfectly nested at %L",
6123 clause, &c->loc);
6124 break;
6125 }
6126 if (c)
6127 break;
6128 do_code = do_code->block;
6129 if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
6130 && do_code->op != EXEC_DO_CONCURRENT)
6131 {
6132 gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
6133 clause, &code->loc);
6134 break;
6135 }
6136 do_code = do_code->next;
6137 if (do_code == NULL
6138 || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
6139 && do_code->op != EXEC_DO_CONCURRENT))
6140 {
6141 gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
6142 clause, &code->loc);
6143 break;
6144 }
6145 }
6146 }
6147
6148
6149 static void
6150 resolve_oacc_params_in_parallel (gfc_code *code, const char *clause,
6151 const char *arg)
6152 {
6153 fortran_omp_context *c;
6154
6155 if (oacc_is_parallel (code))
6156 gfc_error ("!$ACC LOOP %s in PARALLEL region doesn't allow "
6157 "%s arguments at %L", clause, arg, &code->loc);
6158 for (c = omp_current_ctx; c; c = c->previous)
6159 {
6160 if (oacc_is_loop (c->code))
6161 break;
6162 if (oacc_is_parallel (c->code))
6163 gfc_error ("!$ACC LOOP %s in PARALLEL region doesn't allow "
6164 "%s arguments at %L", clause, arg, &code->loc);
6165 }
6166 }
6167
6168
6169 static void
6170 resolve_oacc_loop_blocks (gfc_code *code)
6171 {
6172 if (!oacc_is_loop (code))
6173 return;
6174
6175 if (code->ext.omp_clauses->tile_list && code->ext.omp_clauses->gang
6176 && code->ext.omp_clauses->worker && code->ext.omp_clauses->vector)
6177 gfc_error ("Tiled loop cannot be parallelized across gangs, workers and "
6178 "vectors at the same time at %L", &code->loc);
6179
6180 if (code->ext.omp_clauses->gang
6181 && code->ext.omp_clauses->gang_num_expr)
6182 resolve_oacc_params_in_parallel (code, "GANG", "num");
6183
6184 if (code->ext.omp_clauses->worker
6185 && code->ext.omp_clauses->worker_expr)
6186 resolve_oacc_params_in_parallel (code, "WORKER", "num");
6187
6188 if (code->ext.omp_clauses->vector
6189 && code->ext.omp_clauses->vector_expr)
6190 resolve_oacc_params_in_parallel (code, "VECTOR", "length");
6191
6192 if (code->ext.omp_clauses->tile_list)
6193 {
6194 gfc_expr_list *el;
6195 for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
6196 {
6197 if (el->expr == NULL)
6198 {
6199 /* NULL expressions are used to represent '*' arguments.
6200 Convert those to a 0 expressions. */
6201 el->expr = gfc_get_constant_expr (BT_INTEGER,
6202 gfc_default_integer_kind,
6203 &code->loc);
6204 mpz_set_si (el->expr->value.integer, 0);
6205 }
6206 else
6207 {
6208 resolve_positive_int_expr (el->expr, "TILE");
6209 if (el->expr->expr_type != EXPR_CONSTANT)
6210 gfc_error ("TILE requires constant expression at %L",
6211 &code->loc);
6212 }
6213 }
6214 }
6215 }
6216
6217
6218 void
6219 gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns)
6220 {
6221 fortran_omp_context ctx;
6222 gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
6223 gfc_omp_namelist *n;
6224 int list;
6225
6226 resolve_oacc_loop_blocks (code);
6227
6228 ctx.code = code;
6229 ctx.sharing_clauses = new hash_set<gfc_symbol *>;
6230 ctx.private_iterators = new hash_set<gfc_symbol *>;
6231 ctx.previous = omp_current_ctx;
6232 ctx.is_openmp = false;
6233 omp_current_ctx = &ctx;
6234
6235 for (list = 0; list < OMP_LIST_NUM; list++)
6236 switch (list)
6237 {
6238 case OMP_LIST_PRIVATE:
6239 for (n = omp_clauses->lists[list]; n; n = n->next)
6240 ctx.sharing_clauses->add (n->sym);
6241 break;
6242 default:
6243 break;
6244 }
6245
6246 gfc_resolve_blocks (code->block, ns);
6247
6248 omp_current_ctx = ctx.previous;
6249 delete ctx.sharing_clauses;
6250 delete ctx.private_iterators;
6251 }
6252
6253
6254 static void
6255 resolve_oacc_loop (gfc_code *code)
6256 {
6257 gfc_code *do_code;
6258 int collapse;
6259
6260 if (code->ext.omp_clauses)
6261 resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
6262
6263 do_code = code->block->next;
6264 collapse = code->ext.omp_clauses->collapse;
6265
6266 /* Both collapsed and tiled loops are lowered the same way, but are not
6267 compatible. In gfc_trans_omp_do, the tile is prioritized. */
6268 if (code->ext.omp_clauses->tile_list)
6269 {
6270 int num = 0;
6271 gfc_expr_list *el;
6272 for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
6273 ++num;
6274 resolve_oacc_nested_loops (code, code->block->next, num, "tiled");
6275 return;
6276 }
6277
6278 if (collapse <= 0)
6279 collapse = 1;
6280 resolve_oacc_nested_loops (code, do_code, collapse, "collapsed");
6281 }
6282
6283 void
6284 gfc_resolve_oacc_declare (gfc_namespace *ns)
6285 {
6286 int list;
6287 gfc_omp_namelist *n;
6288 gfc_oacc_declare *oc;
6289
6290 if (ns->oacc_declare == NULL)
6291 return;
6292
6293 for (oc = ns->oacc_declare; oc; oc = oc->next)
6294 {
6295 for (list = 0; list < OMP_LIST_NUM; list++)
6296 for (n = oc->clauses->lists[list]; n; n = n->next)
6297 {
6298 n->sym->mark = 0;
6299 if (n->sym->attr.flavor != FL_VARIABLE
6300 && (n->sym->attr.flavor != FL_PROCEDURE
6301 || n->sym->result != n->sym))
6302 {
6303 gfc_error ("Object %qs is not a variable at %L",
6304 n->sym->name, &oc->loc);
6305 continue;
6306 }
6307
6308 if (n->expr && n->expr->ref->type == REF_ARRAY)
6309 {
6310 gfc_error ("Array sections: %qs not allowed in"
6311 " !$ACC DECLARE at %L", n->sym->name, &oc->loc);
6312 continue;
6313 }
6314 }
6315
6316 for (n = oc->clauses->lists[OMP_LIST_DEVICE_RESIDENT]; n; n = n->next)
6317 check_array_not_assumed (n->sym, oc->loc, "DEVICE_RESIDENT");
6318 }
6319
6320 for (oc = ns->oacc_declare; oc; oc = oc->next)
6321 {
6322 for (list = 0; list < OMP_LIST_NUM; list++)
6323 for (n = oc->clauses->lists[list]; n; n = n->next)
6324 {
6325 if (n->sym->mark)
6326 {
6327 gfc_error ("Symbol %qs present on multiple clauses at %L",
6328 n->sym->name, &oc->loc);
6329 continue;
6330 }
6331 else
6332 n->sym->mark = 1;
6333 }
6334 }
6335
6336 for (oc = ns->oacc_declare; oc; oc = oc->next)
6337 {
6338 for (list = 0; list < OMP_LIST_NUM; list++)
6339 for (n = oc->clauses->lists[list]; n; n = n->next)
6340 n->sym->mark = 0;
6341 }
6342 }
6343
6344
6345 void
6346 gfc_resolve_oacc_routines (gfc_namespace *ns)
6347 {
6348 for (gfc_oacc_routine_name *orn = ns->oacc_routine_names;
6349 orn;
6350 orn = orn->next)
6351 {
6352 gfc_symbol *sym = orn->sym;
6353 if (!sym->attr.external
6354 && !sym->attr.function
6355 && !sym->attr.subroutine)
6356 {
6357 gfc_error ("NAME %qs does not refer to a subroutine or function"
6358 " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
6359 continue;
6360 }
6361 if (!gfc_add_omp_declare_target (&sym->attr, sym->name, &orn->loc))
6362 {
6363 gfc_error ("NAME %qs invalid"
6364 " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
6365 continue;
6366 }
6367 }
6368 }
6369
6370
6371 void
6372 gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
6373 {
6374 resolve_oacc_directive_inside_omp_region (code);
6375
6376 switch (code->op)
6377 {
6378 case EXEC_OACC_PARALLEL:
6379 case EXEC_OACC_KERNELS:
6380 case EXEC_OACC_SERIAL:
6381 case EXEC_OACC_DATA:
6382 case EXEC_OACC_HOST_DATA:
6383 case EXEC_OACC_UPDATE:
6384 case EXEC_OACC_ENTER_DATA:
6385 case EXEC_OACC_EXIT_DATA:
6386 case EXEC_OACC_WAIT:
6387 case EXEC_OACC_CACHE:
6388 resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
6389 break;
6390 case EXEC_OACC_PARALLEL_LOOP:
6391 case EXEC_OACC_KERNELS_LOOP:
6392 case EXEC_OACC_SERIAL_LOOP:
6393 case EXEC_OACC_LOOP:
6394 resolve_oacc_loop (code);
6395 break;
6396 case EXEC_OACC_ATOMIC:
6397 resolve_omp_atomic (code);
6398 break;
6399 default:
6400 break;
6401 }
6402 }
6403
6404
6405 /* Resolve OpenMP directive clauses and check various requirements
6406 of each directive. */
6407
6408 void
6409 gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
6410 {
6411 resolve_omp_directive_inside_oacc_region (code);
6412
6413 if (code->op != EXEC_OMP_ATOMIC)
6414 gfc_maybe_initialize_eh ();
6415
6416 switch (code->op)
6417 {
6418 case EXEC_OMP_DISTRIBUTE:
6419 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
6420 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
6421 case EXEC_OMP_DISTRIBUTE_SIMD:
6422 case EXEC_OMP_DO:
6423 case EXEC_OMP_DO_SIMD:
6424 case EXEC_OMP_PARALLEL_DO:
6425 case EXEC_OMP_PARALLEL_DO_SIMD:
6426 case EXEC_OMP_SIMD:
6427 case EXEC_OMP_TARGET_PARALLEL_DO:
6428 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
6429 case EXEC_OMP_TARGET_SIMD:
6430 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
6431 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
6432 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
6433 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
6434 case EXEC_OMP_TASKLOOP:
6435 case EXEC_OMP_TASKLOOP_SIMD:
6436 case EXEC_OMP_TEAMS_DISTRIBUTE:
6437 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
6438 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
6439 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
6440 resolve_omp_do (code);
6441 break;
6442 case EXEC_OMP_CANCEL:
6443 case EXEC_OMP_PARALLEL_WORKSHARE:
6444 case EXEC_OMP_PARALLEL:
6445 case EXEC_OMP_PARALLEL_SECTIONS:
6446 case EXEC_OMP_SECTIONS:
6447 case EXEC_OMP_SINGLE:
6448 case EXEC_OMP_TARGET:
6449 case EXEC_OMP_TARGET_DATA:
6450 case EXEC_OMP_TARGET_ENTER_DATA:
6451 case EXEC_OMP_TARGET_EXIT_DATA:
6452 case EXEC_OMP_TARGET_PARALLEL:
6453 case EXEC_OMP_TARGET_TEAMS:
6454 case EXEC_OMP_TASK:
6455 case EXEC_OMP_TEAMS:
6456 case EXEC_OMP_WORKSHARE:
6457 if (code->ext.omp_clauses)
6458 resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
6459 break;
6460 case EXEC_OMP_TARGET_UPDATE:
6461 if (code->ext.omp_clauses)
6462 resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
6463 if (code->ext.omp_clauses == NULL
6464 || (code->ext.omp_clauses->lists[OMP_LIST_TO] == NULL
6465 && code->ext.omp_clauses->lists[OMP_LIST_FROM] == NULL))
6466 gfc_error ("OMP TARGET UPDATE at %L requires at least one TO or "
6467 "FROM clause", &code->loc);
6468 break;
6469 case EXEC_OMP_ATOMIC:
6470 resolve_omp_atomic (code);
6471 break;
6472 default:
6473 break;
6474 }
6475 }
6476
6477 /* Resolve !$omp declare simd constructs in NS. */
6478
6479 void
6480 gfc_resolve_omp_declare_simd (gfc_namespace *ns)
6481 {
6482 gfc_omp_declare_simd *ods;
6483
6484 for (ods = ns->omp_declare_simd; ods; ods = ods->next)
6485 {
6486 if (ods->proc_name != NULL
6487 && ods->proc_name != ns->proc_name)
6488 gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure "
6489 "%qs at %L", ns->proc_name->name, &ods->where);
6490 if (ods->clauses)
6491 resolve_omp_clauses (NULL, ods->clauses, ns);
6492 }
6493 }
6494
6495 struct omp_udr_callback_data
6496 {
6497 gfc_omp_udr *omp_udr;
6498 bool is_initializer;
6499 };
6500
6501 static int
6502 omp_udr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
6503 void *data)
6504 {
6505 struct omp_udr_callback_data *cd = (struct omp_udr_callback_data *) data;
6506 if ((*e)->expr_type == EXPR_VARIABLE)
6507 {
6508 if (cd->is_initializer)
6509 {
6510 if ((*e)->symtree->n.sym != cd->omp_udr->omp_priv
6511 && (*e)->symtree->n.sym != cd->omp_udr->omp_orig)
6512 gfc_error ("Variable other than OMP_PRIV or OMP_ORIG used in "
6513 "INITIALIZER clause of !$OMP DECLARE REDUCTION at %L",
6514 &(*e)->where);
6515 }
6516 else
6517 {
6518 if ((*e)->symtree->n.sym != cd->omp_udr->omp_out
6519 && (*e)->symtree->n.sym != cd->omp_udr->omp_in)
6520 gfc_error ("Variable other than OMP_OUT or OMP_IN used in "
6521 "combiner of !$OMP DECLARE REDUCTION at %L",
6522 &(*e)->where);
6523 }
6524 }
6525 return 0;
6526 }
6527
6528 /* Resolve !$omp declare reduction constructs. */
6529
6530 static void
6531 gfc_resolve_omp_udr (gfc_omp_udr *omp_udr)
6532 {
6533 gfc_actual_arglist *a;
6534 const char *predef_name = NULL;
6535
6536 switch (omp_udr->rop)
6537 {
6538 case OMP_REDUCTION_PLUS:
6539 case OMP_REDUCTION_TIMES:
6540 case OMP_REDUCTION_MINUS:
6541 case OMP_REDUCTION_AND:
6542 case OMP_REDUCTION_OR:
6543 case OMP_REDUCTION_EQV:
6544 case OMP_REDUCTION_NEQV:
6545 case OMP_REDUCTION_MAX:
6546 case OMP_REDUCTION_USER:
6547 break;
6548 default:
6549 gfc_error ("Invalid operator for !$OMP DECLARE REDUCTION %s at %L",
6550 omp_udr->name, &omp_udr->where);
6551 return;
6552 }
6553
6554 if (gfc_omp_udr_predef (omp_udr->rop, omp_udr->name,
6555 &omp_udr->ts, &predef_name))
6556 {
6557 if (predef_name)
6558 gfc_error_now ("Redefinition of predefined %s "
6559 "!$OMP DECLARE REDUCTION at %L",
6560 predef_name, &omp_udr->where);
6561 else
6562 gfc_error_now ("Redefinition of predefined "
6563 "!$OMP DECLARE REDUCTION at %L", &omp_udr->where);
6564 return;
6565 }
6566
6567 if (omp_udr->ts.type == BT_CHARACTER
6568 && omp_udr->ts.u.cl->length
6569 && omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
6570 {
6571 gfc_error ("CHARACTER length in !$OMP DECLARE REDUCTION %s not "
6572 "constant at %L", omp_udr->name, &omp_udr->where);
6573 return;
6574 }
6575
6576 struct omp_udr_callback_data cd;
6577 cd.omp_udr = omp_udr;
6578 cd.is_initializer = false;
6579 gfc_code_walker (&omp_udr->combiner_ns->code, gfc_dummy_code_callback,
6580 omp_udr_callback, &cd);
6581 if (omp_udr->combiner_ns->code->op == EXEC_CALL)
6582 {
6583 for (a = omp_udr->combiner_ns->code->ext.actual; a; a = a->next)
6584 if (a->expr == NULL)
6585 break;
6586 if (a)
6587 gfc_error ("Subroutine call with alternate returns in combiner "
6588 "of !$OMP DECLARE REDUCTION at %L",
6589 &omp_udr->combiner_ns->code->loc);
6590 }
6591 if (omp_udr->initializer_ns)
6592 {
6593 cd.is_initializer = true;
6594 gfc_code_walker (&omp_udr->initializer_ns->code, gfc_dummy_code_callback,
6595 omp_udr_callback, &cd);
6596 if (omp_udr->initializer_ns->code->op == EXEC_CALL)
6597 {
6598 for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
6599 if (a->expr == NULL)
6600 break;
6601 if (a)
6602 gfc_error ("Subroutine call with alternate returns in "
6603 "INITIALIZER clause of !$OMP DECLARE REDUCTION "
6604 "at %L", &omp_udr->initializer_ns->code->loc);
6605 for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
6606 if (a->expr
6607 && a->expr->expr_type == EXPR_VARIABLE
6608 && a->expr->symtree->n.sym == omp_udr->omp_priv
6609 && a->expr->ref == NULL)
6610 break;
6611 if (a == NULL)
6612 gfc_error ("One of actual subroutine arguments in INITIALIZER "
6613 "clause of !$OMP DECLARE REDUCTION must be OMP_PRIV "
6614 "at %L", &omp_udr->initializer_ns->code->loc);
6615 }
6616 }
6617 else if (omp_udr->ts.type == BT_DERIVED
6618 && !gfc_has_default_initializer (omp_udr->ts.u.derived))
6619 {
6620 gfc_error ("Missing INITIALIZER clause for !$OMP DECLARE REDUCTION "
6621 "of derived type without default initializer at %L",
6622 &omp_udr->where);
6623 return;
6624 }
6625 }
6626
6627 void
6628 gfc_resolve_omp_udrs (gfc_symtree *st)
6629 {
6630 gfc_omp_udr *omp_udr;
6631
6632 if (st == NULL)
6633 return;
6634 gfc_resolve_omp_udrs (st->left);
6635 gfc_resolve_omp_udrs (st->right);
6636 for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
6637 gfc_resolve_omp_udr (omp_udr);
6638 }