projects / gcc.git / blob
? search:


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