projects / gcc.git / blob
? search:


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