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