projects / gcc.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
OpenMP/Fortran: Fixes for {use,is}_device_ptr
[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 for (n = omp_clauses->lists[list]; n != NULL; n = n->next)
5349 {
5350 if (!n->sym->attr.dummy)
5351 gfc_error ("Non-dummy object %qs in %s clause at %L",
5352 n->sym->name, name, &n->where);
5353 if (n->sym->attr.allocatable
5354 || (n->sym->ts.type == BT_CLASS
5355 && CLASS_DATA (n->sym)->attr.allocatable))
5356 gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
5357 n->sym->name, name, &n->where);
5358 if (n->sym->attr.pointer
5359 || (n->sym->ts.type == BT_CLASS
5360 && CLASS_DATA (n->sym)->attr.pointer))
5361 gfc_error ("POINTER object %qs in %s clause at %L",
5362 n->sym->name, name, &n->where);
5363 if (n->sym->attr.value)
5364 gfc_error ("VALUE object %qs in %s clause at %L",
5365 n->sym->name, name, &n->where);
5366 }
5367 break;
5368 case OMP_LIST_USE_DEVICE_PTR:
5369 case OMP_LIST_USE_DEVICE_ADDR:
5370 /* FIXME: Handle OMP_LIST_USE_DEVICE_PTR. */
5371 break;
5372 default:
5373 for (; n != NULL; n = n->next)
5374 {
5375 bool bad = false;
5376 bool is_reduction = (list == OMP_LIST_REDUCTION
5377 || list == OMP_LIST_REDUCTION_INSCAN
5378 || list == OMP_LIST_REDUCTION_TASK
5379 || list == OMP_LIST_IN_REDUCTION
5380 || list == OMP_LIST_TASK_REDUCTION);
5381 if (list == OMP_LIST_REDUCTION_INSCAN)
5382 has_inscan = true;
5383 else if (is_reduction)
5384 has_notinscan = true;
5385 if (has_inscan && has_notinscan && is_reduction)
5386 {
5387 gfc_error ("%<inscan%> and non-%<inscan%> %<reduction%> "
5388 "clauses on the same construct %L",
5389 &n->where);
5390 break;
5391 }
5392 if (n->sym->attr.threadprivate)
5393 gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
5394 n->sym->name, name, &n->where);
5395 if (n->sym->attr.cray_pointee)
5396 gfc_error ("Cray pointee %qs in %s clause at %L",
5397 n->sym->name, name, &n->where);
5398 if (n->sym->attr.associate_var)
5399 gfc_error ("ASSOCIATE name %qs in %s clause at %L",
5400 n->sym->name, name, &n->where);
5401 if (list != OMP_LIST_PRIVATE && is_reduction)
5402 {
5403 if (n->sym->attr.proc_pointer)
5404 gfc_error ("Procedure pointer %qs in %s clause at %L",
5405 n->sym->name, name, &n->where);
5406 if (n->sym->attr.pointer)
5407 gfc_error ("POINTER object %qs in %s clause at %L",
5408 n->sym->name, name, &n->where);
5409 if (n->sym->attr.cray_pointer)
5410 gfc_error ("Cray pointer %qs in %s clause at %L",
5411 n->sym->name, name, &n->where);
5412 }
5413 if (code
5414 && (oacc_is_loop (code)
5415 || code->op == EXEC_OACC_PARALLEL
5416 || code->op == EXEC_OACC_SERIAL))
5417 check_array_not_assumed (n->sym, n->where, name);
5418 else if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
5419 gfc_error ("Assumed size array %qs in %s clause at %L",
5420 n->sym->name, name, &n->where);
5421 if (n->sym->attr.in_namelist && !is_reduction)
5422 gfc_error ("Variable %qs in %s clause is used in "
5423 "NAMELIST statement at %L",
5424 n->sym->name, name, &n->where);
5425 if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
5426 switch (list)
5427 {
5428 case OMP_LIST_PRIVATE:
5429 case OMP_LIST_LASTPRIVATE:
5430 case OMP_LIST_LINEAR:
5431 /* case OMP_LIST_REDUCTION: */
5432 gfc_error ("INTENT(IN) POINTER %qs in %s clause at %L",
5433 n->sym->name, name, &n->where);
5434 break;
5435 default:
5436 break;
5437 }
5438 if (omp_clauses->detach
5439 && (list == OMP_LIST_PRIVATE
5440 || list == OMP_LIST_FIRSTPRIVATE
5441 || list == OMP_LIST_LASTPRIVATE)
5442 && n->sym == omp_clauses->detach->symtree->n.sym)
5443 gfc_error ("DETACH event handle %qs in %s clause at %L",
5444 n->sym->name, name, &n->where);
5445 switch (list)
5446 {
5447 case OMP_LIST_REDUCTION_INSCAN:
5448 case OMP_LIST_REDUCTION_TASK:
5449 if (code && (code->op == EXEC_OMP_TASKLOOP
5450 || code->op == EXEC_OMP_TEAMS
5451 || code->op == EXEC_OMP_TEAMS_DISTRIBUTE))
5452 {
5453 gfc_error ("Only DEFAULT permitted as reduction-"
5454 "modifier in REDUCTION clause at %L",
5455 &n->where);
5456 break;
5457 }
5458 gcc_fallthrough ();
5459 case OMP_LIST_REDUCTION:
5460 case OMP_LIST_IN_REDUCTION:
5461 case OMP_LIST_TASK_REDUCTION:
5462 switch (n->u.reduction_op)
5463 {
5464 case OMP_REDUCTION_PLUS:
5465 case OMP_REDUCTION_TIMES:
5466 case OMP_REDUCTION_MINUS:
5467 if (!gfc_numeric_ts (&n->sym->ts))
5468 bad = true;
5469 break;
5470 case OMP_REDUCTION_AND:
5471 case OMP_REDUCTION_OR:
5472 case OMP_REDUCTION_EQV:
5473 case OMP_REDUCTION_NEQV:
5474 if (n->sym->ts.type != BT_LOGICAL)
5475 bad = true;
5476 break;
5477 case OMP_REDUCTION_MAX:
5478 case OMP_REDUCTION_MIN:
5479 if (n->sym->ts.type != BT_INTEGER
5480 && n->sym->ts.type != BT_REAL)
5481 bad = true;
5482 break;
5483 case OMP_REDUCTION_IAND:
5484 case OMP_REDUCTION_IOR:
5485 case OMP_REDUCTION_IEOR:
5486 if (n->sym->ts.type != BT_INTEGER)
5487 bad = true;
5488 break;
5489 case OMP_REDUCTION_USER:
5490 bad = true;
5491 break;
5492 default:
5493 break;
5494 }
5495 if (!bad)
5496 n->udr = NULL;
5497 else
5498 {
5499 const char *udr_name = NULL;
5500 if (n->udr)
5501 {
5502 udr_name = n->udr->udr->name;
5503 n->udr->udr
5504 = gfc_find_omp_udr (NULL, udr_name,
5505 &n->sym->ts);
5506 if (n->udr->udr == NULL)
5507 {
5508 free (n->udr);
5509 n->udr = NULL;
5510 }
5511 }
5512 if (n->udr == NULL)
5513 {
5514 if (udr_name == NULL)
5515 switch (n->u.reduction_op)
5516 {
5517 case OMP_REDUCTION_PLUS:
5518 case OMP_REDUCTION_TIMES:
5519 case OMP_REDUCTION_MINUS:
5520 case OMP_REDUCTION_AND:
5521 case OMP_REDUCTION_OR:
5522 case OMP_REDUCTION_EQV:
5523 case OMP_REDUCTION_NEQV:
5524 udr_name = gfc_op2string ((gfc_intrinsic_op)
5525 n->u.reduction_op);
5526 break;
5527 case OMP_REDUCTION_MAX:
5528 udr_name = "max";
5529 break;
5530 case OMP_REDUCTION_MIN:
5531 udr_name = "min";
5532 break;
5533 case OMP_REDUCTION_IAND:
5534 udr_name = "iand";
5535 break;
5536 case OMP_REDUCTION_IOR:
5537 udr_name = "ior";
5538 break;
5539 case OMP_REDUCTION_IEOR:
5540 udr_name = "ieor";
5541 break;
5542 default:
5543 gcc_unreachable ();
5544 }
5545 gfc_error ("!$OMP DECLARE REDUCTION %s not found "
5546 "for type %s at %L", udr_name,
5547 gfc_typename (&n->sym->ts), &n->where);
5548 }
5549 else
5550 {
5551 gfc_omp_udr *udr = n->udr->udr;
5552 n->u.reduction_op = OMP_REDUCTION_USER;
5553 n->udr->combiner
5554 = resolve_omp_udr_clause (n, udr->combiner_ns,
5555 udr->omp_out,
5556 udr->omp_in);
5557 if (udr->initializer_ns)
5558 n->udr->initializer
5559 = resolve_omp_udr_clause (n,
5560 udr->initializer_ns,
5561 udr->omp_priv,
5562 udr->omp_orig);
5563 }
5564 }
5565 break;
5566 case OMP_LIST_LINEAR:
5567 if (code
5568 && n->u.linear_op != OMP_LINEAR_DEFAULT
5569 && n->u.linear_op != linear_op)
5570 {
5571 gfc_error ("LINEAR clause modifier used on DO or SIMD"
5572 " construct at %L", &n->where);
5573 linear_op = n->u.linear_op;
5574 }
5575 else if (omp_clauses->orderedc)
5576 gfc_error ("LINEAR clause specified together with "
5577 "ORDERED clause with argument at %L",
5578 &n->where);
5579 else if (n->u.linear_op != OMP_LINEAR_REF
5580 && n->sym->ts.type != BT_INTEGER)
5581 gfc_error ("LINEAR variable %qs must be INTEGER "
5582 "at %L", n->sym->name, &n->where);
5583 else if ((n->u.linear_op == OMP_LINEAR_REF
5584 || n->u.linear_op == OMP_LINEAR_UVAL)
5585 && n->sym->attr.value)
5586 gfc_error ("LINEAR dummy argument %qs with VALUE "
5587 "attribute with %s modifier at %L",
5588 n->sym->name,
5589 n->u.linear_op == OMP_LINEAR_REF
5590 ? "REF" : "UVAL", &n->where);
5591 else if (n->expr)
5592 {
5593 gfc_expr *expr = n->expr;
5594 if (!gfc_resolve_expr (expr)
5595 || expr->ts.type != BT_INTEGER
5596 || expr->rank != 0)
5597 gfc_error ("%qs in LINEAR clause at %L requires "
5598 "a scalar integer linear-step expression",
5599 n->sym->name, &n->where);
5600 else if (!code && expr->expr_type != EXPR_CONSTANT)
5601 {
5602 if (expr->expr_type == EXPR_VARIABLE
5603 && expr->symtree->n.sym->attr.dummy
5604 && expr->symtree->n.sym->ns == ns)
5605 {
5606 gfc_omp_namelist *n2;
5607 for (n2 = omp_clauses->lists[OMP_LIST_UNIFORM];
5608 n2; n2 = n2->next)
5609 if (n2->sym == expr->symtree->n.sym)
5610 break;
5611 if (n2)
5612 break;
5613 }
5614 gfc_error ("%qs in LINEAR clause at %L requires "
5615 "a constant integer linear-step "
5616 "expression or dummy argument "
5617 "specified in UNIFORM clause",
5618 n->sym->name, &n->where);
5619 }
5620 }
5621 break;
5622 /* Workaround for PR middle-end/26316, nothing really needs
5623 to be done here for OMP_LIST_PRIVATE. */
5624 case OMP_LIST_PRIVATE:
5625 gcc_assert (code && code->op != EXEC_NOP);
5626 break;
5627 case OMP_LIST_USE_DEVICE:
5628 if (n->sym->attr.allocatable
5629 || (n->sym->ts.type == BT_CLASS && CLASS_DATA (n->sym)
5630 && CLASS_DATA (n->sym)->attr.allocatable))
5631 gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
5632 n->sym->name, name, &n->where);
5633 if (n->sym->ts.type == BT_CLASS
5634 && CLASS_DATA (n->sym)
5635 && CLASS_DATA (n->sym)->attr.class_pointer)
5636 gfc_error ("POINTER object %qs of polymorphic type in "
5637 "%s clause at %L", n->sym->name, name,
5638 &n->where);
5639 if (n->sym->attr.cray_pointer)
5640 gfc_error ("Cray pointer object %qs in %s clause at %L",
5641 n->sym->name, name, &n->where);
5642 else if (n->sym->attr.cray_pointee)
5643 gfc_error ("Cray pointee object %qs in %s clause at %L",
5644 n->sym->name, name, &n->where);
5645 else if (n->sym->attr.flavor == FL_VARIABLE
5646 && !n->sym->as
5647 && !n->sym->attr.pointer)
5648 gfc_error ("%s clause variable %qs at %L is neither "
5649 "a POINTER nor an array", name,
5650 n->sym->name, &n->where);
5651 /* FALLTHRU */
5652 case OMP_LIST_DEVICE_RESIDENT:
5653 check_symbol_not_pointer (n->sym, n->where, name);
5654 check_array_not_assumed (n->sym, n->where, name);
5655 break;
5656 default:
5657 break;
5658 }
5659 }
5660 break;
5661 }
5662 }
5663 /* OpenMP 5.1: use_device_ptr acts like use_device_addr, except for
5664 type(c_ptr). */
5665 if (omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR])
5666 {
5667 gfc_omp_namelist *n_prev, *n_next, *n_addr;
5668 n_addr = omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR];
5669 for (; n_addr && n_addr->next; n_addr = n_addr->next)
5670 ;
5671 n_prev = NULL;
5672 n = omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR];
5673 while (n)
5674 {
5675 n_next = n->next;
5676 if (n->sym->ts.type != BT_DERIVED
5677 || n->sym->ts.u.derived->ts.f90_type != BT_VOID)
5678 {
5679 n->next = NULL;
5680 if (n_addr)
5681 n_addr->next = n;
5682 else
5683 omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] = n;
5684 n_addr = n;
5685 if (n_prev)
5686 n_prev->next = n_next;
5687 else
5688 omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] = n_next;
5689 }
5690 else
5691 n_prev = n;
5692 n = n_next;
5693 }
5694 }
5695 if (omp_clauses->safelen_expr)
5696 resolve_positive_int_expr (omp_clauses->safelen_expr, "SAFELEN");
5697 if (omp_clauses->simdlen_expr)
5698 resolve_positive_int_expr (omp_clauses->simdlen_expr, "SIMDLEN");
5699 if (omp_clauses->num_teams)
5700 resolve_positive_int_expr (omp_clauses->num_teams, "NUM_TEAMS");
5701 if (omp_clauses->device)
5702 resolve_nonnegative_int_expr (omp_clauses->device, "DEVICE");
5703 if (omp_clauses->hint)
5704 {
5705 resolve_scalar_int_expr (omp_clauses->hint, "HINT");
5706 if (omp_clauses->hint->ts.type != BT_INTEGER
5707 || omp_clauses->hint->expr_type != EXPR_CONSTANT
5708 || mpz_sgn (omp_clauses->hint->value.integer) < 0)
5709 gfc_error ("Value of HINT clause at %L shall be a valid "
5710 "constant hint expression", &omp_clauses->hint->where);
5711 }
5712 if (omp_clauses->priority)
5713 resolve_nonnegative_int_expr (omp_clauses->priority, "PRIORITY");
5714 if (omp_clauses->dist_chunk_size)
5715 {
5716 gfc_expr *expr = omp_clauses->dist_chunk_size;
5717 if (!gfc_resolve_expr (expr)
5718 || expr->ts.type != BT_INTEGER || expr->rank != 0)
5719 gfc_error ("DIST_SCHEDULE clause's chunk_size at %L requires "
5720 "a scalar INTEGER expression", &expr->where);
5721 }
5722 if (omp_clauses->thread_limit)
5723 resolve_positive_int_expr (omp_clauses->thread_limit, "THREAD_LIMIT");
5724 if (omp_clauses->grainsize)
5725 resolve_positive_int_expr (omp_clauses->grainsize, "GRAINSIZE");
5726 if (omp_clauses->num_tasks)
5727 resolve_positive_int_expr (omp_clauses->num_tasks, "NUM_TASKS");
5728 if (omp_clauses->async)
5729 if (omp_clauses->async_expr)
5730 resolve_scalar_int_expr (omp_clauses->async_expr, "ASYNC");
5731 if (omp_clauses->num_gangs_expr)
5732 resolve_positive_int_expr (omp_clauses->num_gangs_expr, "NUM_GANGS");
5733 if (omp_clauses->num_workers_expr)
5734 resolve_positive_int_expr (omp_clauses->num_workers_expr, "NUM_WORKERS");
5735 if (omp_clauses->vector_length_expr)
5736 resolve_positive_int_expr (omp_clauses->vector_length_expr,
5737 "VECTOR_LENGTH");
5738 if (omp_clauses->gang_num_expr)
5739 resolve_positive_int_expr (omp_clauses->gang_num_expr, "GANG");
5740 if (omp_clauses->gang_static_expr)
5741 resolve_positive_int_expr (omp_clauses->gang_static_expr, "GANG");
5742 if (omp_clauses->worker_expr)
5743 resolve_positive_int_expr (omp_clauses->worker_expr, "WORKER");
5744 if (omp_clauses->vector_expr)
5745 resolve_positive_int_expr (omp_clauses->vector_expr, "VECTOR");
5746 for (el = omp_clauses->wait_list; el; el = el->next)
5747 resolve_scalar_int_expr (el->expr, "WAIT");
5748 if (omp_clauses->collapse && omp_clauses->tile_list)
5749 gfc_error ("Incompatible use of TILE and COLLAPSE at %L", &code->loc);
5750 if (omp_clauses->depend_source && code->op != EXEC_OMP_ORDERED)
5751 gfc_error ("SOURCE dependence type only allowed "
5752 "on ORDERED directive at %L", &code->loc);
5753 if (!openacc
5754 && code
5755 && omp_clauses->lists[OMP_LIST_MAP] == NULL
5756 && omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] == NULL
5757 && omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] == NULL)
5758 {
5759 const char *p = NULL;
5760 switch (code->op)
5761 {
5762 case EXEC_OMP_TARGET_ENTER_DATA: p = "TARGET ENTER DATA"; break;
5763 case EXEC_OMP_TARGET_EXIT_DATA: p = "TARGET EXIT DATA"; break;
5764 default: break;
5765 }
5766 if (code->op == EXEC_OMP_TARGET_DATA)
5767 gfc_error ("TARGET DATA must contain at least one MAP, USE_DEVICE_PTR, "
5768 "or USE_DEVICE_ADDR clause at %L", &code->loc);
5769 else if (p)
5770 gfc_error ("%s must contain at least one MAP clause at %L",
5771 p, &code->loc);
5772 }
5773 if (!openacc && omp_clauses->mergeable && omp_clauses->detach)
5774 gfc_error ("%<DETACH%> clause at %L must not be used together with "
5775 "%<MERGEABLE%> clause", &omp_clauses->detach->where);
5776 }
5777
5778
5779 /* Return true if SYM is ever referenced in EXPR except in the SE node. */
5780
5781 static bool
5782 expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
5783 {
5784 gfc_actual_arglist *arg;
5785 if (e == NULL || e == se)
5786 return false;
5787 switch (e->expr_type)
5788 {
5789 case EXPR_CONSTANT:
5790 case EXPR_NULL:
5791 case EXPR_VARIABLE:
5792 case EXPR_STRUCTURE:
5793 case EXPR_ARRAY:
5794 if (e->symtree != NULL
5795 && e->symtree->n.sym == s)
5796 return true;
5797 return false;
5798 case EXPR_SUBSTRING:
5799 if (e->ref != NULL
5800 && (expr_references_sym (e->ref->u.ss.start, s, se)
5801 || expr_references_sym (e->ref->u.ss.end, s, se)))
5802 return true;
5803 return false;
5804 case EXPR_OP:
5805 if (expr_references_sym (e->value.op.op2, s, se))
5806 return true;
5807 return expr_references_sym (e->value.op.op1, s, se);
5808 case EXPR_FUNCTION:
5809 for (arg = e->value.function.actual; arg; arg = arg->next)
5810 if (expr_references_sym (arg->expr, s, se))
5811 return true;
5812 return false;
5813 default:
5814 gcc_unreachable ();
5815 }
5816 }
5817
5818
5819 /* If EXPR is a conversion function that widens the type
5820 if WIDENING is true or narrows the type if WIDENING is false,
5821 return the inner expression, otherwise return NULL. */
5822
5823 static gfc_expr *
5824 is_conversion (gfc_expr *expr, bool widening)
5825 {
5826 gfc_typespec *ts1, *ts2;
5827
5828 if (expr->expr_type != EXPR_FUNCTION
5829 || expr->value.function.isym == NULL
5830 || expr->value.function.esym != NULL
5831 || expr->value.function.isym->id != GFC_ISYM_CONVERSION)
5832 return NULL;
5833
5834 if (widening)
5835 {
5836 ts1 = &expr->ts;
5837 ts2 = &expr->value.function.actual->expr->ts;
5838 }
5839 else
5840 {
5841 ts1 = &expr->value.function.actual->expr->ts;
5842 ts2 = &expr->ts;
5843 }
5844
5845 if (ts1->type > ts2->type
5846 || (ts1->type == ts2->type && ts1->kind > ts2->kind))
5847 return expr->value.function.actual->expr;
5848
5849 return NULL;
5850 }
5851
5852
5853 static void
5854 resolve_omp_atomic (gfc_code *code)
5855 {
5856 gfc_code *atomic_code = code->block;
5857 gfc_symbol *var;
5858 gfc_expr *expr2, *expr2_tmp;
5859 gfc_omp_atomic_op aop
5860 = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op
5861 & GFC_OMP_ATOMIC_MASK);
5862
5863 code = code->block->next;
5864 /* resolve_blocks asserts this is initially EXEC_ASSIGN.
5865 If it changed to EXEC_NOP, assume an error has been emitted already. */
5866 if (code->op == EXEC_NOP)
5867 return;
5868 if (code->op != EXEC_ASSIGN)
5869 {
5870 unexpected:
5871 gfc_error ("unexpected !$OMP ATOMIC expression at %L", &code->loc);
5872 return;
5873 }
5874 if (!atomic_code->ext.omp_clauses->capture)
5875 {
5876 if (code->next != NULL)
5877 goto unexpected;
5878 }
5879 else
5880 {
5881 if (code->next == NULL)
5882 goto unexpected;
5883 if (code->next->op == EXEC_NOP)
5884 return;
5885 if (code->next->op != EXEC_ASSIGN || code->next->next)
5886 {
5887 code = code->next;
5888 goto unexpected;
5889 }
5890 }
5891
5892 if (code->expr1->expr_type != EXPR_VARIABLE
5893 || code->expr1->symtree == NULL
5894 || code->expr1->rank != 0
5895 || (code->expr1->ts.type != BT_INTEGER
5896 && code->expr1->ts.type != BT_REAL
5897 && code->expr1->ts.type != BT_COMPLEX
5898 && code->expr1->ts.type != BT_LOGICAL))
5899 {
5900 gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
5901 "intrinsic type at %L", &code->loc);
5902 return;
5903 }
5904
5905 var = code->expr1->symtree->n.sym;
5906 expr2 = is_conversion (code->expr2, false);
5907 if (expr2 == NULL)
5908 {
5909 if (aop == GFC_OMP_ATOMIC_READ || aop == GFC_OMP_ATOMIC_WRITE)
5910 expr2 = is_conversion (code->expr2, true);
5911 if (expr2 == NULL)
5912 expr2 = code->expr2;
5913 }
5914
5915 switch (aop)
5916 {
5917 case GFC_OMP_ATOMIC_READ:
5918 if (expr2->expr_type != EXPR_VARIABLE
5919 || expr2->symtree == NULL
5920 || expr2->rank != 0
5921 || (expr2->ts.type != BT_INTEGER
5922 && expr2->ts.type != BT_REAL
5923 && expr2->ts.type != BT_COMPLEX
5924 && expr2->ts.type != BT_LOGICAL))
5925 gfc_error ("!$OMP ATOMIC READ statement must read from a scalar "
5926 "variable of intrinsic type at %L", &expr2->where);
5927 return;
5928 case GFC_OMP_ATOMIC_WRITE:
5929 if (expr2->rank != 0 || expr_references_sym (code->expr2, var, NULL))
5930 gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr "
5931 "must be scalar and cannot reference var at %L",
5932 &expr2->where);
5933 return;
5934 default:
5935 break;
5936 }
5937 if (atomic_code->ext.omp_clauses->capture)
5938 {
5939 expr2_tmp = expr2;
5940 if (expr2 == code->expr2)
5941 {
5942 expr2_tmp = is_conversion (code->expr2, true);
5943 if (expr2_tmp == NULL)
5944 expr2_tmp = expr2;
5945 }
5946 if (expr2_tmp->expr_type == EXPR_VARIABLE)
5947 {
5948 if (expr2_tmp->symtree == NULL
5949 || expr2_tmp->rank != 0
5950 || (expr2_tmp->ts.type != BT_INTEGER
5951 && expr2_tmp->ts.type != BT_REAL
5952 && expr2_tmp->ts.type != BT_COMPLEX
5953 && expr2_tmp->ts.type != BT_LOGICAL)
5954 || expr2_tmp->symtree->n.sym == var)
5955 {
5956 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read from "
5957 "a scalar variable of intrinsic type at %L",
5958 &expr2_tmp->where);
5959 return;
5960 }
5961 var = expr2_tmp->symtree->n.sym;
5962 code = code->next;
5963 if (code->expr1->expr_type != EXPR_VARIABLE
5964 || code->expr1->symtree == NULL
5965 || code->expr1->rank != 0
5966 || (code->expr1->ts.type != BT_INTEGER
5967 && code->expr1->ts.type != BT_REAL
5968 && code->expr1->ts.type != BT_COMPLEX
5969 && code->expr1->ts.type != BT_LOGICAL))
5970 {
5971 gfc_error ("!$OMP ATOMIC CAPTURE update statement must set "
5972 "a scalar variable of intrinsic type at %L",
5973 &code->expr1->where);
5974 return;
5975 }
5976 if (code->expr1->symtree->n.sym != var)
5977 {
5978 gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
5979 "different variable than update statement writes "
5980 "into at %L", &code->expr1->where);
5981 return;
5982 }
5983 expr2 = is_conversion (code->expr2, false);
5984 if (expr2 == NULL)
5985 expr2 = code->expr2;
5986 }
5987 }
5988
5989 if (gfc_expr_attr (code->expr1).allocatable)
5990 {
5991 gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L",
5992 &code->loc);
5993 return;
5994 }
5995
5996 if (atomic_code->ext.omp_clauses->capture
5997 && code->next == NULL
5998 && code->expr2->rank == 0
5999 && !expr_references_sym (code->expr2, var, NULL))
6000 atomic_code->ext.omp_clauses->atomic_op
6001 = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op
6002 | GFC_OMP_ATOMIC_SWAP);
6003 else if (expr2->expr_type == EXPR_OP)
6004 {
6005 gfc_expr *v = NULL, *e, *c;
6006 gfc_intrinsic_op op = expr2->value.op.op;
6007 gfc_intrinsic_op alt_op = INTRINSIC_NONE;
6008
6009 switch (op)
6010 {
6011 case INTRINSIC_PLUS:
6012 alt_op = INTRINSIC_MINUS;
6013 break;
6014 case INTRINSIC_TIMES:
6015 alt_op = INTRINSIC_DIVIDE;
6016 break;
6017 case INTRINSIC_MINUS:
6018 alt_op = INTRINSIC_PLUS;
6019 break;
6020 case INTRINSIC_DIVIDE:
6021 alt_op = INTRINSIC_TIMES;
6022 break;
6023 case INTRINSIC_AND:
6024 case INTRINSIC_OR:
6025 break;
6026 case INTRINSIC_EQV:
6027 alt_op = INTRINSIC_NEQV;
6028 break;
6029 case INTRINSIC_NEQV:
6030 alt_op = INTRINSIC_EQV;
6031 break;
6032 default:
6033 gfc_error ("!$OMP ATOMIC assignment operator must be binary "
6034 "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
6035 &expr2->where);
6036 return;
6037 }
6038
6039 /* Check for var = var op expr resp. var = expr op var where
6040 expr doesn't reference var and var op expr is mathematically
6041 equivalent to var op (expr) resp. expr op var equivalent to
6042 (expr) op var. We rely here on the fact that the matcher
6043 for x op1 y op2 z where op1 and op2 have equal precedence
6044 returns (x op1 y) op2 z. */
6045 e = expr2->value.op.op2;
6046 if (e->expr_type == EXPR_VARIABLE
6047 && e->symtree != NULL
6048 && e->symtree->n.sym == var)
6049 v = e;
6050 else if ((c = is_conversion (e, true)) != NULL
6051 && c->expr_type == EXPR_VARIABLE
6052 && c->symtree != NULL
6053 && c->symtree->n.sym == var)
6054 v = c;
6055 else
6056 {
6057 gfc_expr **p = NULL, **q;
6058 for (q = &expr2->value.op.op1; (e = *q) != NULL; )
6059 if (e->expr_type == EXPR_VARIABLE
6060 && e->symtree != NULL
6061 && e->symtree->n.sym == var)
6062 {
6063 v = e;
6064 break;
6065 }
6066 else if ((c = is_conversion (e, true)) != NULL)
6067 q = &e->value.function.actual->expr;
6068 else if (e->expr_type != EXPR_OP
6069 || (e->value.op.op != op
6070 && e->value.op.op != alt_op)
6071 || e->rank != 0)
6072 break;
6073 else
6074 {
6075 p = q;
6076 q = &e->value.op.op1;
6077 }
6078
6079 if (v == NULL)
6080 {
6081 gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
6082 "or var = expr op var at %L", &expr2->where);
6083 return;
6084 }
6085
6086 if (p != NULL)
6087 {
6088 e = *p;
6089 switch (e->value.op.op)
6090 {
6091 case INTRINSIC_MINUS:
6092 case INTRINSIC_DIVIDE:
6093 case INTRINSIC_EQV:
6094 case INTRINSIC_NEQV:
6095 gfc_error ("!$OMP ATOMIC var = var op expr not "
6096 "mathematically equivalent to var = var op "
6097 "(expr) at %L", &expr2->where);
6098 break;
6099 default:
6100 break;
6101 }
6102
6103 /* Canonicalize into var = var op (expr). */
6104 *p = e->value.op.op2;
6105 e->value.op.op2 = expr2;
6106 e->ts = expr2->ts;
6107 if (code->expr2 == expr2)
6108 code->expr2 = expr2 = e;
6109 else
6110 code->expr2->value.function.actual->expr = expr2 = e;
6111
6112 if (!gfc_compare_types (&expr2->value.op.op1->ts, &expr2->ts))
6113 {
6114 for (p = &expr2->value.op.op1; *p != v;
6115 p = &(*p)->value.function.actual->expr)
6116 ;
6117 *p = NULL;
6118 gfc_free_expr (expr2->value.op.op1);
6119 expr2->value.op.op1 = v;
6120 gfc_convert_type (v, &expr2->ts, 2);
6121 }
6122 }
6123 }
6124
6125 if (e->rank != 0 || expr_references_sym (code->expr2, var, v))
6126 {
6127 gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
6128 "must be scalar and cannot reference var at %L",
6129 &expr2->where);
6130 return;
6131 }
6132 }
6133 else if (expr2->expr_type == EXPR_FUNCTION
6134 && expr2->value.function.isym != NULL
6135 && expr2->value.function.esym == NULL
6136 && expr2->value.function.actual != NULL
6137 && expr2->value.function.actual->next != NULL)
6138 {
6139 gfc_actual_arglist *arg, *var_arg;
6140
6141 switch (expr2->value.function.isym->id)
6142 {
6143 case GFC_ISYM_MIN:
6144 case GFC_ISYM_MAX:
6145 break;
6146 case GFC_ISYM_IAND:
6147 case GFC_ISYM_IOR:
6148 case GFC_ISYM_IEOR:
6149 if (expr2->value.function.actual->next->next != NULL)
6150 {
6151 gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
6152 "or IEOR must have two arguments at %L",
6153 &expr2->where);
6154 return;
6155 }
6156 break;
6157 default:
6158 gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
6159 "MIN, MAX, IAND, IOR or IEOR at %L",
6160 &expr2->where);
6161 return;
6162 }
6163
6164 var_arg = NULL;
6165 for (arg = expr2->value.function.actual; arg; arg = arg->next)
6166 {
6167 if ((arg == expr2->value.function.actual
6168 || (var_arg == NULL && arg->next == NULL))
6169 && arg->expr->expr_type == EXPR_VARIABLE
6170 && arg->expr->symtree != NULL
6171 && arg->expr->symtree->n.sym == var)
6172 var_arg = arg;
6173 else if (expr_references_sym (arg->expr, var, NULL))
6174 {
6175 gfc_error ("!$OMP ATOMIC intrinsic arguments except one must "
6176 "not reference %qs at %L",
6177 var->name, &arg->expr->where);
6178 return;
6179 }
6180 if (arg->expr->rank != 0)
6181 {
6182 gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
6183 "at %L", &arg->expr->where);
6184 return;
6185 }
6186 }
6187
6188 if (var_arg == NULL)
6189 {
6190 gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
6191 "be %qs at %L", var->name, &expr2->where);
6192 return;
6193 }
6194
6195 if (var_arg != expr2->value.function.actual)
6196 {
6197 /* Canonicalize, so that var comes first. */
6198 gcc_assert (var_arg->next == NULL);
6199 for (arg = expr2->value.function.actual;
6200 arg->next != var_arg; arg = arg->next)
6201 ;
6202 var_arg->next = expr2->value.function.actual;
6203 expr2->value.function.actual = var_arg;
6204 arg->next = NULL;
6205 }
6206 }
6207 else
6208 gfc_error ("!$OMP ATOMIC assignment must have an operator or "
6209 "intrinsic on right hand side at %L", &expr2->where);
6210
6211 if (atomic_code->ext.omp_clauses->capture && code->next)
6212 {
6213 code = code->next;
6214 if (code->expr1->expr_type != EXPR_VARIABLE
6215 || code->expr1->symtree == NULL
6216 || code->expr1->rank != 0
6217 || (code->expr1->ts.type != BT_INTEGER
6218 && code->expr1->ts.type != BT_REAL
6219 && code->expr1->ts.type != BT_COMPLEX
6220 && code->expr1->ts.type != BT_LOGICAL))
6221 {
6222 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must set "
6223 "a scalar variable of intrinsic type at %L",
6224 &code->expr1->where);
6225 return;
6226 }
6227
6228 expr2 = is_conversion (code->expr2, false);
6229 if (expr2 == NULL)
6230 {
6231 expr2 = is_conversion (code->expr2, true);
6232 if (expr2 == NULL)
6233 expr2 = code->expr2;
6234 }
6235
6236 if (expr2->expr_type != EXPR_VARIABLE
6237 || expr2->symtree == NULL
6238 || expr2->rank != 0
6239 || (expr2->ts.type != BT_INTEGER
6240 && expr2->ts.type != BT_REAL
6241 && expr2->ts.type != BT_COMPLEX
6242 && expr2->ts.type != BT_LOGICAL))
6243 {
6244 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read "
6245 "from a scalar variable of intrinsic type at %L",
6246 &expr2->where);
6247 return;
6248 }
6249 if (expr2->symtree->n.sym != var)
6250 {
6251 gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
6252 "different variable than update statement writes "
6253 "into at %L", &expr2->where);
6254 return;
6255 }
6256 }
6257 }
6258
6259
6260 static struct fortran_omp_context
6261 {
6262 gfc_code *code;
6263 hash_set<gfc_symbol *> *sharing_clauses;
6264 hash_set<gfc_symbol *> *private_iterators;
6265 struct fortran_omp_context *previous;
6266 bool is_openmp;
6267 } *omp_current_ctx;
6268 static gfc_code *omp_current_do_code;
6269 static int omp_current_do_collapse;
6270
6271 void
6272 gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
6273 {
6274 if (code->block->next && code->block->next->op == EXEC_DO)
6275 {
6276 int i;
6277 gfc_code *c;
6278
6279 omp_current_do_code = code->block->next;
6280 if (code->ext.omp_clauses->orderedc)
6281 omp_current_do_collapse = code->ext.omp_clauses->orderedc;
6282 else
6283 omp_current_do_collapse = code->ext.omp_clauses->collapse;
6284 for (i = 1, c = omp_current_do_code; i < omp_current_do_collapse; i++)
6285 {
6286 c = c->block;
6287 if (c->op != EXEC_DO || c->next == NULL)
6288 break;
6289 c = c->next;
6290 if (c->op != EXEC_DO)
6291 break;
6292 }
6293 if (i < omp_current_do_collapse || omp_current_do_collapse <= 0)
6294 omp_current_do_collapse = 1;
6295 if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
6296 {
6297 locus *loc
6298 = &code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where;
6299 if (code->ext.omp_clauses->ordered)
6300 gfc_error ("ORDERED clause specified together with %<inscan%> "
6301 "REDUCTION clause at %L", loc);
6302 if (code->ext.omp_clauses->sched_kind != OMP_SCHED_NONE)
6303 gfc_error ("SCHEDULE clause specified together with %<inscan%> "
6304 "REDUCTION clause at %L", loc);
6305 if (!c->block
6306 || !c->block->next
6307 || !c->block->next->next
6308 || c->block->next->next->op != EXEC_OMP_SCAN
6309 || !c->block->next->next->next
6310 || c->block->next->next->next->next)
6311 gfc_error ("With INSCAN at %L, expected loop body with !$OMP SCAN "
6312 "between two structured-block-sequences", loc);
6313 else
6314 /* Mark as checked; flag will be unset later. */
6315 c->block->next->next->ext.omp_clauses->if_present = true;
6316 }
6317 }
6318 gfc_resolve_blocks (code->block, ns);
6319 omp_current_do_collapse = 0;
6320 omp_current_do_code = NULL;
6321 }
6322
6323
6324 void
6325 gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
6326 {
6327 struct fortran_omp_context ctx;
6328 gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
6329 gfc_omp_namelist *n;
6330 int list;
6331
6332 ctx.code = code;
6333 ctx.sharing_clauses = new hash_set<gfc_symbol *>;
6334 ctx.private_iterators = new hash_set<gfc_symbol *>;
6335 ctx.previous = omp_current_ctx;
6336 ctx.is_openmp = true;
6337 omp_current_ctx = &ctx;
6338
6339 for (list = 0; list < OMP_LIST_NUM; list++)
6340 switch (list)
6341 {
6342 case OMP_LIST_SHARED:
6343 case OMP_LIST_PRIVATE:
6344 case OMP_LIST_FIRSTPRIVATE:
6345 case OMP_LIST_LASTPRIVATE:
6346 case OMP_LIST_REDUCTION:
6347 case OMP_LIST_REDUCTION_INSCAN:
6348 case OMP_LIST_REDUCTION_TASK:
6349 case OMP_LIST_IN_REDUCTION:
6350 case OMP_LIST_TASK_REDUCTION:
6351 case OMP_LIST_LINEAR:
6352 for (n = omp_clauses->lists[list]; n; n = n->next)
6353 ctx.sharing_clauses->add (n->sym);
6354 break;
6355 default:
6356 break;
6357 }
6358
6359 switch (code->op)
6360 {
6361 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
6362 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
6363 case EXEC_OMP_PARALLEL_DO:
6364 case EXEC_OMP_PARALLEL_DO_SIMD:
6365 case EXEC_OMP_TARGET_PARALLEL_DO:
6366 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
6367 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
6368 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
6369 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
6370 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
6371 case EXEC_OMP_TASKLOOP:
6372 case EXEC_OMP_TASKLOOP_SIMD:
6373 case EXEC_OMP_TEAMS_DISTRIBUTE:
6374 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
6375 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
6376 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
6377 gfc_resolve_omp_do_blocks (code, ns);
6378 break;
6379 default:
6380 gfc_resolve_blocks (code->block, ns);
6381 }
6382
6383 omp_current_ctx = ctx.previous;
6384 delete ctx.sharing_clauses;
6385 delete ctx.private_iterators;
6386 }
6387
6388
6389 /* Save and clear openmp.c private state. */
6390
6391 void
6392 gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *state)
6393 {
6394 state->ptrs[0] = omp_current_ctx;
6395 state->ptrs[1] = omp_current_do_code;
6396 state->ints[0] = omp_current_do_collapse;
6397 omp_current_ctx = NULL;
6398 omp_current_do_code = NULL;
6399 omp_current_do_collapse = 0;
6400 }
6401
6402
6403 /* Restore openmp.c private state from the saved state. */
6404
6405 void
6406 gfc_omp_restore_state (struct gfc_omp_saved_state *state)
6407 {
6408 omp_current_ctx = (struct fortran_omp_context *) state->ptrs[0];
6409 omp_current_do_code = (gfc_code *) state->ptrs[1];
6410 omp_current_do_collapse = state->ints[0];
6411 }
6412
6413
6414 /* Note a DO iterator variable. This is special in !$omp parallel
6415 construct, where they are predetermined private. */
6416
6417 void
6418 gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym, bool add_clause)
6419 {
6420 if (omp_current_ctx == NULL)
6421 return;
6422
6423 int i = omp_current_do_collapse;
6424 gfc_code *c = omp_current_do_code;
6425
6426 if (sym->attr.threadprivate)
6427 return;
6428
6429 /* !$omp do and !$omp parallel do iteration variable is predetermined
6430 private just in the !$omp do resp. !$omp parallel do construct,
6431 with no implications for the outer parallel constructs. */
6432
6433 while (i-- >= 1)
6434 {
6435 if (code == c)
6436 return;
6437
6438 c = c->block->next;
6439 }
6440
6441 /* An openacc context may represent a data clause. Abort if so. */
6442 if (!omp_current_ctx->is_openmp && !oacc_is_loop (omp_current_ctx->code))
6443 return;
6444
6445 if (omp_current_ctx->sharing_clauses->contains (sym))
6446 return;
6447
6448 if (! omp_current_ctx->private_iterators->add (sym) && add_clause)
6449 {
6450 gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses;
6451 gfc_omp_namelist *p;
6452
6453 p = gfc_get_omp_namelist ();
6454 p->sym = sym;
6455 p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
6456 omp_clauses->lists[OMP_LIST_PRIVATE] = p;
6457 }
6458 }
6459
6460 static void
6461 handle_local_var (gfc_symbol *sym)
6462 {
6463 if (sym->attr.flavor != FL_VARIABLE
6464 || sym->as != NULL
6465 || (sym->ts.type != BT_INTEGER && sym->ts.type != BT_REAL))
6466 return;
6467 gfc_resolve_do_iterator (sym->ns->code, sym, false);
6468 }
6469
6470 void
6471 gfc_resolve_omp_local_vars (gfc_namespace *ns)
6472 {
6473 if (omp_current_ctx)
6474 gfc_traverse_ns (ns, handle_local_var);
6475 }
6476
6477 static void
6478 resolve_omp_do (gfc_code *code)
6479 {
6480 gfc_code *do_code, *c;
6481 int list, i, collapse;
6482 gfc_omp_namelist *n;
6483 gfc_symbol *dovar;
6484 const char *name;
6485 bool is_simd = false;
6486
6487 switch (code->op)
6488 {
6489 case EXEC_OMP_DISTRIBUTE: name = "!$OMP DISTRIBUTE"; break;
6490 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
6491 name = "!$OMP DISTRIBUTE PARALLEL DO";
6492 break;
6493 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
6494 name = "!$OMP DISTRIBUTE PARALLEL DO SIMD";
6495 is_simd = true;
6496 break;
6497 case EXEC_OMP_DISTRIBUTE_SIMD:
6498 name = "!$OMP DISTRIBUTE SIMD";
6499 is_simd = true;
6500 break;
6501 case EXEC_OMP_DO: name = "!$OMP DO"; break;
6502 case EXEC_OMP_DO_SIMD: name = "!$OMP DO SIMD"; is_simd = true; break;
6503 case EXEC_OMP_PARALLEL_DO: name = "!$OMP PARALLEL DO"; break;
6504 case EXEC_OMP_PARALLEL_DO_SIMD:
6505 name = "!$OMP PARALLEL DO SIMD";
6506 is_simd = true;
6507 break;
6508 case EXEC_OMP_SIMD: name = "!$OMP SIMD"; is_simd = true; break;
6509 case EXEC_OMP_TARGET_PARALLEL_DO: name = "!$OMP TARGET PARALLEL DO"; break;
6510 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
6511 name = "!$OMP TARGET PARALLEL DO SIMD";
6512 is_simd = true;
6513 break;
6514 case EXEC_OMP_TARGET_SIMD:
6515 name = "!$OMP TARGET SIMD";
6516 is_simd = true;
6517 break;
6518 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
6519 name = "!$OMP TARGET TEAMS DISTRIBUTE";
6520 break;
6521 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
6522 name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
6523 break;
6524 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
6525 name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
6526 is_simd = true;
6527 break;
6528 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
6529 name = "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
6530 is_simd = true;
6531 break;
6532 case EXEC_OMP_TASKLOOP: name = "!$OMP TASKLOOP"; break;
6533 case EXEC_OMP_TASKLOOP_SIMD:
6534 name = "!$OMP TASKLOOP SIMD";
6535 is_simd = true;
6536 break;
6537 case EXEC_OMP_TEAMS_DISTRIBUTE: name = "!$OMP TEAMS DISTRIBUTE"; break;
6538 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
6539 name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
6540 break;
6541 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
6542 name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
6543 is_simd = true;
6544 break;
6545 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
6546 name = "!$OMP TEAMS DISTRIBUTE SIMD";
6547 is_simd = true;
6548 break;
6549 default: gcc_unreachable ();
6550 }
6551
6552 if (code->ext.omp_clauses)
6553 resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
6554
6555 do_code = code->block->next;
6556 if (code->ext.omp_clauses->orderedc)
6557 collapse = code->ext.omp_clauses->orderedc;
6558 else
6559 {
6560 collapse = code->ext.omp_clauses->collapse;
6561 if (collapse <= 0)
6562 collapse = 1;
6563 }
6564 for (i = 1; i <= collapse; i++)
6565 {
6566 if (do_code->op == EXEC_DO_WHILE)
6567 {
6568 gfc_error ("%s cannot be a DO WHILE or DO without loop control "
6569 "at %L", name, &do_code->loc);
6570 break;
6571 }
6572 if (do_code->op == EXEC_DO_CONCURRENT)
6573 {
6574 gfc_error ("%s cannot be a DO CONCURRENT loop at %L", name,
6575 &do_code->loc);
6576 break;
6577 }
6578 gcc_assert (do_code->op == EXEC_DO);
6579 if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
6580 gfc_error ("%s iteration variable must be of type integer at %L",
6581 name, &do_code->loc);
6582 dovar = do_code->ext.iterator->var->symtree->n.sym;
6583 if (dovar->attr.threadprivate)
6584 gfc_error ("%s iteration variable must not be THREADPRIVATE "
6585 "at %L", name, &do_code->loc);
6586 if (code->ext.omp_clauses)
6587 for (list = 0; list < OMP_LIST_NUM; list++)
6588 if (!is_simd || code->ext.omp_clauses->collapse > 1
6589 ? (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE)
6590 : (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE
6591 && list != OMP_LIST_LINEAR))
6592 for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
6593 if (dovar == n->sym)
6594 {
6595 if (!is_simd || code->ext.omp_clauses->collapse > 1)
6596 gfc_error ("%s iteration variable present on clause "
6597 "other than PRIVATE or LASTPRIVATE at %L",
6598 name, &do_code->loc);
6599 else
6600 gfc_error ("%s iteration variable present on clause "
6601 "other than PRIVATE, LASTPRIVATE or "
6602 "LINEAR at %L", name, &do_code->loc);
6603 break;
6604 }
6605 if (i > 1)
6606 {
6607 gfc_code *do_code2 = code->block->next;
6608 int j;
6609
6610 for (j = 1; j < i; j++)
6611 {
6612 gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
6613 if (dovar == ivar
6614 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
6615 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
6616 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
6617 {
6618 gfc_error ("%s collapsed loops don't form rectangular "
6619 "iteration space at %L", name, &do_code->loc);
6620 break;
6621 }
6622 do_code2 = do_code2->block->next;
6623 }
6624 }
6625 for (c = do_code->next; c; c = c->next)
6626 if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
6627 {
6628 gfc_error ("collapsed %s loops not perfectly nested at %L",
6629 name, &c->loc);
6630 break;
6631 }
6632 if (i == collapse || c)
6633 break;
6634 do_code = do_code->block;
6635 if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE)
6636 {
6637 gfc_error ("not enough DO loops for collapsed %s at %L",
6638 name, &code->loc);
6639 break;
6640 }
6641 do_code = do_code->next;
6642 if (do_code == NULL
6643 || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE))
6644 {
6645 gfc_error ("not enough DO loops for collapsed %s at %L",
6646 name, &code->loc);
6647 break;
6648 }
6649 }
6650 }
6651
6652
6653 static gfc_statement
6654 omp_code_to_statement (gfc_code *code)
6655 {
6656 switch (code->op)
6657 {
6658 case EXEC_OMP_PARALLEL:
6659 return ST_OMP_PARALLEL;
6660 case EXEC_OMP_PARALLEL_SECTIONS:
6661 return ST_OMP_PARALLEL_SECTIONS;
6662 case EXEC_OMP_SECTIONS:
6663 return ST_OMP_SECTIONS;
6664 case EXEC_OMP_ORDERED:
6665 return ST_OMP_ORDERED;
6666 case EXEC_OMP_CRITICAL:
6667 return ST_OMP_CRITICAL;
6668 case EXEC_OMP_MASTER:
6669 return ST_OMP_MASTER;
6670 case EXEC_OMP_SINGLE:
6671 return ST_OMP_SINGLE;
6672 case EXEC_OMP_TASK:
6673 return ST_OMP_TASK;
6674 case EXEC_OMP_WORKSHARE:
6675 return ST_OMP_WORKSHARE;
6676 case EXEC_OMP_PARALLEL_WORKSHARE:
6677 return ST_OMP_PARALLEL_WORKSHARE;
6678 case EXEC_OMP_DO:
6679 return ST_OMP_DO;
6680 case EXEC_OMP_ATOMIC:
6681 return ST_OMP_ATOMIC;
6682 case EXEC_OMP_BARRIER:
6683 return ST_OMP_BARRIER;
6684 case EXEC_OMP_CANCEL:
6685 return ST_OMP_CANCEL;
6686 case EXEC_OMP_CANCELLATION_POINT:
6687 return ST_OMP_CANCELLATION_POINT;
6688 case EXEC_OMP_FLUSH:
6689 return ST_OMP_FLUSH;
6690 case EXEC_OMP_DISTRIBUTE:
6691 return ST_OMP_DISTRIBUTE;
6692 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
6693 return ST_OMP_DISTRIBUTE_PARALLEL_DO;
6694 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
6695 return ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD;
6696 case EXEC_OMP_DISTRIBUTE_SIMD:
6697 return ST_OMP_DISTRIBUTE_SIMD;
6698 case EXEC_OMP_DO_SIMD:
6699 return ST_OMP_DO_SIMD;
6700 case EXEC_OMP_SCAN:
6701 return ST_OMP_SCAN;
6702 case EXEC_OMP_SIMD:
6703 return ST_OMP_SIMD;
6704 case EXEC_OMP_TARGET:
6705 return ST_OMP_TARGET;
6706 case EXEC_OMP_TARGET_DATA:
6707 return ST_OMP_TARGET_DATA;
6708 case EXEC_OMP_TARGET_ENTER_DATA:
6709 return ST_OMP_TARGET_ENTER_DATA;
6710 case EXEC_OMP_TARGET_EXIT_DATA:
6711 return ST_OMP_TARGET_EXIT_DATA;
6712 case EXEC_OMP_TARGET_PARALLEL:
6713 return ST_OMP_TARGET_PARALLEL;
6714 case EXEC_OMP_TARGET_PARALLEL_DO:
6715 return ST_OMP_TARGET_PARALLEL_DO;
6716 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
6717 return ST_OMP_TARGET_PARALLEL_DO_SIMD;
6718 case EXEC_OMP_TARGET_SIMD:
6719 return ST_OMP_TARGET_SIMD;
6720 case EXEC_OMP_TARGET_TEAMS:
6721 return ST_OMP_TARGET_TEAMS;
6722 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
6723 return ST_OMP_TARGET_TEAMS_DISTRIBUTE;
6724 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
6725 return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
6726 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
6727 return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
6728 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
6729 return ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD;
6730 case EXEC_OMP_TARGET_UPDATE:
6731 return ST_OMP_TARGET_UPDATE;
6732 case EXEC_OMP_TASKGROUP:
6733 return ST_OMP_TASKGROUP;
6734 case EXEC_OMP_TASKLOOP:
6735 return ST_OMP_TASKLOOP;
6736 case EXEC_OMP_TASKLOOP_SIMD:
6737 return ST_OMP_TASKLOOP_SIMD;
6738 case EXEC_OMP_TASKWAIT:
6739 return ST_OMP_TASKWAIT;
6740 case EXEC_OMP_TASKYIELD:
6741 return ST_OMP_TASKYIELD;
6742 case EXEC_OMP_TEAMS:
6743 return ST_OMP_TEAMS;
6744 case EXEC_OMP_TEAMS_DISTRIBUTE:
6745 return ST_OMP_TEAMS_DISTRIBUTE;
6746 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
6747 return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO;
6748 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
6749 return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
6750 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
6751 return ST_OMP_TEAMS_DISTRIBUTE_SIMD;
6752 case EXEC_OMP_PARALLEL_DO:
6753 return ST_OMP_PARALLEL_DO;
6754 case EXEC_OMP_PARALLEL_DO_SIMD:
6755 return ST_OMP_PARALLEL_DO_SIMD;
6756
6757 default:
6758 gcc_unreachable ();
6759 }
6760 }
6761
6762 static gfc_statement
6763 oacc_code_to_statement (gfc_code *code)
6764 {
6765 switch (code->op)
6766 {
6767 case EXEC_OACC_PARALLEL:
6768 return ST_OACC_PARALLEL;
6769 case EXEC_OACC_KERNELS:
6770 return ST_OACC_KERNELS;
6771 case EXEC_OACC_SERIAL:
6772 return ST_OACC_SERIAL;
6773 case EXEC_OACC_DATA:
6774 return ST_OACC_DATA;
6775 case EXEC_OACC_HOST_DATA:
6776 return ST_OACC_HOST_DATA;
6777 case EXEC_OACC_PARALLEL_LOOP:
6778 return ST_OACC_PARALLEL_LOOP;
6779 case EXEC_OACC_KERNELS_LOOP:
6780 return ST_OACC_KERNELS_LOOP;
6781 case EXEC_OACC_SERIAL_LOOP:
6782 return ST_OACC_SERIAL_LOOP;
6783 case EXEC_OACC_LOOP:
6784 return ST_OACC_LOOP;
6785 case EXEC_OACC_ATOMIC:
6786 return ST_OACC_ATOMIC;
6787 case EXEC_OACC_ROUTINE:
6788 return ST_OACC_ROUTINE;
6789 case EXEC_OACC_UPDATE:
6790 return ST_OACC_UPDATE;
6791 case EXEC_OACC_WAIT:
6792 return ST_OACC_WAIT;
6793 case EXEC_OACC_CACHE:
6794 return ST_OACC_CACHE;
6795 case EXEC_OACC_ENTER_DATA:
6796 return ST_OACC_ENTER_DATA;
6797 case EXEC_OACC_EXIT_DATA:
6798 return ST_OACC_EXIT_DATA;
6799 case EXEC_OACC_DECLARE:
6800 return ST_OACC_DECLARE;
6801 default:
6802 gcc_unreachable ();
6803 }
6804 }
6805
6806 static void
6807 resolve_oacc_directive_inside_omp_region (gfc_code *code)
6808 {
6809 if (omp_current_ctx != NULL && omp_current_ctx->is_openmp)
6810 {
6811 gfc_statement st = omp_code_to_statement (omp_current_ctx->code);
6812 gfc_statement oacc_st = oacc_code_to_statement (code);
6813 gfc_error ("The %s directive cannot be specified within "
6814 "a %s region at %L", gfc_ascii_statement (oacc_st),
6815 gfc_ascii_statement (st), &code->loc);
6816 }
6817 }
6818
6819 static void
6820 resolve_omp_directive_inside_oacc_region (gfc_code *code)
6821 {
6822 if (omp_current_ctx != NULL && !omp_current_ctx->is_openmp)
6823 {
6824 gfc_statement st = oacc_code_to_statement (omp_current_ctx->code);
6825 gfc_statement omp_st = omp_code_to_statement (code);
6826 gfc_error ("The %s directive cannot be specified within "
6827 "a %s region at %L", gfc_ascii_statement (omp_st),
6828 gfc_ascii_statement (st), &code->loc);
6829 }
6830 }
6831
6832
6833 static void
6834 resolve_oacc_nested_loops (gfc_code *code, gfc_code* do_code, int collapse,
6835 const char *clause)
6836 {
6837 gfc_symbol *dovar;
6838 gfc_code *c;
6839 int i;
6840
6841 for (i = 1; i <= collapse; i++)
6842 {
6843 if (do_code->op == EXEC_DO_WHILE)
6844 {
6845 gfc_error ("!$ACC LOOP cannot be a DO WHILE or DO without loop control "
6846 "at %L", &do_code->loc);
6847 break;
6848 }
6849 if (do_code->op == EXEC_DO_CONCURRENT)
6850 {
6851 gfc_error ("!$ACC LOOP cannot be a DO CONCURRENT loop at %L",
6852 &do_code->loc);
6853 break;
6854 }
6855 gcc_assert (do_code->op == EXEC_DO);
6856 if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
6857 gfc_error ("!$ACC LOOP iteration variable must be of type integer at %L",
6858 &do_code->loc);
6859 dovar = do_code->ext.iterator->var->symtree->n.sym;
6860 if (i > 1)
6861 {
6862 gfc_code *do_code2 = code->block->next;
6863 int j;
6864
6865 for (j = 1; j < i; j++)
6866 {
6867 gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
6868 if (dovar == ivar
6869 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
6870 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
6871 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
6872 {
6873 gfc_error ("!$ACC LOOP %s loops don't form rectangular "
6874 "iteration space at %L", clause, &do_code->loc);
6875 break;
6876 }
6877 do_code2 = do_code2->block->next;
6878 }
6879 }
6880 if (i == collapse)
6881 break;
6882 for (c = do_code->next; c; c = c->next)
6883 if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
6884 {
6885 gfc_error ("%s !$ACC LOOP loops not perfectly nested at %L",
6886 clause, &c->loc);
6887 break;
6888 }
6889 if (c)
6890 break;
6891 do_code = do_code->block;
6892 if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
6893 && do_code->op != EXEC_DO_CONCURRENT)
6894 {
6895 gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
6896 clause, &code->loc);
6897 break;
6898 }
6899 do_code = do_code->next;
6900 if (do_code == NULL
6901 || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
6902 && do_code->op != EXEC_DO_CONCURRENT))
6903 {
6904 gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
6905 clause, &code->loc);
6906 break;
6907 }
6908 }
6909 }
6910
6911
6912 static void
6913 resolve_oacc_loop_blocks (gfc_code *code)
6914 {
6915 if (!oacc_is_loop (code))
6916 return;
6917
6918 if (code->ext.omp_clauses->tile_list && code->ext.omp_clauses->gang
6919 && code->ext.omp_clauses->worker && code->ext.omp_clauses->vector)
6920 gfc_error ("Tiled loop cannot be parallelized across gangs, workers and "
6921 "vectors at the same time at %L", &code->loc);
6922
6923 if (code->ext.omp_clauses->tile_list)
6924 {
6925 gfc_expr_list *el;
6926 for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
6927 {
6928 if (el->expr == NULL)
6929 {
6930 /* NULL expressions are used to represent '*' arguments.
6931 Convert those to a 0 expressions. */
6932 el->expr = gfc_get_constant_expr (BT_INTEGER,
6933 gfc_default_integer_kind,
6934 &code->loc);
6935 mpz_set_si (el->expr->value.integer, 0);
6936 }
6937 else
6938 {
6939 resolve_positive_int_expr (el->expr, "TILE");
6940 if (el->expr->expr_type != EXPR_CONSTANT)
6941 gfc_error ("TILE requires constant expression at %L",
6942 &code->loc);
6943 }
6944 }
6945 }
6946 }
6947
6948
6949 void
6950 gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns)
6951 {
6952 fortran_omp_context ctx;
6953 gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
6954 gfc_omp_namelist *n;
6955 int list;
6956
6957 resolve_oacc_loop_blocks (code);
6958
6959 ctx.code = code;
6960 ctx.sharing_clauses = new hash_set<gfc_symbol *>;
6961 ctx.private_iterators = new hash_set<gfc_symbol *>;
6962 ctx.previous = omp_current_ctx;
6963 ctx.is_openmp = false;
6964 omp_current_ctx = &ctx;
6965
6966 for (list = 0; list < OMP_LIST_NUM; list++)
6967 switch (list)
6968 {
6969 case OMP_LIST_PRIVATE:
6970 for (n = omp_clauses->lists[list]; n; n = n->next)
6971 ctx.sharing_clauses->add (n->sym);
6972 break;
6973 default:
6974 break;
6975 }
6976
6977 gfc_resolve_blocks (code->block, ns);
6978
6979 omp_current_ctx = ctx.previous;
6980 delete ctx.sharing_clauses;
6981 delete ctx.private_iterators;
6982 }
6983
6984
6985 static void
6986 resolve_oacc_loop (gfc_code *code)
6987 {
6988 gfc_code *do_code;
6989 int collapse;
6990
6991 if (code->ext.omp_clauses)
6992 resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
6993
6994 do_code = code->block->next;
6995 collapse = code->ext.omp_clauses->collapse;
6996
6997 /* Both collapsed and tiled loops are lowered the same way, but are not
6998 compatible. In gfc_trans_omp_do, the tile is prioritized. */
6999 if (code->ext.omp_clauses->tile_list)
7000 {
7001 int num = 0;
7002 gfc_expr_list *el;
7003 for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
7004 ++num;
7005 resolve_oacc_nested_loops (code, code->block->next, num, "tiled");
7006 return;
7007 }
7008
7009 if (collapse <= 0)
7010 collapse = 1;
7011 resolve_oacc_nested_loops (code, do_code, collapse, "collapsed");
7012 }
7013
7014 void
7015 gfc_resolve_oacc_declare (gfc_namespace *ns)
7016 {
7017 int list;
7018 gfc_omp_namelist *n;
7019 gfc_oacc_declare *oc;
7020
7021 if (ns->oacc_declare == NULL)
7022 return;
7023
7024 for (oc = ns->oacc_declare; oc; oc = oc->next)
7025 {
7026 for (list = 0; list < OMP_LIST_NUM; list++)
7027 for (n = oc->clauses->lists[list]; n; n = n->next)
7028 {
7029 n->sym->mark = 0;
7030 if (n->sym->attr.flavor != FL_VARIABLE
7031 && (n->sym->attr.flavor != FL_PROCEDURE
7032 || n->sym->result != n->sym))
7033 {
7034 gfc_error ("Object %qs is not a variable at %L",
7035 n->sym->name, &oc->loc);
7036 continue;
7037 }
7038
7039 if (n->expr && n->expr->ref->type == REF_ARRAY)
7040 {
7041 gfc_error ("Array sections: %qs not allowed in"
7042 " !$ACC DECLARE at %L", n->sym->name, &oc->loc);
7043 continue;
7044 }
7045 }
7046
7047 for (n = oc->clauses->lists[OMP_LIST_DEVICE_RESIDENT]; n; n = n->next)
7048 check_array_not_assumed (n->sym, oc->loc, "DEVICE_RESIDENT");
7049 }
7050
7051 for (oc = ns->oacc_declare; oc; oc = oc->next)
7052 {
7053 for (list = 0; list < OMP_LIST_NUM; list++)
7054 for (n = oc->clauses->lists[list]; n; n = n->next)
7055 {
7056 if (n->sym->mark)
7057 {
7058 gfc_error ("Symbol %qs present on multiple clauses at %L",
7059 n->sym->name, &oc->loc);
7060 continue;
7061 }
7062 else
7063 n->sym->mark = 1;
7064 }
7065 }
7066
7067 for (oc = ns->oacc_declare; oc; oc = oc->next)
7068 {
7069 for (list = 0; list < OMP_LIST_NUM; list++)
7070 for (n = oc->clauses->lists[list]; n; n = n->next)
7071 n->sym->mark = 0;
7072 }
7073 }
7074
7075
7076 void
7077 gfc_resolve_oacc_routines (gfc_namespace *ns)
7078 {
7079 for (gfc_oacc_routine_name *orn = ns->oacc_routine_names;
7080 orn;
7081 orn = orn->next)
7082 {
7083 gfc_symbol *sym = orn->sym;
7084 if (!sym->attr.external
7085 && !sym->attr.function
7086 && !sym->attr.subroutine)
7087 {
7088 gfc_error ("NAME %qs does not refer to a subroutine or function"
7089 " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
7090 continue;
7091 }
7092 if (!gfc_add_omp_declare_target (&sym->attr, sym->name, &orn->loc))
7093 {
7094 gfc_error ("NAME %qs invalid"
7095 " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
7096 continue;
7097 }
7098 }
7099 }
7100
7101
7102 void
7103 gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
7104 {
7105 resolve_oacc_directive_inside_omp_region (code);
7106
7107 switch (code->op)
7108 {
7109 case EXEC_OACC_PARALLEL:
7110 case EXEC_OACC_KERNELS:
7111 case EXEC_OACC_SERIAL:
7112 case EXEC_OACC_DATA:
7113 case EXEC_OACC_HOST_DATA:
7114 case EXEC_OACC_UPDATE:
7115 case EXEC_OACC_ENTER_DATA:
7116 case EXEC_OACC_EXIT_DATA:
7117 case EXEC_OACC_WAIT:
7118 case EXEC_OACC_CACHE:
7119 resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
7120 break;
7121 case EXEC_OACC_PARALLEL_LOOP:
7122 case EXEC_OACC_KERNELS_LOOP:
7123 case EXEC_OACC_SERIAL_LOOP:
7124 case EXEC_OACC_LOOP:
7125 resolve_oacc_loop (code);
7126 break;
7127 case EXEC_OACC_ATOMIC:
7128 resolve_omp_atomic (code);
7129 break;
7130 default:
7131 break;
7132 }
7133 }
7134
7135
7136 /* Resolve OpenMP directive clauses and check various requirements
7137 of each directive. */
7138
7139 void
7140 gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns)
7141 {
7142 resolve_omp_directive_inside_oacc_region (code);
7143
7144 if (code->op != EXEC_OMP_ATOMIC)
7145 gfc_maybe_initialize_eh ();
7146
7147 switch (code->op)
7148 {
7149 case EXEC_OMP_DISTRIBUTE:
7150 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
7151 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
7152 case EXEC_OMP_DISTRIBUTE_SIMD:
7153 case EXEC_OMP_DO:
7154 case EXEC_OMP_DO_SIMD:
7155 case EXEC_OMP_PARALLEL_DO:
7156 case EXEC_OMP_PARALLEL_DO_SIMD:
7157 case EXEC_OMP_SIMD:
7158 case EXEC_OMP_TARGET_PARALLEL_DO:
7159 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
7160 case EXEC_OMP_TARGET_SIMD:
7161 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
7162 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
7163 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
7164 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
7165 case EXEC_OMP_TASKLOOP:
7166 case EXEC_OMP_TASKLOOP_SIMD:
7167 case EXEC_OMP_TEAMS_DISTRIBUTE:
7168 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
7169 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
7170 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
7171 resolve_omp_do (code);
7172 break;
7173 case EXEC_OMP_CANCEL:
7174 case EXEC_OMP_PARALLEL_WORKSHARE:
7175 case EXEC_OMP_PARALLEL:
7176 case EXEC_OMP_PARALLEL_SECTIONS:
7177 case EXEC_OMP_SECTIONS:
7178 case EXEC_OMP_SINGLE:
7179 case EXEC_OMP_TARGET:
7180 case EXEC_OMP_TARGET_DATA:
7181 case EXEC_OMP_TARGET_ENTER_DATA:
7182 case EXEC_OMP_TARGET_EXIT_DATA:
7183 case EXEC_OMP_TARGET_PARALLEL:
7184 case EXEC_OMP_TARGET_TEAMS:
7185 case EXEC_OMP_TASK:
7186 case EXEC_OMP_TEAMS:
7187 case EXEC_OMP_WORKSHARE:
7188 if (code->ext.omp_clauses)
7189 resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
7190 break;
7191 case EXEC_OMP_TARGET_UPDATE:
7192 if (code->ext.omp_clauses)
7193 resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
7194 if (code->ext.omp_clauses == NULL
7195 || (code->ext.omp_clauses->lists[OMP_LIST_TO] == NULL
7196 && code->ext.omp_clauses->lists[OMP_LIST_FROM] == NULL))
7197 gfc_error ("OMP TARGET UPDATE at %L requires at least one TO or "
7198 "FROM clause", &code->loc);
7199 break;
7200 case EXEC_OMP_ATOMIC:
7201 resolve_omp_clauses (code, code->block->ext.omp_clauses, NULL);
7202 resolve_omp_atomic (code);
7203 break;
7204 case EXEC_OMP_CRITICAL:
7205 resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
7206 if (!code->ext.omp_clauses->critical_name
7207 && code->ext.omp_clauses->hint
7208 && code->ext.omp_clauses->hint->ts.type == BT_INTEGER
7209 && code->ext.omp_clauses->hint->expr_type == EXPR_CONSTANT
7210 && mpz_sgn (code->ext.omp_clauses->hint->value.integer) != 0)
7211 gfc_error ("OMP CRITICAL at %L with HINT clause requires a NAME, "
7212 "except when omp_sync_hint_none is used", &code->loc);
7213 break;
7214 case EXEC_OMP_SCAN:
7215 /* Flag is only used to checking, hence, it is unset afterwards. */
7216 if (!code->ext.omp_clauses->if_present)
7217 gfc_error ("Unexpected !$OMP SCAN at %L outside loop construct with "
7218 "%<inscan%> REDUCTION clause", &code->loc);
7219 code->ext.omp_clauses->if_present = false;
7220 resolve_omp_clauses (code, code->ext.omp_clauses, ns);
7221 break;
7222 default:
7223 break;
7224 }
7225 }
7226
7227 /* Resolve !$omp declare simd constructs in NS. */
7228
7229 void
7230 gfc_resolve_omp_declare_simd (gfc_namespace *ns)
7231 {
7232 gfc_omp_declare_simd *ods;
7233
7234 for (ods = ns->omp_declare_simd; ods; ods = ods->next)
7235 {
7236 if (ods->proc_name != NULL
7237 && ods->proc_name != ns->proc_name)
7238 gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure "
7239 "%qs at %L", ns->proc_name->name, &ods->where);
7240 if (ods->clauses)
7241 resolve_omp_clauses (NULL, ods->clauses, ns);
7242 }
7243 }
7244
7245 struct omp_udr_callback_data
7246 {
7247 gfc_omp_udr *omp_udr;
7248 bool is_initializer;
7249 };
7250
7251 static int
7252 omp_udr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
7253 void *data)
7254 {
7255 struct omp_udr_callback_data *cd = (struct omp_udr_callback_data *) data;
7256 if ((*e)->expr_type == EXPR_VARIABLE)
7257 {
7258 if (cd->is_initializer)
7259 {
7260 if ((*e)->symtree->n.sym != cd->omp_udr->omp_priv
7261 && (*e)->symtree->n.sym != cd->omp_udr->omp_orig)
7262 gfc_error ("Variable other than OMP_PRIV or OMP_ORIG used in "
7263 "INITIALIZER clause of !$OMP DECLARE REDUCTION at %L",
7264 &(*e)->where);
7265 }
7266 else
7267 {
7268 if ((*e)->symtree->n.sym != cd->omp_udr->omp_out
7269 && (*e)->symtree->n.sym != cd->omp_udr->omp_in)
7270 gfc_error ("Variable other than OMP_OUT or OMP_IN used in "
7271 "combiner of !$OMP DECLARE REDUCTION at %L",
7272 &(*e)->where);
7273 }
7274 }
7275 return 0;
7276 }
7277
7278 /* Resolve !$omp declare reduction constructs. */
7279
7280 static void
7281 gfc_resolve_omp_udr (gfc_omp_udr *omp_udr)
7282 {
7283 gfc_actual_arglist *a;
7284 const char *predef_name = NULL;
7285
7286 switch (omp_udr->rop)
7287 {
7288 case OMP_REDUCTION_PLUS:
7289 case OMP_REDUCTION_TIMES:
7290 case OMP_REDUCTION_MINUS:
7291 case OMP_REDUCTION_AND:
7292 case OMP_REDUCTION_OR:
7293 case OMP_REDUCTION_EQV:
7294 case OMP_REDUCTION_NEQV:
7295 case OMP_REDUCTION_MAX:
7296 case OMP_REDUCTION_USER:
7297 break;
7298 default:
7299 gfc_error ("Invalid operator for !$OMP DECLARE REDUCTION %s at %L",
7300 omp_udr->name, &omp_udr->where);
7301 return;
7302 }
7303
7304 if (gfc_omp_udr_predef (omp_udr->rop, omp_udr->name,
7305 &omp_udr->ts, &predef_name))
7306 {
7307 if (predef_name)
7308 gfc_error_now ("Redefinition of predefined %s "
7309 "!$OMP DECLARE REDUCTION at %L",
7310 predef_name, &omp_udr->where);
7311 else
7312 gfc_error_now ("Redefinition of predefined "
7313 "!$OMP DECLARE REDUCTION at %L", &omp_udr->where);
7314 return;
7315 }
7316
7317 if (omp_udr->ts.type == BT_CHARACTER
7318 && omp_udr->ts.u.cl->length
7319 && omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
7320 {
7321 gfc_error ("CHARACTER length in !$OMP DECLARE REDUCTION %s not "
7322 "constant at %L", omp_udr->name, &omp_udr->where);
7323 return;
7324 }
7325
7326 struct omp_udr_callback_data cd;
7327 cd.omp_udr = omp_udr;
7328 cd.is_initializer = false;
7329 gfc_code_walker (&omp_udr->combiner_ns->code, gfc_dummy_code_callback,
7330 omp_udr_callback, &cd);
7331 if (omp_udr->combiner_ns->code->op == EXEC_CALL)
7332 {
7333 for (a = omp_udr->combiner_ns->code->ext.actual; a; a = a->next)
7334 if (a->expr == NULL)
7335 break;
7336 if (a)
7337 gfc_error ("Subroutine call with alternate returns in combiner "
7338 "of !$OMP DECLARE REDUCTION at %L",
7339 &omp_udr->combiner_ns->code->loc);
7340 }
7341 if (omp_udr->initializer_ns)
7342 {
7343 cd.is_initializer = true;
7344 gfc_code_walker (&omp_udr->initializer_ns->code, gfc_dummy_code_callback,
7345 omp_udr_callback, &cd);
7346 if (omp_udr->initializer_ns->code->op == EXEC_CALL)
7347 {
7348 for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
7349 if (a->expr == NULL)
7350 break;
7351 if (a)
7352 gfc_error ("Subroutine call with alternate returns in "
7353 "INITIALIZER clause of !$OMP DECLARE REDUCTION "
7354 "at %L", &omp_udr->initializer_ns->code->loc);
7355 for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
7356 if (a->expr
7357 && a->expr->expr_type == EXPR_VARIABLE
7358 && a->expr->symtree->n.sym == omp_udr->omp_priv
7359 && a->expr->ref == NULL)
7360 break;
7361 if (a == NULL)
7362 gfc_error ("One of actual subroutine arguments in INITIALIZER "
7363 "clause of !$OMP DECLARE REDUCTION must be OMP_PRIV "
7364 "at %L", &omp_udr->initializer_ns->code->loc);
7365 }
7366 }
7367 else if (omp_udr->ts.type == BT_DERIVED
7368 && !gfc_has_default_initializer (omp_udr->ts.u.derived))
7369 {
7370 gfc_error ("Missing INITIALIZER clause for !$OMP DECLARE REDUCTION "
7371 "of derived type without default initializer at %L",
7372 &omp_udr->where);
7373 return;
7374 }
7375 }
7376
7377 void
7378 gfc_resolve_omp_udrs (gfc_symtree *st)
7379 {
7380 gfc_omp_udr *omp_udr;
7381
7382 if (st == NULL)
7383 return;
7384 gfc_resolve_omp_udrs (st->left);
7385 gfc_resolve_omp_udrs (st->right);
7386 for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
7387 gfc_resolve_omp_udr (omp_udr);
7388 }