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