?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* ggc.h (empty_string): Delete.
[official-gcc.git] / gcc / fortran / openmp.c
blob8400354181c2b9ae18965366f81928f5f4c736a1
1 /* OpenMP directive matching and resolving.
2 Copyright (C) 2005-2017 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 if (gfc_extract_int (cexpr, &collapse, -1))
1029 collapse = 1;
1030 else if (collapse <= 0)
1031 {
1032 gfc_error_now ("COLLAPSE clause argument not"
1033 " constant positive integer at %C");
1034 collapse = 1;
1035 }
1036 c->collapse = collapse;
1037 gfc_free_expr (cexpr);
1038 continue;
1039 }
1040 }
1041 if ((mask & OMP_CLAUSE_COPY)
1042 && gfc_match ("copy ( ") == MATCH_YES
1043 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1044 OMP_MAP_FORCE_TOFROM))
1045 continue;
1046 if (mask & OMP_CLAUSE_COPYIN)
1047 {
1048 if (openacc)
1049 {
1050 if (gfc_match ("copyin ( ") == MATCH_YES
1051 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1052 OMP_MAP_FORCE_TO))
1053 continue;
1054 }
1055 else if (gfc_match_omp_variable_list ("copyin (",
1056 &c->lists[OMP_LIST_COPYIN],
1057 true) == MATCH_YES)
1058 continue;
1059 }
1060 if ((mask & OMP_CLAUSE_COPYOUT)
1061 && gfc_match ("copyout ( ") == MATCH_YES
1062 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1063 OMP_MAP_FORCE_FROM))
1064 continue;
1065 if ((mask & OMP_CLAUSE_COPYPRIVATE)
1066 && gfc_match_omp_variable_list ("copyprivate (",
1067 &c->lists[OMP_LIST_COPYPRIVATE],
1068 true) == MATCH_YES)
1069 continue;
1070 if ((mask & OMP_CLAUSE_CREATE)
1071 && gfc_match ("create ( ") == MATCH_YES
1072 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1073 OMP_MAP_FORCE_ALLOC))
1074 continue;
1075 break;
1076 case 'd':
1077 if ((mask & OMP_CLAUSE_DEFAULT)
1078 && c->default_sharing == OMP_DEFAULT_UNKNOWN)
1079 {
1080 if (gfc_match ("default ( none )") == MATCH_YES)
1081 c->default_sharing = OMP_DEFAULT_NONE;
1082 else if (openacc)
1083 {
1084 if (gfc_match ("default ( present )") == MATCH_YES)
1085 c->default_sharing = OMP_DEFAULT_PRESENT;
1086 }
1087 else
1088 {
1089 if (gfc_match ("default ( firstprivate )") == MATCH_YES)
1090 c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE;
1091 else if (gfc_match ("default ( private )") == MATCH_YES)
1092 c->default_sharing = OMP_DEFAULT_PRIVATE;
1093 else if (gfc_match ("default ( shared )") == MATCH_YES)
1094 c->default_sharing = OMP_DEFAULT_SHARED;
1095 }
1096 if (c->default_sharing != OMP_DEFAULT_UNKNOWN)
1097 continue;
1098 }
1099 if ((mask & OMP_CLAUSE_DEFAULTMAP)
1100 && !c->defaultmap
1101 && gfc_match ("defaultmap ( tofrom : scalar )") == MATCH_YES)
1102 {
1103 c->defaultmap = true;
1104 continue;
1105 }
1106 if ((mask & OMP_CLAUSE_DELETE)
1107 && gfc_match ("delete ( ") == MATCH_YES
1108 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1109 OMP_MAP_DELETE))
1110 continue;
1111 if ((mask & OMP_CLAUSE_DEPEND)
1112 && gfc_match ("depend ( ") == MATCH_YES)
1113 {
1114 match m = MATCH_YES;
1115 gfc_omp_depend_op depend_op = OMP_DEPEND_OUT;
1116 if (gfc_match ("inout") == MATCH_YES)
1117 depend_op = OMP_DEPEND_INOUT;
1118 else if (gfc_match ("in") == MATCH_YES)
1119 depend_op = OMP_DEPEND_IN;
1120 else if (gfc_match ("out") == MATCH_YES)
1121 depend_op = OMP_DEPEND_OUT;
1122 else if (!c->depend_source
1123 && gfc_match ("source )") == MATCH_YES)
1124 {
1125 c->depend_source = true;
1126 continue;
1127 }
1128 else if (gfc_match ("sink : ") == MATCH_YES)
1129 {
1130 if (gfc_match_omp_depend_sink (&c->lists[OMP_LIST_DEPEND])
1131 == MATCH_YES)
1132 continue;
1133 m = MATCH_NO;
1134 }
1135 else
1136 m = MATCH_NO;
1137 head = NULL;
1138 if (m == MATCH_YES
1139 && gfc_match_omp_variable_list (" : ",
1140 &c->lists[OMP_LIST_DEPEND],
1141 false, NULL, &head,
1142 true) == MATCH_YES)
1143 {
1144 gfc_omp_namelist *n;
1145 for (n = *head; n; n = n->next)
1146 n->u.depend_op = depend_op;
1147 continue;
1148 }
1149 else
1150 gfc_current_locus = old_loc;
1151 }
1152 if ((mask & OMP_CLAUSE_DEVICE)
1153 && !openacc
1154 && c->device == NULL
1155 && gfc_match ("device ( %e )", &c->device) == MATCH_YES)
1156 continue;
1157 if ((mask & OMP_CLAUSE_DEVICE)
1158 && openacc
1159 && gfc_match ("device ( ") == MATCH_YES
1160 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1161 OMP_MAP_FORCE_TO))
1162 continue;
1163 if ((mask & OMP_CLAUSE_DEVICEPTR)
1164 && gfc_match ("deviceptr ( ") == MATCH_YES)
1165 {
1166 gfc_omp_namelist **list = &c->lists[OMP_LIST_MAP];
1167 gfc_omp_namelist **head = NULL;
1168 if (gfc_match_omp_variable_list ("", list, true, NULL,
1169 &head, false) == MATCH_YES)
1170 {
1171 gfc_omp_namelist *n;
1172 for (n = *head; n; n = n->next)
1173 n->u.map_op = OMP_MAP_FORCE_DEVICEPTR;
1174 continue;
1175 }
1176 }
1177 if ((mask & OMP_CLAUSE_DEVICE_RESIDENT)
1178 && gfc_match_omp_variable_list
1179 ("device_resident (",
1180 &c->lists[OMP_LIST_DEVICE_RESIDENT], true) == MATCH_YES)
1181 continue;
1182 if ((mask & OMP_CLAUSE_DIST_SCHEDULE)
1183 && c->dist_sched_kind == OMP_SCHED_NONE
1184 && gfc_match ("dist_schedule ( static") == MATCH_YES)
1185 {
1186 match m = MATCH_NO;
1187 c->dist_sched_kind = OMP_SCHED_STATIC;
1188 m = gfc_match (" , %e )", &c->dist_chunk_size);
1189 if (m != MATCH_YES)
1190 m = gfc_match_char (')');
1191 if (m != MATCH_YES)
1192 {
1193 c->dist_sched_kind = OMP_SCHED_NONE;
1194 gfc_current_locus = old_loc;
1195 }
1196 else
1197 continue;
1198 }
1199 break;
1200 case 'f':
1201 if ((mask & OMP_CLAUSE_FINAL)
1202 && c->final_expr == NULL
1203 && gfc_match ("final ( %e )", &c->final_expr) == MATCH_YES)
1204 continue;
1205 if ((mask & OMP_CLAUSE_FIRSTPRIVATE)
1206 && gfc_match_omp_variable_list ("firstprivate (",
1207 &c->lists[OMP_LIST_FIRSTPRIVATE],
1208 true) == MATCH_YES)
1209 continue;
1210 if ((mask & OMP_CLAUSE_FROM)
1211 && gfc_match_omp_variable_list ("from (",
1212 &c->lists[OMP_LIST_FROM], false,
1213 NULL, &head, true) == MATCH_YES)
1214 continue;
1215 break;
1216 case 'g':
1217 if ((mask & OMP_CLAUSE_GANG)
1218 && !c->gang
1219 && gfc_match ("gang") == MATCH_YES)
1220 {
1221 c->gang = true;
1222 match m = match_oacc_clause_gwv (c, GOMP_DIM_GANG);
1223 if (m == MATCH_ERROR)
1224 {
1225 gfc_current_locus = old_loc;
1226 break;
1227 }
1228 else if (m == MATCH_NO)
1229 needs_space = true;
1230 continue;
1231 }
1232 if ((mask & OMP_CLAUSE_GRAINSIZE)
1233 && c->grainsize == NULL
1234 && gfc_match ("grainsize ( %e )", &c->grainsize) == MATCH_YES)
1235 continue;
1236 break;
1237 case 'h':
1238 if ((mask & OMP_CLAUSE_HINT)
1239 && c->hint == NULL
1240 && gfc_match ("hint ( %e )", &c->hint) == MATCH_YES)
1241 continue;
1242 if ((mask & OMP_CLAUSE_HOST_SELF)
1243 && gfc_match ("host ( ") == MATCH_YES
1244 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1245 OMP_MAP_FORCE_FROM))
1246 continue;
1247 break;
1248 case 'i':
1249 if ((mask & OMP_CLAUSE_IF)
1250 && c->if_expr == NULL
1251 && gfc_match ("if ( ") == MATCH_YES)
1252 {
1253 if (gfc_match ("%e )", &c->if_expr) == MATCH_YES)
1254 continue;
1255 if (!openacc)
1256 {
1257 /* This should match the enum gfc_omp_if_kind order. */
1258 static const char *ifs[OMP_IF_LAST] = {
1259 " parallel : %e )",
1260 " task : %e )",
1261 " taskloop : %e )",
1262 " target : %e )",
1263 " target data : %e )",
1264 " target update : %e )",
1265 " target enter data : %e )",
1266 " target exit data : %e )" };
1267 int i;
1268 for (i = 0; i < OMP_IF_LAST; i++)
1269 if (c->if_exprs[i] == NULL
1270 && gfc_match (ifs[i], &c->if_exprs[i]) == MATCH_YES)
1271 break;
1272 if (i < OMP_IF_LAST)
1273 continue;
1274 }
1275 gfc_current_locus = old_loc;
1276 }
1277 if ((mask & OMP_CLAUSE_INBRANCH)
1278 && !c->inbranch
1279 && !c->notinbranch
1280 && gfc_match ("inbranch") == MATCH_YES)
1281 {
1282 c->inbranch = needs_space = true;
1283 continue;
1284 }
1285 if ((mask & OMP_CLAUSE_INDEPENDENT)
1286 && !c->independent
1287 && gfc_match ("independent") == MATCH_YES)
1288 {
1289 c->independent = true;
1290 needs_space = true;
1291 continue;
1292 }
1293 if ((mask & OMP_CLAUSE_IS_DEVICE_PTR)
1294 && gfc_match_omp_variable_list
1295 ("is_device_ptr (",
1296 &c->lists[OMP_LIST_IS_DEVICE_PTR], false) == MATCH_YES)
1297 continue;
1298 break;
1299 case 'l':
1300 if ((mask & OMP_CLAUSE_LASTPRIVATE)
1301 && gfc_match_omp_variable_list ("lastprivate (",
1302 &c->lists[OMP_LIST_LASTPRIVATE],
1303 true) == MATCH_YES)
1304 continue;
1305 end_colon = false;
1306 head = NULL;
1307 if ((mask & OMP_CLAUSE_LINEAR)
1308 && gfc_match ("linear (") == MATCH_YES)
1309 {
1310 gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
1311 gfc_expr *step = NULL;
1312
1313 if (gfc_match_omp_variable_list (" ref (",
1314 &c->lists[OMP_LIST_LINEAR],
1315 false, NULL, &head)
1316 == MATCH_YES)
1317 linear_op = OMP_LINEAR_REF;
1318 else if (gfc_match_omp_variable_list (" val (",
1319 &c->lists[OMP_LIST_LINEAR],
1320 false, NULL, &head)
1321 == MATCH_YES)
1322 linear_op = OMP_LINEAR_VAL;
1323 else if (gfc_match_omp_variable_list (" uval (",
1324 &c->lists[OMP_LIST_LINEAR],
1325 false, NULL, &head)
1326 == MATCH_YES)
1327 linear_op = OMP_LINEAR_UVAL;
1328 else if (gfc_match_omp_variable_list ("",
1329 &c->lists[OMP_LIST_LINEAR],
1330 false, &end_colon, &head)
1331 == MATCH_YES)
1332 linear_op = OMP_LINEAR_DEFAULT;
1333 else
1334 {
1335 gfc_free_omp_namelist (*head);
1336 gfc_current_locus = old_loc;
1337 *head = NULL;
1338 break;
1339 }
1340 if (linear_op != OMP_LINEAR_DEFAULT)
1341 {
1342 if (gfc_match (" :") == MATCH_YES)
1343 end_colon = true;
1344 else if (gfc_match (" )") != MATCH_YES)
1345 {
1346 gfc_free_omp_namelist (*head);
1347 gfc_current_locus = old_loc;
1348 *head = NULL;
1349 break;
1350 }
1351 }
1352 if (end_colon && gfc_match (" %e )", &step) != MATCH_YES)
1353 {
1354 gfc_free_omp_namelist (*head);
1355 gfc_current_locus = old_loc;
1356 *head = NULL;
1357 break;
1358 }
1359 else if (!end_colon)
1360 {
1361 step = gfc_get_constant_expr (BT_INTEGER,
1362 gfc_default_integer_kind,
1363 &old_loc);
1364 mpz_set_si (step->value.integer, 1);
1365 }
1366 (*head)->expr = step;
1367 if (linear_op != OMP_LINEAR_DEFAULT)
1368 for (gfc_omp_namelist *n = *head; n; n = n->next)
1369 n->u.linear_op = linear_op;
1370 continue;
1371 }
1372 if ((mask & OMP_CLAUSE_LINK)
1373 && openacc
1374 && (gfc_match_oacc_clause_link ("link (",
1375 &c->lists[OMP_LIST_LINK])
1376 == MATCH_YES))
1377 continue;
1378 else if ((mask & OMP_CLAUSE_LINK)
1379 && !openacc
1380 && (gfc_match_omp_to_link ("link (",
1381 &c->lists[OMP_LIST_LINK])
1382 == MATCH_YES))
1383 continue;
1384 break;
1385 case 'm':
1386 if ((mask & OMP_CLAUSE_MAP)
1387 && gfc_match ("map ( ") == MATCH_YES)
1388 {
1389 locus old_loc2 = gfc_current_locus;
1390 bool always = false;
1391 gfc_omp_map_op map_op = OMP_MAP_TOFROM;
1392 if (gfc_match ("always , ") == MATCH_YES)
1393 always = true;
1394 if (gfc_match ("alloc : ") == MATCH_YES)
1395 map_op = OMP_MAP_ALLOC;
1396 else if (gfc_match ("tofrom : ") == MATCH_YES)
1397 map_op = always ? OMP_MAP_ALWAYS_TOFROM : OMP_MAP_TOFROM;
1398 else if (gfc_match ("to : ") == MATCH_YES)
1399 map_op = always ? OMP_MAP_ALWAYS_TO : OMP_MAP_TO;
1400 else if (gfc_match ("from : ") == MATCH_YES)
1401 map_op = always ? OMP_MAP_ALWAYS_FROM : OMP_MAP_FROM;
1402 else if (gfc_match ("release : ") == MATCH_YES)
1403 map_op = OMP_MAP_RELEASE;
1404 else if (gfc_match ("delete : ") == MATCH_YES)
1405 map_op = OMP_MAP_DELETE;
1406 else if (always)
1407 {
1408 gfc_current_locus = old_loc2;
1409 always = false;
1410 }
1411 head = NULL;
1412 if (gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_MAP],
1413 false, NULL, &head,
1414 true) == MATCH_YES)
1415 {
1416 gfc_omp_namelist *n;
1417 for (n = *head; n; n = n->next)
1418 n->u.map_op = map_op;
1419 continue;
1420 }
1421 else
1422 gfc_current_locus = old_loc;
1423 }
1424 if ((mask & OMP_CLAUSE_MERGEABLE) && !c->mergeable
1425 && gfc_match ("mergeable") == MATCH_YES)
1426 {
1427 c->mergeable = needs_space = true;
1428 continue;
1429 }
1430 break;
1431 case 'n':
1432 if ((mask & OMP_CLAUSE_NOGROUP)
1433 && !c->nogroup
1434 && gfc_match ("nogroup") == MATCH_YES)
1435 {
1436 c->nogroup = needs_space = true;
1437 continue;
1438 }
1439 if ((mask & OMP_CLAUSE_NOTINBRANCH)
1440 && !c->notinbranch
1441 && !c->inbranch
1442 && gfc_match ("notinbranch") == MATCH_YES)
1443 {
1444 c->notinbranch = needs_space = true;
1445 continue;
1446 }
1447 if ((mask & OMP_CLAUSE_NOWAIT)
1448 && !c->nowait
1449 && gfc_match ("nowait") == MATCH_YES)
1450 {
1451 c->nowait = needs_space = true;
1452 continue;
1453 }
1454 if ((mask & OMP_CLAUSE_NUM_GANGS)
1455 && c->num_gangs_expr == NULL
1456 && gfc_match ("num_gangs ( %e )",
1457 &c->num_gangs_expr) == MATCH_YES)
1458 continue;
1459 if ((mask & OMP_CLAUSE_NUM_TASKS)
1460 && c->num_tasks == NULL
1461 && gfc_match ("num_tasks ( %e )", &c->num_tasks) == MATCH_YES)
1462 continue;
1463 if ((mask & OMP_CLAUSE_NUM_TEAMS)
1464 && c->num_teams == NULL
1465 && gfc_match ("num_teams ( %e )", &c->num_teams) == MATCH_YES)
1466 continue;
1467 if ((mask & OMP_CLAUSE_NUM_THREADS)
1468 && c->num_threads == NULL
1469 && (gfc_match ("num_threads ( %e )", &c->num_threads)
1470 == MATCH_YES))
1471 continue;
1472 if ((mask & OMP_CLAUSE_NUM_WORKERS)
1473 && c->num_workers_expr == NULL
1474 && gfc_match ("num_workers ( %e )",
1475 &c->num_workers_expr) == MATCH_YES)
1476 continue;
1477 break;
1478 case 'o':
1479 if ((mask & OMP_CLAUSE_ORDERED)
1480 && !c->ordered
1481 && gfc_match ("ordered") == MATCH_YES)
1482 {
1483 gfc_expr *cexpr = NULL;
1484 match m = gfc_match (" ( %e )", &cexpr);
1485
1486 c->ordered = true;
1487 if (m == MATCH_YES)
1488 {
1489 int ordered = 0;
1490 if (gfc_extract_int (cexpr, &ordered, -1))
1491 ordered = 0;
1492 else if (ordered <= 0)
1493 {
1494 gfc_error_now ("ORDERED clause argument not"
1495 " constant positive integer at %C");
1496 ordered = 0;
1497 }
1498 c->orderedc = ordered;
1499 gfc_free_expr (cexpr);
1500 continue;
1501 }
1502
1503 needs_space = true;
1504 continue;
1505 }
1506 break;
1507 case 'p':
1508 if ((mask & OMP_CLAUSE_PRESENT_OR_COPY)
1509 && gfc_match ("pcopy ( ") == MATCH_YES
1510 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1511 OMP_MAP_TOFROM))
1512 continue;
1513 if ((mask & OMP_CLAUSE_PRESENT_OR_COPYIN)
1514 && gfc_match ("pcopyin ( ") == MATCH_YES
1515 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1516 OMP_MAP_TO))
1517 continue;
1518 if ((mask & OMP_CLAUSE_PRESENT_OR_COPYOUT)
1519 && gfc_match ("pcopyout ( ") == MATCH_YES
1520 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1521 OMP_MAP_FROM))
1522 continue;
1523 if ((mask & OMP_CLAUSE_PRESENT_OR_CREATE)
1524 && gfc_match ("pcreate ( ") == MATCH_YES
1525 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1526 OMP_MAP_ALLOC))
1527 continue;
1528 if ((mask & OMP_CLAUSE_PRESENT)
1529 && gfc_match ("present ( ") == MATCH_YES
1530 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1531 OMP_MAP_FORCE_PRESENT))
1532 continue;
1533 if ((mask & OMP_CLAUSE_PRESENT_OR_COPY)
1534 && gfc_match ("present_or_copy ( ") == MATCH_YES
1535 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1536 OMP_MAP_TOFROM))
1537 continue;
1538 if ((mask & OMP_CLAUSE_PRESENT_OR_COPYIN)
1539 && gfc_match ("present_or_copyin ( ") == MATCH_YES
1540 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1541 OMP_MAP_TO))
1542 continue;
1543 if ((mask & OMP_CLAUSE_PRESENT_OR_COPYOUT)
1544 && gfc_match ("present_or_copyout ( ") == MATCH_YES
1545 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1546 OMP_MAP_FROM))
1547 continue;
1548 if ((mask & OMP_CLAUSE_PRESENT_OR_CREATE)
1549 && gfc_match ("present_or_create ( ") == MATCH_YES
1550 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1551 OMP_MAP_ALLOC))
1552 continue;
1553 if ((mask & OMP_CLAUSE_PRIORITY)
1554 && c->priority == NULL
1555 && gfc_match ("priority ( %e )", &c->priority) == MATCH_YES)
1556 continue;
1557 if ((mask & OMP_CLAUSE_PRIVATE)
1558 && gfc_match_omp_variable_list ("private (",
1559 &c->lists[OMP_LIST_PRIVATE],
1560 true) == MATCH_YES)
1561 continue;
1562 if ((mask & OMP_CLAUSE_PROC_BIND)
1563 && c->proc_bind == OMP_PROC_BIND_UNKNOWN)
1564 {
1565 if (gfc_match ("proc_bind ( master )") == MATCH_YES)
1566 c->proc_bind = OMP_PROC_BIND_MASTER;
1567 else if (gfc_match ("proc_bind ( spread )") == MATCH_YES)
1568 c->proc_bind = OMP_PROC_BIND_SPREAD;
1569 else if (gfc_match ("proc_bind ( close )") == MATCH_YES)
1570 c->proc_bind = OMP_PROC_BIND_CLOSE;
1571 if (c->proc_bind != OMP_PROC_BIND_UNKNOWN)
1572 continue;
1573 }
1574 break;
1575 case 'r':
1576 if ((mask & OMP_CLAUSE_REDUCTION)
1577 && gfc_match ("reduction ( ") == MATCH_YES)
1578 {
1579 gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
1580 char buffer[GFC_MAX_SYMBOL_LEN + 3];
1581 if (gfc_match_char ('+') == MATCH_YES)
1582 rop = OMP_REDUCTION_PLUS;
1583 else if (gfc_match_char ('*') == MATCH_YES)
1584 rop = OMP_REDUCTION_TIMES;
1585 else if (gfc_match_char ('-') == MATCH_YES)
1586 rop = OMP_REDUCTION_MINUS;
1587 else if (gfc_match (".and.") == MATCH_YES)
1588 rop = OMP_REDUCTION_AND;
1589 else if (gfc_match (".or.") == MATCH_YES)
1590 rop = OMP_REDUCTION_OR;
1591 else if (gfc_match (".eqv.") == MATCH_YES)
1592 rop = OMP_REDUCTION_EQV;
1593 else if (gfc_match (".neqv.") == MATCH_YES)
1594 rop = OMP_REDUCTION_NEQV;
1595 if (rop != OMP_REDUCTION_NONE)
1596 snprintf (buffer, sizeof buffer, "operator %s",
1597 gfc_op2string ((gfc_intrinsic_op) rop));
1598 else if (gfc_match_defined_op_name (buffer + 1, 1) == MATCH_YES)
1599 {
1600 buffer[0] = '.';
1601 strcat (buffer, ".");
1602 }
1603 else if (gfc_match_name (buffer) == MATCH_YES)
1604 {
1605 gfc_symbol *sym;
1606 const char *n = buffer;
1607
1608 gfc_find_symbol (buffer, NULL, 1, &sym);
1609 if (sym != NULL)
1610 {
1611 if (sym->attr.intrinsic)
1612 n = sym->name;
1613 else if ((sym->attr.flavor != FL_UNKNOWN
1614 && sym->attr.flavor != FL_PROCEDURE)
1615 || sym->attr.external
1616 || sym->attr.generic
1617 || sym->attr.entry
1618 || sym->attr.result
1619 || sym->attr.dummy
1620 || sym->attr.subroutine
1621 || sym->attr.pointer
1622 || sym->attr.target
1623 || sym->attr.cray_pointer
1624 || sym->attr.cray_pointee
1625 || (sym->attr.proc != PROC_UNKNOWN
1626 && sym->attr.proc != PROC_INTRINSIC)
1627 || sym->attr.if_source != IFSRC_UNKNOWN
1628 || sym == sym->ns->proc_name)
1629 {
1630 sym = NULL;
1631 n = NULL;
1632 }
1633 else
1634 n = sym->name;
1635 }
1636 if (n == NULL)
1637 rop = OMP_REDUCTION_NONE;
1638 else if (strcmp (n, "max") == 0)
1639 rop = OMP_REDUCTION_MAX;
1640 else if (strcmp (n, "min") == 0)
1641 rop = OMP_REDUCTION_MIN;
1642 else if (strcmp (n, "iand") == 0)
1643 rop = OMP_REDUCTION_IAND;
1644 else if (strcmp (n, "ior") == 0)
1645 rop = OMP_REDUCTION_IOR;
1646 else if (strcmp (n, "ieor") == 0)
1647 rop = OMP_REDUCTION_IEOR;
1648 if (rop != OMP_REDUCTION_NONE
1649 && sym != NULL
1650 && ! sym->attr.intrinsic
1651 && ! sym->attr.use_assoc
1652 && ((sym->attr.flavor == FL_UNKNOWN
1653 && !gfc_add_flavor (&sym->attr, FL_PROCEDURE,
1654 sym->name, NULL))
1655 || !gfc_add_intrinsic (&sym->attr, NULL)))
1656 rop = OMP_REDUCTION_NONE;
1657 }
1658 else
1659 buffer[0] = '\0';
1660 gfc_omp_udr *udr
1661 = (buffer[0]
1662 ? gfc_find_omp_udr (gfc_current_ns, buffer, NULL) : NULL);
1663 gfc_omp_namelist **head = NULL;
1664 if (rop == OMP_REDUCTION_NONE && udr)
1665 rop = OMP_REDUCTION_USER;
1666
1667 if (gfc_match_omp_variable_list (" :",
1668 &c->lists[OMP_LIST_REDUCTION],
1669 false, NULL, &head,
1670 openacc) == MATCH_YES)
1671 {
1672 gfc_omp_namelist *n;
1673 if (rop == OMP_REDUCTION_NONE)
1674 {
1675 n = *head;
1676 *head = NULL;
1677 gfc_error_now ("!$OMP DECLARE REDUCTION %s not found "
1678 "at %L", buffer, &old_loc);
1679 gfc_free_omp_namelist (n);
1680 }
1681 else
1682 for (n = *head; n; n = n->next)
1683 {
1684 n->u.reduction_op = rop;
1685 if (udr)
1686 {
1687 n->udr = gfc_get_omp_namelist_udr ();
1688 n->udr->udr = udr;
1689 }
1690 }
1691 continue;
1692 }
1693 else
1694 gfc_current_locus = old_loc;
1695 }
1696 break;
1697 case 's':
1698 if ((mask & OMP_CLAUSE_SAFELEN)
1699 && c->safelen_expr == NULL
1700 && gfc_match ("safelen ( %e )", &c->safelen_expr) == MATCH_YES)
1701 continue;
1702 if ((mask & OMP_CLAUSE_SCHEDULE)
1703 && c->sched_kind == OMP_SCHED_NONE
1704 && gfc_match ("schedule ( ") == MATCH_YES)
1705 {
1706 int nmodifiers = 0;
1707 locus old_loc2 = gfc_current_locus;
1708 do
1709 {
1710 if (!c->sched_simd
1711 && gfc_match ("simd") == MATCH_YES)
1712 {
1713 c->sched_simd = true;
1714 nmodifiers++;
1715 }
1716 else if (!c->sched_monotonic
1717 && !c->sched_nonmonotonic
1718 && gfc_match ("monotonic") == MATCH_YES)
1719 {
1720 c->sched_monotonic = true;
1721 nmodifiers++;
1722 }
1723 else if (!c->sched_monotonic
1724 && !c->sched_nonmonotonic
1725 && gfc_match ("nonmonotonic") == MATCH_YES)
1726 {
1727 c->sched_nonmonotonic = true;
1728 nmodifiers++;
1729 }
1730 else
1731 {
1732 if (nmodifiers)
1733 gfc_current_locus = old_loc2;
1734 break;
1735 }
1736 if (nmodifiers == 0
1737 && gfc_match (" , ") == MATCH_YES)
1738 continue;
1739 else if (gfc_match (" : ") == MATCH_YES)
1740 break;
1741 gfc_current_locus = old_loc2;
1742 break;
1743 }
1744 while (1);
1745 if (gfc_match ("static") == MATCH_YES)
1746 c->sched_kind = OMP_SCHED_STATIC;
1747 else if (gfc_match ("dynamic") == MATCH_YES)
1748 c->sched_kind = OMP_SCHED_DYNAMIC;
1749 else if (gfc_match ("guided") == MATCH_YES)
1750 c->sched_kind = OMP_SCHED_GUIDED;
1751 else if (gfc_match ("runtime") == MATCH_YES)
1752 c->sched_kind = OMP_SCHED_RUNTIME;
1753 else if (gfc_match ("auto") == MATCH_YES)
1754 c->sched_kind = OMP_SCHED_AUTO;
1755 if (c->sched_kind != OMP_SCHED_NONE)
1756 {
1757 match m = MATCH_NO;
1758 if (c->sched_kind != OMP_SCHED_RUNTIME
1759 && c->sched_kind != OMP_SCHED_AUTO)
1760 m = gfc_match (" , %e )", &c->chunk_size);
1761 if (m != MATCH_YES)
1762 m = gfc_match_char (')');
1763 if (m != MATCH_YES)
1764 c->sched_kind = OMP_SCHED_NONE;
1765 }
1766 if (c->sched_kind != OMP_SCHED_NONE)
1767 continue;
1768 else
1769 gfc_current_locus = old_loc;
1770 }
1771 if ((mask & OMP_CLAUSE_HOST_SELF)
1772 && gfc_match ("self ( ") == MATCH_YES
1773 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1774 OMP_MAP_FORCE_FROM))
1775 continue;
1776 if ((mask & OMP_CLAUSE_SEQ)
1777 && !c->seq
1778 && gfc_match ("seq") == MATCH_YES)
1779 {
1780 c->seq = true;
1781 needs_space = true;
1782 continue;
1783 }
1784 if ((mask & OMP_CLAUSE_SHARED)
1785 && gfc_match_omp_variable_list ("shared (",
1786 &c->lists[OMP_LIST_SHARED],
1787 true) == MATCH_YES)
1788 continue;
1789 if ((mask & OMP_CLAUSE_SIMDLEN)
1790 && c->simdlen_expr == NULL
1791 && gfc_match ("simdlen ( %e )", &c->simdlen_expr) == MATCH_YES)
1792 continue;
1793 if ((mask & OMP_CLAUSE_SIMD)
1794 && !c->simd
1795 && gfc_match ("simd") == MATCH_YES)
1796 {
1797 c->simd = needs_space = true;
1798 continue;
1799 }
1800 break;
1801 case 't':
1802 if ((mask & OMP_CLAUSE_THREAD_LIMIT)
1803 && c->thread_limit == NULL
1804 && gfc_match ("thread_limit ( %e )",
1805 &c->thread_limit) == MATCH_YES)
1806 continue;
1807 if ((mask & OMP_CLAUSE_THREADS)
1808 && !c->threads
1809 && gfc_match ("threads") == MATCH_YES)
1810 {
1811 c->threads = needs_space = true;
1812 continue;
1813 }
1814 if ((mask & OMP_CLAUSE_TILE)
1815 && !c->tile_list
1816 && match_oacc_expr_list ("tile (", &c->tile_list,
1817 true) == MATCH_YES)
1818 continue;
1819 if ((mask & OMP_CLAUSE_TO) && (mask & OMP_CLAUSE_LINK))
1820 {
1821 if (gfc_match_omp_to_link ("to (", &c->lists[OMP_LIST_TO])
1822 == MATCH_YES)
1823 continue;
1824 }
1825 else if ((mask & OMP_CLAUSE_TO)
1826 && gfc_match_omp_variable_list ("to (",
1827 &c->lists[OMP_LIST_TO], false,
1828 NULL, &head, true) == MATCH_YES)
1829 continue;
1830 break;
1831 case 'u':
1832 if ((mask & OMP_CLAUSE_UNIFORM)
1833 && gfc_match_omp_variable_list ("uniform (",
1834 &c->lists[OMP_LIST_UNIFORM],
1835 false) == MATCH_YES)
1836 continue;
1837 if ((mask & OMP_CLAUSE_UNTIED)
1838 && !c->untied
1839 && gfc_match ("untied") == MATCH_YES)
1840 {
1841 c->untied = needs_space = true;
1842 continue;
1843 }
1844 if ((mask & OMP_CLAUSE_USE_DEVICE)
1845 && gfc_match_omp_variable_list ("use_device (",
1846 &c->lists[OMP_LIST_USE_DEVICE],
1847 true) == MATCH_YES)
1848 continue;
1849 if ((mask & OMP_CLAUSE_USE_DEVICE_PTR)
1850 && gfc_match_omp_variable_list
1851 ("use_device_ptr (",
1852 &c->lists[OMP_LIST_USE_DEVICE_PTR], false) == MATCH_YES)
1853 continue;
1854 break;
1855 case 'v':
1856 /* VECTOR_LENGTH must be matched before VECTOR, because the latter
1857 doesn't unconditionally match '('. */
1858 if ((mask & OMP_CLAUSE_VECTOR_LENGTH)
1859 && c->vector_length_expr == NULL
1860 && (gfc_match ("vector_length ( %e )", &c->vector_length_expr)
1861 == MATCH_YES))
1862 continue;
1863 if ((mask & OMP_CLAUSE_VECTOR)
1864 && !c->vector
1865 && gfc_match ("vector") == MATCH_YES)
1866 {
1867 c->vector = true;
1868 match m = match_oacc_clause_gwv (c, GOMP_DIM_VECTOR);
1869 if (m == MATCH_ERROR)
1870 {
1871 gfc_current_locus = old_loc;
1872 break;
1873 }
1874 if (m == MATCH_NO)
1875 needs_space = true;
1876 continue;
1877 }
1878 break;
1879 case 'w':
1880 if ((mask & OMP_CLAUSE_WAIT)
1881 && !c->wait
1882 && gfc_match ("wait") == MATCH_YES)
1883 {
1884 c->wait = true;
1885 match m = match_oacc_expr_list (" (", &c->wait_list, false);
1886 if (m == MATCH_ERROR)
1887 {
1888 gfc_current_locus = old_loc;
1889 break;
1890 }
1891 else if (m == MATCH_NO)
1892 needs_space = true;
1893 continue;
1894 }
1895 if ((mask & OMP_CLAUSE_WORKER)
1896 && !c->worker
1897 && gfc_match ("worker") == MATCH_YES)
1898 {
1899 c->worker = true;
1900 match m = match_oacc_clause_gwv (c, GOMP_DIM_WORKER);
1901 if (m == MATCH_ERROR)
1902 {
1903 gfc_current_locus = old_loc;
1904 break;
1905 }
1906 else if (m == MATCH_NO)
1907 needs_space = true;
1908 continue;
1909 }
1910 break;
1911 }
1912 break;
1913 }
1914
1915 if (gfc_match_omp_eos () != MATCH_YES)
1916 {
1917 gfc_free_omp_clauses (c);
1918 return MATCH_ERROR;
1919 }
1920
1921 *cp = c;
1922 return MATCH_YES;
1923 }
1924
1925
1926 #define OACC_PARALLEL_CLAUSES \
1927 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
1928 | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_REDUCTION \
1929 | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
1930 | OMP_CLAUSE_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_PRESENT_OR_COPY \
1931 | OMP_CLAUSE_PRESENT_OR_COPYIN | OMP_CLAUSE_PRESENT_OR_COPYOUT \
1932 | OMP_CLAUSE_PRESENT_OR_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE \
1933 | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT)
1934 #define OACC_KERNELS_CLAUSES \
1935 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
1936 | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_DEVICEPTR \
1937 | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
1938 | OMP_CLAUSE_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_PRESENT_OR_COPY \
1939 | OMP_CLAUSE_PRESENT_OR_COPYIN | OMP_CLAUSE_PRESENT_OR_COPYOUT \
1940 | OMP_CLAUSE_PRESENT_OR_CREATE | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT)
1941 #define OACC_DATA_CLAUSES \
1942 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_COPY \
1943 | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_CREATE \
1944 | OMP_CLAUSE_PRESENT | OMP_CLAUSE_PRESENT_OR_COPY \
1945 | OMP_CLAUSE_PRESENT_OR_COPYIN | OMP_CLAUSE_PRESENT_OR_COPYOUT \
1946 | OMP_CLAUSE_PRESENT_OR_CREATE)
1947 #define OACC_LOOP_CLAUSES \
1948 (omp_mask (OMP_CLAUSE_COLLAPSE) | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER \
1949 | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ | OMP_CLAUSE_INDEPENDENT \
1950 | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_AUTO \
1951 | OMP_CLAUSE_TILE)
1952 #define OACC_PARALLEL_LOOP_CLAUSES \
1953 (OACC_LOOP_CLAUSES | OACC_PARALLEL_CLAUSES)
1954 #define OACC_KERNELS_LOOP_CLAUSES \
1955 (OACC_LOOP_CLAUSES | OACC_KERNELS_CLAUSES)
1956 #define OACC_HOST_DATA_CLAUSES omp_mask (OMP_CLAUSE_USE_DEVICE)
1957 #define OACC_DECLARE_CLAUSES \
1958 (omp_mask (OMP_CLAUSE_COPY) | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
1959 | OMP_CLAUSE_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_DEVICE_RESIDENT \
1960 | OMP_CLAUSE_PRESENT | OMP_CLAUSE_PRESENT_OR_COPY \
1961 | OMP_CLAUSE_PRESENT_OR_COPYIN | OMP_CLAUSE_PRESENT_OR_COPYOUT \
1962 | OMP_CLAUSE_PRESENT_OR_CREATE | OMP_CLAUSE_LINK)
1963 #define OACC_UPDATE_CLAUSES \
1964 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_HOST_SELF \
1965 | OMP_CLAUSE_DEVICE | OMP_CLAUSE_WAIT)
1966 #define OACC_ENTER_DATA_CLAUSES \
1967 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
1968 | OMP_CLAUSE_COPYIN | OMP_CLAUSE_CREATE | OMP_CLAUSE_PRESENT_OR_COPYIN \
1969 | OMP_CLAUSE_PRESENT_OR_CREATE)
1970 #define OACC_EXIT_DATA_CLAUSES \
1971 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
1972 | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE)
1973 #define OACC_WAIT_CLAUSES \
1974 omp_mask (OMP_CLAUSE_ASYNC)
1975 #define OACC_ROUTINE_CLAUSES \
1976 (omp_mask (OMP_CLAUSE_GANG) | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR \
1977 | OMP_CLAUSE_SEQ)
1978
1979
1980 static match
1981 match_acc (gfc_exec_op op, const omp_mask mask)
1982 {
1983 gfc_omp_clauses *c;
1984 if (gfc_match_omp_clauses (&c, mask, false, false, true) != MATCH_YES)
1985 return MATCH_ERROR;
1986 new_st.op = op;
1987 new_st.ext.omp_clauses = c;
1988 return MATCH_YES;
1989 }
1990
1991 match
1992 gfc_match_oacc_parallel_loop (void)
1993 {
1994 return match_acc (EXEC_OACC_PARALLEL_LOOP, OACC_PARALLEL_LOOP_CLAUSES);
1995 }
1996
1997
1998 match
1999 gfc_match_oacc_parallel (void)
2000 {
2001 return match_acc (EXEC_OACC_PARALLEL, OACC_PARALLEL_CLAUSES);
2002 }
2003
2004
2005 match
2006 gfc_match_oacc_kernels_loop (void)
2007 {
2008 return match_acc (EXEC_OACC_KERNELS_LOOP, OACC_KERNELS_LOOP_CLAUSES);
2009 }
2010
2011
2012 match
2013 gfc_match_oacc_kernels (void)
2014 {
2015 return match_acc (EXEC_OACC_KERNELS, OACC_KERNELS_CLAUSES);
2016 }
2017
2018
2019 match
2020 gfc_match_oacc_data (void)
2021 {
2022 return match_acc (EXEC_OACC_DATA, OACC_DATA_CLAUSES);
2023 }
2024
2025
2026 match
2027 gfc_match_oacc_host_data (void)
2028 {
2029 return match_acc (EXEC_OACC_HOST_DATA, OACC_HOST_DATA_CLAUSES);
2030 }
2031
2032
2033 match
2034 gfc_match_oacc_loop (void)
2035 {
2036 return match_acc (EXEC_OACC_LOOP, OACC_LOOP_CLAUSES);
2037 }
2038
2039
2040 match
2041 gfc_match_oacc_declare (void)
2042 {
2043 gfc_omp_clauses *c;
2044 gfc_omp_namelist *n;
2045 gfc_namespace *ns = gfc_current_ns;
2046 gfc_oacc_declare *new_oc;
2047 bool module_var = false;
2048 locus where = gfc_current_locus;
2049
2050 if (gfc_match_omp_clauses (&c, OACC_DECLARE_CLAUSES, false, false, true)
2051 != MATCH_YES)
2052 return MATCH_ERROR;
2053
2054 for (n = c->lists[OMP_LIST_DEVICE_RESIDENT]; n != NULL; n = n->next)
2055 n->sym->attr.oacc_declare_device_resident = 1;
2056
2057 for (n = c->lists[OMP_LIST_LINK]; n != NULL; n = n->next)
2058 n->sym->attr.oacc_declare_link = 1;
2059
2060 for (n = c->lists[OMP_LIST_MAP]; n != NULL; n = n->next)
2061 {
2062 gfc_symbol *s = n->sym;
2063
2064 if (s->ns->proc_name && s->ns->proc_name->attr.proc == PROC_MODULE)
2065 {
2066 if (n->u.map_op != OMP_MAP_FORCE_ALLOC
2067 && n->u.map_op != OMP_MAP_FORCE_TO)
2068 {
2069 gfc_error ("Invalid clause in module with !$ACC DECLARE at %L",
2070 &where);
2071 return MATCH_ERROR;
2072 }
2073
2074 module_var = true;
2075 }
2076
2077 if (s->attr.use_assoc)
2078 {
2079 gfc_error ("Variable is USE-associated with !$ACC DECLARE at %L",
2080 &where);
2081 return MATCH_ERROR;
2082 }
2083
2084 if ((s->attr.dimension || s->attr.codimension)
2085 && s->attr.dummy && s->as->type != AS_EXPLICIT)
2086 {
2087 gfc_error ("Assumed-size dummy array with !$ACC DECLARE at %L",
2088 &where);
2089 return MATCH_ERROR;
2090 }
2091
2092 switch (n->u.map_op)
2093 {
2094 case OMP_MAP_FORCE_ALLOC:
2095 s->attr.oacc_declare_create = 1;
2096 break;
2097
2098 case OMP_MAP_FORCE_TO:
2099 s->attr.oacc_declare_copyin = 1;
2100 break;
2101
2102 case OMP_MAP_FORCE_DEVICEPTR:
2103 s->attr.oacc_declare_deviceptr = 1;
2104 break;
2105
2106 default:
2107 break;
2108 }
2109 }
2110
2111 new_oc = gfc_get_oacc_declare ();
2112 new_oc->next = ns->oacc_declare;
2113 new_oc->module_var = module_var;
2114 new_oc->clauses = c;
2115 new_oc->loc = gfc_current_locus;
2116 ns->oacc_declare = new_oc;
2117
2118 return MATCH_YES;
2119 }
2120
2121
2122 match
2123 gfc_match_oacc_update (void)
2124 {
2125 gfc_omp_clauses *c;
2126 locus here = gfc_current_locus;
2127
2128 if (gfc_match_omp_clauses (&c, OACC_UPDATE_CLAUSES, false, false, true)
2129 != MATCH_YES)
2130 return MATCH_ERROR;
2131
2132 if (!c->lists[OMP_LIST_MAP])
2133 {
2134 gfc_error ("%<acc update%> must contain at least one "
2135 "%<device%> or %<host%> or %<self%> clause at %L", &here);
2136 return MATCH_ERROR;
2137 }
2138
2139 new_st.op = EXEC_OACC_UPDATE;
2140 new_st.ext.omp_clauses = c;
2141 return MATCH_YES;
2142 }
2143
2144
2145 match
2146 gfc_match_oacc_enter_data (void)
2147 {
2148 return match_acc (EXEC_OACC_ENTER_DATA, OACC_ENTER_DATA_CLAUSES);
2149 }
2150
2151
2152 match
2153 gfc_match_oacc_exit_data (void)
2154 {
2155 return match_acc (EXEC_OACC_EXIT_DATA, OACC_EXIT_DATA_CLAUSES);
2156 }
2157
2158
2159 match
2160 gfc_match_oacc_wait (void)
2161 {
2162 gfc_omp_clauses *c = gfc_get_omp_clauses ();
2163 gfc_expr_list *wait_list = NULL, *el;
2164 bool space = true;
2165 match m;
2166
2167 m = match_oacc_expr_list (" (", &wait_list, true);
2168 if (m == MATCH_ERROR)
2169 return m;
2170 else if (m == MATCH_YES)
2171 space = false;
2172
2173 if (gfc_match_omp_clauses (&c, OACC_WAIT_CLAUSES, space, space, true)
2174 == MATCH_ERROR)
2175 return MATCH_ERROR;
2176
2177 if (wait_list)
2178 for (el = wait_list; el; el = el->next)
2179 {
2180 if (el->expr == NULL)
2181 {
2182 gfc_error ("Invalid argument to !$ACC WAIT at %L",
2183 &wait_list->expr->where);
2184 return MATCH_ERROR;
2185 }
2186
2187 if (!gfc_resolve_expr (el->expr)
2188 || el->expr->ts.type != BT_INTEGER || el->expr->rank != 0
2189 || el->expr->expr_type != EXPR_CONSTANT)
2190 {
2191 gfc_error ("WAIT clause at %L requires a scalar INTEGER expression",
2192 &el->expr->where);
2193
2194 return MATCH_ERROR;
2195 }
2196 }
2197 c->wait_list = wait_list;
2198 new_st.op = EXEC_OACC_WAIT;
2199 new_st.ext.omp_clauses = c;
2200 return MATCH_YES;
2201 }
2202
2203
2204 match
2205 gfc_match_oacc_cache (void)
2206 {
2207 gfc_omp_clauses *c = gfc_get_omp_clauses ();
2208 /* The OpenACC cache directive explicitly only allows "array elements or
2209 subarrays", which we're currently not checking here. Either check this
2210 after the call of gfc_match_omp_variable_list, or add something like a
2211 only_sections variant next to its allow_sections parameter. */
2212 match m = gfc_match_omp_variable_list (" (",
2213 &c->lists[OMP_LIST_CACHE], true,
2214 NULL, NULL, true);
2215 if (m != MATCH_YES)
2216 {
2217 gfc_free_omp_clauses(c);
2218 return m;
2219 }
2220
2221 if (gfc_current_state() != COMP_DO
2222 && gfc_current_state() != COMP_DO_CONCURRENT)
2223 {
2224 gfc_error ("ACC CACHE directive must be inside of loop %C");
2225 gfc_free_omp_clauses(c);
2226 return MATCH_ERROR;
2227 }
2228
2229 new_st.op = EXEC_OACC_CACHE;
2230 new_st.ext.omp_clauses = c;
2231 return MATCH_YES;
2232 }
2233
2234 /* Determine the loop level for a routine. */
2235
2236 static int
2237 gfc_oacc_routine_dims (gfc_omp_clauses *clauses)
2238 {
2239 int level = -1;
2240
2241 if (clauses)
2242 {
2243 unsigned mask = 0;
2244
2245 if (clauses->gang)
2246 level = GOMP_DIM_GANG, mask |= GOMP_DIM_MASK (level);
2247 if (clauses->worker)
2248 level = GOMP_DIM_WORKER, mask |= GOMP_DIM_MASK (level);
2249 if (clauses->vector)
2250 level = GOMP_DIM_VECTOR, mask |= GOMP_DIM_MASK (level);
2251 if (clauses->seq)
2252 level = GOMP_DIM_MAX, mask |= GOMP_DIM_MASK (level);
2253
2254 if (mask != (mask & -mask))
2255 gfc_error ("Multiple loop axes specified for routine");
2256 }
2257
2258 if (level < 0)
2259 level = GOMP_DIM_MAX;
2260
2261 return level;
2262 }
2263
2264 match
2265 gfc_match_oacc_routine (void)
2266 {
2267 locus old_loc;
2268 gfc_symbol *sym = NULL;
2269 match m;
2270 gfc_omp_clauses *c = NULL;
2271 gfc_oacc_routine_name *n = NULL;
2272
2273 old_loc = gfc_current_locus;
2274
2275 m = gfc_match (" (");
2276
2277 if (gfc_current_ns->proc_name
2278 && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
2279 && m == MATCH_YES)
2280 {
2281 gfc_error ("Only the !$ACC ROUTINE form without "
2282 "list is allowed in interface block at %C");
2283 goto cleanup;
2284 }
2285
2286 if (m == MATCH_YES)
2287 {
2288 char buffer[GFC_MAX_SYMBOL_LEN + 1];
2289 gfc_symtree *st;
2290
2291 m = gfc_match_name (buffer);
2292 if (m == MATCH_YES)
2293 {
2294 st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);
2295 if (st)
2296 {
2297 sym = st->n.sym;
2298 if (gfc_current_ns->proc_name != NULL
2299 && 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 ("%s", 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 %qs of derived type 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 %qs of derived type 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 %qs of polymorphic type 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 %qs of polymorphic type 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 else if (list != OMP_LIST_DEPEND
4386 && n->sym->as
4387 && n->sym->as->type == AS_ASSUMED_SIZE)
4388 gfc_error ("Assumed size array %qs in %s clause at %L",
4389 n->sym->name, name, &n->where);
4390 if (list == OMP_LIST_MAP && !openacc)
4391 switch (code->op)
4392 {
4393 case EXEC_OMP_TARGET:
4394 case EXEC_OMP_TARGET_DATA:
4395 switch (n->u.map_op)
4396 {
4397 case OMP_MAP_TO:
4398 case OMP_MAP_ALWAYS_TO:
4399 case OMP_MAP_FROM:
4400 case OMP_MAP_ALWAYS_FROM:
4401 case OMP_MAP_TOFROM:
4402 case OMP_MAP_ALWAYS_TOFROM:
4403 case OMP_MAP_ALLOC:
4404 break;
4405 default:
4406 gfc_error ("TARGET%s with map-type other than TO, "
4407 "FROM, TOFROM, or ALLOC on MAP clause "
4408 "at %L",
4409 code->op == EXEC_OMP_TARGET
4410 ? "" : " DATA", &n->where);
4411 break;
4412 }
4413 break;
4414 case EXEC_OMP_TARGET_ENTER_DATA:
4415 switch (n->u.map_op)
4416 {
4417 case OMP_MAP_TO:
4418 case OMP_MAP_ALWAYS_TO:
4419 case OMP_MAP_ALLOC:
4420 break;
4421 default:
4422 gfc_error ("TARGET ENTER DATA with map-type other "
4423 "than TO, or ALLOC on MAP clause at %L",
4424 &n->where);
4425 break;
4426 }
4427 break;
4428 case EXEC_OMP_TARGET_EXIT_DATA:
4429 switch (n->u.map_op)
4430 {
4431 case OMP_MAP_FROM:
4432 case OMP_MAP_ALWAYS_FROM:
4433 case OMP_MAP_RELEASE:
4434 case OMP_MAP_DELETE:
4435 break;
4436 default:
4437 gfc_error ("TARGET EXIT DATA with map-type other "
4438 "than FROM, RELEASE, or DELETE on MAP "
4439 "clause at %L", &n->where);
4440 break;
4441 }
4442 break;
4443 default:
4444 break;
4445 }
4446 }
4447
4448 if (list != OMP_LIST_DEPEND)
4449 for (n = omp_clauses->lists[list]; n != NULL; n = n->next)
4450 {
4451 n->sym->attr.referenced = 1;
4452 if (n->sym->attr.threadprivate)
4453 gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
4454 n->sym->name, name, &n->where);
4455 if (n->sym->attr.cray_pointee)
4456 gfc_error ("Cray pointee %qs in %s clause at %L",
4457 n->sym->name, name, &n->where);
4458 }
4459 break;
4460 case OMP_LIST_IS_DEVICE_PTR:
4461 case OMP_LIST_USE_DEVICE_PTR:
4462 /* FIXME: Handle these. */
4463 break;
4464 default:
4465 for (; n != NULL; n = n->next)
4466 {
4467 bool bad = false;
4468 if (n->sym->attr.threadprivate)
4469 gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
4470 n->sym->name, name, &n->where);
4471 if (n->sym->attr.cray_pointee)
4472 gfc_error ("Cray pointee %qs in %s clause at %L",
4473 n->sym->name, name, &n->where);
4474 if (n->sym->attr.associate_var)
4475 gfc_error ("ASSOCIATE name %qs in %s clause at %L",
4476 n->sym->name, name, &n->where);
4477 if (list != OMP_LIST_PRIVATE)
4478 {
4479 if (n->sym->attr.proc_pointer && list == OMP_LIST_REDUCTION)
4480 gfc_error ("Procedure pointer %qs in %s clause at %L",
4481 n->sym->name, name, &n->where);
4482 if (n->sym->attr.pointer && list == OMP_LIST_REDUCTION)
4483 gfc_error ("POINTER object %qs in %s clause at %L",
4484 n->sym->name, name, &n->where);
4485 if (n->sym->attr.cray_pointer && list == OMP_LIST_REDUCTION)
4486 gfc_error ("Cray pointer %qs in %s clause at %L",
4487 n->sym->name, name, &n->where);
4488 }
4489 if (code
4490 && (oacc_is_loop (code) || code->op == EXEC_OACC_PARALLEL))
4491 check_array_not_assumed (n->sym, n->where, name);
4492 else if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
4493 gfc_error ("Assumed size array %qs in %s clause at %L",
4494 n->sym->name, name, &n->where);
4495 if (n->sym->attr.in_namelist && list != OMP_LIST_REDUCTION)
4496 gfc_error ("Variable %qs in %s clause is used in "
4497 "NAMELIST statement at %L",
4498 n->sym->name, name, &n->where);
4499 if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
4500 switch (list)
4501 {
4502 case OMP_LIST_PRIVATE:
4503 case OMP_LIST_LASTPRIVATE:
4504 case OMP_LIST_LINEAR:
4505 /* case OMP_LIST_REDUCTION: */
4506 gfc_error ("INTENT(IN) POINTER %qs in %s clause at %L",
4507 n->sym->name, name, &n->where);
4508 break;
4509 default:
4510 break;
4511 }
4512
4513 switch (list)
4514 {
4515 case OMP_LIST_REDUCTION:
4516 switch (n->u.reduction_op)
4517 {
4518 case OMP_REDUCTION_PLUS:
4519 case OMP_REDUCTION_TIMES:
4520 case OMP_REDUCTION_MINUS:
4521 if (!gfc_numeric_ts (&n->sym->ts))
4522 bad = true;
4523 break;
4524 case OMP_REDUCTION_AND:
4525 case OMP_REDUCTION_OR:
4526 case OMP_REDUCTION_EQV:
4527 case OMP_REDUCTION_NEQV:
4528 if (n->sym->ts.type != BT_LOGICAL)
4529 bad = true;
4530 break;
4531 case OMP_REDUCTION_MAX:
4532 case OMP_REDUCTION_MIN:
4533 if (n->sym->ts.type != BT_INTEGER
4534 && n->sym->ts.type != BT_REAL)
4535 bad = true;
4536 break;
4537 case OMP_REDUCTION_IAND:
4538 case OMP_REDUCTION_IOR:
4539 case OMP_REDUCTION_IEOR:
4540 if (n->sym->ts.type != BT_INTEGER)
4541 bad = true;
4542 break;
4543 case OMP_REDUCTION_USER:
4544 bad = true;
4545 break;
4546 default:
4547 break;
4548 }
4549 if (!bad)
4550 n->udr = NULL;
4551 else
4552 {
4553 const char *udr_name = NULL;
4554 if (n->udr)
4555 {
4556 udr_name = n->udr->udr->name;
4557 n->udr->udr
4558 = gfc_find_omp_udr (NULL, udr_name,
4559 &n->sym->ts);
4560 if (n->udr->udr == NULL)
4561 {
4562 free (n->udr);
4563 n->udr = NULL;
4564 }
4565 }
4566 if (n->udr == NULL)
4567 {
4568 if (udr_name == NULL)
4569 switch (n->u.reduction_op)
4570 {
4571 case OMP_REDUCTION_PLUS:
4572 case OMP_REDUCTION_TIMES:
4573 case OMP_REDUCTION_MINUS:
4574 case OMP_REDUCTION_AND:
4575 case OMP_REDUCTION_OR:
4576 case OMP_REDUCTION_EQV:
4577 case OMP_REDUCTION_NEQV:
4578 udr_name = gfc_op2string ((gfc_intrinsic_op)
4579 n->u.reduction_op);
4580 break;
4581 case OMP_REDUCTION_MAX:
4582 udr_name = "max";
4583 break;
4584 case OMP_REDUCTION_MIN:
4585 udr_name = "min";
4586 break;
4587 case OMP_REDUCTION_IAND:
4588 udr_name = "iand";
4589 break;
4590 case OMP_REDUCTION_IOR:
4591 udr_name = "ior";
4592 break;
4593 case OMP_REDUCTION_IEOR:
4594 udr_name = "ieor";
4595 break;
4596 default:
4597 gcc_unreachable ();
4598 }
4599 gfc_error ("!$OMP DECLARE REDUCTION %s not found "
4600 "for type %s at %L", udr_name,
4601 gfc_typename (&n->sym->ts), &n->where);
4602 }
4603 else
4604 {
4605 gfc_omp_udr *udr = n->udr->udr;
4606 n->u.reduction_op = OMP_REDUCTION_USER;
4607 n->udr->combiner
4608 = resolve_omp_udr_clause (n, udr->combiner_ns,
4609 udr->omp_out,
4610 udr->omp_in);
4611 if (udr->initializer_ns)
4612 n->udr->initializer
4613 = resolve_omp_udr_clause (n,
4614 udr->initializer_ns,
4615 udr->omp_priv,
4616 udr->omp_orig);
4617 }
4618 }
4619 break;
4620 case OMP_LIST_LINEAR:
4621 if (code
4622 && n->u.linear_op != OMP_LINEAR_DEFAULT
4623 && n->u.linear_op != linear_op)
4624 {
4625 gfc_error ("LINEAR clause modifier used on DO or SIMD"
4626 " construct at %L", &n->where);
4627 linear_op = n->u.linear_op;
4628 }
4629 else if (omp_clauses->orderedc)
4630 gfc_error ("LINEAR clause specified together with "
4631 "ORDERED clause with argument at %L",
4632 &n->where);
4633 else if (n->u.linear_op != OMP_LINEAR_REF
4634 && n->sym->ts.type != BT_INTEGER)
4635 gfc_error ("LINEAR variable %qs must be INTEGER "
4636 "at %L", n->sym->name, &n->where);
4637 else if ((n->u.linear_op == OMP_LINEAR_REF
4638 || n->u.linear_op == OMP_LINEAR_UVAL)
4639 && n->sym->attr.value)
4640 gfc_error ("LINEAR dummy argument %qs with VALUE "
4641 "attribute with %s modifier at %L",
4642 n->sym->name,
4643 n->u.linear_op == OMP_LINEAR_REF
4644 ? "REF" : "UVAL", &n->where);
4645 else if (n->expr)
4646 {
4647 gfc_expr *expr = n->expr;
4648 if (!gfc_resolve_expr (expr)
4649 || expr->ts.type != BT_INTEGER
4650 || expr->rank != 0)
4651 gfc_error ("%qs in LINEAR clause at %L requires "
4652 "a scalar integer linear-step expression",
4653 n->sym->name, &n->where);
4654 else if (!code && expr->expr_type != EXPR_CONSTANT)
4655 {
4656 if (expr->expr_type == EXPR_VARIABLE
4657 && expr->symtree->n.sym->attr.dummy
4658 && expr->symtree->n.sym->ns == ns)
4659 {
4660 gfc_omp_namelist *n2;
4661 for (n2 = omp_clauses->lists[OMP_LIST_UNIFORM];
4662 n2; n2 = n2->next)
4663 if (n2->sym == expr->symtree->n.sym)
4664 break;
4665 if (n2)
4666 break;
4667 }
4668 gfc_error ("%qs in LINEAR clause at %L requires "
4669 "a constant integer linear-step "
4670 "expression or dummy argument "
4671 "specified in UNIFORM clause",
4672 n->sym->name, &n->where);
4673 }
4674 }
4675 break;
4676 /* Workaround for PR middle-end/26316, nothing really needs
4677 to be done here for OMP_LIST_PRIVATE. */
4678 case OMP_LIST_PRIVATE:
4679 gcc_assert (code && code->op != EXEC_NOP);
4680 break;
4681 case OMP_LIST_USE_DEVICE:
4682 if (n->sym->attr.allocatable
4683 || (n->sym->ts.type == BT_CLASS && CLASS_DATA (n->sym)
4684 && CLASS_DATA (n->sym)->attr.allocatable))
4685 gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
4686 n->sym->name, name, &n->where);
4687 if (n->sym->ts.type == BT_CLASS
4688 && CLASS_DATA (n->sym)
4689 && CLASS_DATA (n->sym)->attr.class_pointer)
4690 gfc_error ("POINTER object %qs of polymorphic type in "
4691 "%s clause at %L", n->sym->name, name,
4692 &n->where);
4693 if (n->sym->attr.cray_pointer)
4694 gfc_error ("Cray pointer object %qs in %s clause at %L",
4695 n->sym->name, name, &n->where);
4696 else if (n->sym->attr.cray_pointee)
4697 gfc_error ("Cray pointee object %qs in %s clause at %L",
4698 n->sym->name, name, &n->where);
4699 else if (n->sym->attr.flavor == FL_VARIABLE
4700 && !n->sym->as
4701 && !n->sym->attr.pointer)
4702 gfc_error ("%s clause variable %qs at %L is neither "
4703 "a POINTER nor an array", name,
4704 n->sym->name, &n->where);
4705 /* FALLTHRU */
4706 case OMP_LIST_DEVICE_RESIDENT:
4707 check_symbol_not_pointer (n->sym, n->where, name);
4708 check_array_not_assumed (n->sym, n->where, name);
4709 break;
4710 default:
4711 break;
4712 }
4713 }
4714 break;
4715 }
4716 }
4717 if (omp_clauses->safelen_expr)
4718 resolve_positive_int_expr (omp_clauses->safelen_expr, "SAFELEN");
4719 if (omp_clauses->simdlen_expr)
4720 resolve_positive_int_expr (omp_clauses->simdlen_expr, "SIMDLEN");
4721 if (omp_clauses->num_teams)
4722 resolve_positive_int_expr (omp_clauses->num_teams, "NUM_TEAMS");
4723 if (omp_clauses->device)
4724 resolve_nonnegative_int_expr (omp_clauses->device, "DEVICE");
4725 if (omp_clauses->hint)
4726 resolve_scalar_int_expr (omp_clauses->hint, "HINT");
4727 if (omp_clauses->priority)
4728 resolve_nonnegative_int_expr (omp_clauses->priority, "PRIORITY");
4729 if (omp_clauses->dist_chunk_size)
4730 {
4731 gfc_expr *expr = omp_clauses->dist_chunk_size;
4732 if (!gfc_resolve_expr (expr)
4733 || expr->ts.type != BT_INTEGER || expr->rank != 0)
4734 gfc_error ("DIST_SCHEDULE clause's chunk_size at %L requires "
4735 "a scalar INTEGER expression", &expr->where);
4736 }
4737 if (omp_clauses->thread_limit)
4738 resolve_positive_int_expr (omp_clauses->thread_limit, "THREAD_LIMIT");
4739 if (omp_clauses->grainsize)
4740 resolve_positive_int_expr (omp_clauses->grainsize, "GRAINSIZE");
4741 if (omp_clauses->num_tasks)
4742 resolve_positive_int_expr (omp_clauses->num_tasks, "NUM_TASKS");
4743 if (omp_clauses->async)
4744 if (omp_clauses->async_expr)
4745 resolve_scalar_int_expr (omp_clauses->async_expr, "ASYNC");
4746 if (omp_clauses->num_gangs_expr)
4747 resolve_positive_int_expr (omp_clauses->num_gangs_expr, "NUM_GANGS");
4748 if (omp_clauses->num_workers_expr)
4749 resolve_positive_int_expr (omp_clauses->num_workers_expr, "NUM_WORKERS");
4750 if (omp_clauses->vector_length_expr)
4751 resolve_positive_int_expr (omp_clauses->vector_length_expr,
4752 "VECTOR_LENGTH");
4753 if (omp_clauses->gang_num_expr)
4754 resolve_positive_int_expr (omp_clauses->gang_num_expr, "GANG");
4755 if (omp_clauses->gang_static_expr)
4756 resolve_positive_int_expr (omp_clauses->gang_static_expr, "GANG");
4757 if (omp_clauses->worker_expr)
4758 resolve_positive_int_expr (omp_clauses->worker_expr, "WORKER");
4759 if (omp_clauses->vector_expr)
4760 resolve_positive_int_expr (omp_clauses->vector_expr, "VECTOR");
4761 if (omp_clauses->wait)
4762 if (omp_clauses->wait_list)
4763 for (el = omp_clauses->wait_list; el; el = el->next)
4764 resolve_scalar_int_expr (el->expr, "WAIT");
4765 if (omp_clauses->collapse && omp_clauses->tile_list)
4766 gfc_error ("Incompatible use of TILE and COLLAPSE at %L", &code->loc);
4767 if (omp_clauses->depend_source && code->op != EXEC_OMP_ORDERED)
4768 gfc_error ("SOURCE dependence type only allowed "
4769 "on ORDERED directive at %L", &code->loc);
4770 if (!openacc && code && omp_clauses->lists[OMP_LIST_MAP] == NULL)
4771 {
4772 const char *p = NULL;
4773 switch (code->op)
4774 {
4775 case EXEC_OMP_TARGET_DATA: p = "TARGET DATA"; break;
4776 case EXEC_OMP_TARGET_ENTER_DATA: p = "TARGET ENTER DATA"; break;
4777 case EXEC_OMP_TARGET_EXIT_DATA: p = "TARGET EXIT DATA"; break;
4778 default: break;
4779 }
4780 if (p)
4781 gfc_error ("%s must contain at least one MAP clause at %L",
4782 p, &code->loc);
4783 }
4784 }
4785
4786
4787 /* Return true if SYM is ever referenced in EXPR except in the SE node. */
4788
4789 static bool
4790 expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
4791 {
4792 gfc_actual_arglist *arg;
4793 if (e == NULL || e == se)
4794 return false;
4795 switch (e->expr_type)
4796 {
4797 case EXPR_CONSTANT:
4798 case EXPR_NULL:
4799 case EXPR_VARIABLE:
4800 case EXPR_STRUCTURE:
4801 case EXPR_ARRAY:
4802 if (e->symtree != NULL
4803 && e->symtree->n.sym == s)
4804 return true;
4805 return false;
4806 case EXPR_SUBSTRING:
4807 if (e->ref != NULL
4808 && (expr_references_sym (e->ref->u.ss.start, s, se)
4809 || expr_references_sym (e->ref->u.ss.end, s, se)))
4810 return true;
4811 return false;
4812 case EXPR_OP:
4813 if (expr_references_sym (e->value.op.op2, s, se))
4814 return true;
4815 return expr_references_sym (e->value.op.op1, s, se);
4816 case EXPR_FUNCTION:
4817 for (arg = e->value.function.actual; arg; arg = arg->next)
4818 if (expr_references_sym (arg->expr, s, se))
4819 return true;
4820 return false;
4821 default:
4822 gcc_unreachable ();
4823 }
4824 }
4825
4826
4827 /* If EXPR is a conversion function that widens the type
4828 if WIDENING is true or narrows the type if WIDENING is false,
4829 return the inner expression, otherwise return NULL. */
4830
4831 static gfc_expr *
4832 is_conversion (gfc_expr *expr, bool widening)
4833 {
4834 gfc_typespec *ts1, *ts2;
4835
4836 if (expr->expr_type != EXPR_FUNCTION
4837 || expr->value.function.isym == NULL
4838 || expr->value.function.esym != NULL
4839 || expr->value.function.isym->id != GFC_ISYM_CONVERSION)
4840 return NULL;
4841
4842 if (widening)
4843 {
4844 ts1 = &expr->ts;
4845 ts2 = &expr->value.function.actual->expr->ts;
4846 }
4847 else
4848 {
4849 ts1 = &expr->value.function.actual->expr->ts;
4850 ts2 = &expr->ts;
4851 }
4852
4853 if (ts1->type > ts2->type
4854 || (ts1->type == ts2->type && ts1->kind > ts2->kind))
4855 return expr->value.function.actual->expr;
4856
4857 return NULL;
4858 }
4859
4860
4861 static void
4862 resolve_omp_atomic (gfc_code *code)
4863 {
4864 gfc_code *atomic_code = code;
4865 gfc_symbol *var;
4866 gfc_expr *expr2, *expr2_tmp;
4867 gfc_omp_atomic_op aop
4868 = (gfc_omp_atomic_op) (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK);
4869
4870 code = code->block->next;
4871 /* resolve_blocks asserts this is initially EXEC_ASSIGN.
4872 If it changed to EXEC_NOP, assume an error has been emitted already. */
4873 if (code->op == EXEC_NOP)
4874 return;
4875 if (code->op != EXEC_ASSIGN)
4876 {
4877 unexpected:
4878 gfc_error ("unexpected !$OMP ATOMIC expression at %L", &code->loc);
4879 return;
4880 }
4881 if (aop != GFC_OMP_ATOMIC_CAPTURE)
4882 {
4883 if (code->next != NULL)
4884 goto unexpected;
4885 }
4886 else
4887 {
4888 if (code->next == NULL)
4889 goto unexpected;
4890 if (code->next->op == EXEC_NOP)
4891 return;
4892 if (code->next->op != EXEC_ASSIGN || code->next->next)
4893 {
4894 code = code->next;
4895 goto unexpected;
4896 }
4897 }
4898
4899 if (code->expr1->expr_type != EXPR_VARIABLE
4900 || code->expr1->symtree == NULL
4901 || code->expr1->rank != 0
4902 || (code->expr1->ts.type != BT_INTEGER
4903 && code->expr1->ts.type != BT_REAL
4904 && code->expr1->ts.type != BT_COMPLEX
4905 && code->expr1->ts.type != BT_LOGICAL))
4906 {
4907 gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
4908 "intrinsic type at %L", &code->loc);
4909 return;
4910 }
4911
4912 var = code->expr1->symtree->n.sym;
4913 expr2 = is_conversion (code->expr2, false);
4914 if (expr2 == NULL)
4915 {
4916 if (aop == GFC_OMP_ATOMIC_READ || aop == GFC_OMP_ATOMIC_WRITE)
4917 expr2 = is_conversion (code->expr2, true);
4918 if (expr2 == NULL)
4919 expr2 = code->expr2;
4920 }
4921
4922 switch (aop)
4923 {
4924 case GFC_OMP_ATOMIC_READ:
4925 if (expr2->expr_type != EXPR_VARIABLE
4926 || expr2->symtree == NULL
4927 || expr2->rank != 0
4928 || (expr2->ts.type != BT_INTEGER
4929 && expr2->ts.type != BT_REAL
4930 && expr2->ts.type != BT_COMPLEX
4931 && expr2->ts.type != BT_LOGICAL))
4932 gfc_error ("!$OMP ATOMIC READ statement must read from a scalar "
4933 "variable of intrinsic type at %L", &expr2->where);
4934 return;
4935 case GFC_OMP_ATOMIC_WRITE:
4936 if (expr2->rank != 0 || expr_references_sym (code->expr2, var, NULL))
4937 gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr "
4938 "must be scalar and cannot reference var at %L",
4939 &expr2->where);
4940 return;
4941 case GFC_OMP_ATOMIC_CAPTURE:
4942 expr2_tmp = expr2;
4943 if (expr2 == code->expr2)
4944 {
4945 expr2_tmp = is_conversion (code->expr2, true);
4946 if (expr2_tmp == NULL)
4947 expr2_tmp = expr2;
4948 }
4949 if (expr2_tmp->expr_type == EXPR_VARIABLE)
4950 {
4951 if (expr2_tmp->symtree == NULL
4952 || expr2_tmp->rank != 0
4953 || (expr2_tmp->ts.type != BT_INTEGER
4954 && expr2_tmp->ts.type != BT_REAL
4955 && expr2_tmp->ts.type != BT_COMPLEX
4956 && expr2_tmp->ts.type != BT_LOGICAL)
4957 || expr2_tmp->symtree->n.sym == var)
4958 {
4959 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read from "
4960 "a scalar variable of intrinsic type at %L",
4961 &expr2_tmp->where);
4962 return;
4963 }
4964 var = expr2_tmp->symtree->n.sym;
4965 code = code->next;
4966 if (code->expr1->expr_type != EXPR_VARIABLE
4967 || code->expr1->symtree == NULL
4968 || code->expr1->rank != 0
4969 || (code->expr1->ts.type != BT_INTEGER
4970 && code->expr1->ts.type != BT_REAL
4971 && code->expr1->ts.type != BT_COMPLEX
4972 && code->expr1->ts.type != BT_LOGICAL))
4973 {
4974 gfc_error ("!$OMP ATOMIC CAPTURE update statement must set "
4975 "a scalar variable of intrinsic type at %L",
4976 &code->expr1->where);
4977 return;
4978 }
4979 if (code->expr1->symtree->n.sym != var)
4980 {
4981 gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
4982 "different variable than update statement writes "
4983 "into at %L", &code->expr1->where);
4984 return;
4985 }
4986 expr2 = is_conversion (code->expr2, false);
4987 if (expr2 == NULL)
4988 expr2 = code->expr2;
4989 }
4990 break;
4991 default:
4992 break;
4993 }
4994
4995 if (gfc_expr_attr (code->expr1).allocatable)
4996 {
4997 gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L",
4998 &code->loc);
4999 return;
5000 }
5001
5002 if (aop == GFC_OMP_ATOMIC_CAPTURE
5003 && code->next == NULL
5004 && code->expr2->rank == 0
5005 && !expr_references_sym (code->expr2, var, NULL))
5006 atomic_code->ext.omp_atomic
5007 = (gfc_omp_atomic_op) (atomic_code->ext.omp_atomic
5008 | GFC_OMP_ATOMIC_SWAP);
5009 else if (expr2->expr_type == EXPR_OP)
5010 {
5011 gfc_expr *v = NULL, *e, *c;
5012 gfc_intrinsic_op op = expr2->value.op.op;
5013 gfc_intrinsic_op alt_op = INTRINSIC_NONE;
5014
5015 switch (op)
5016 {
5017 case INTRINSIC_PLUS:
5018 alt_op = INTRINSIC_MINUS;
5019 break;
5020 case INTRINSIC_TIMES:
5021 alt_op = INTRINSIC_DIVIDE;
5022 break;
5023 case INTRINSIC_MINUS:
5024 alt_op = INTRINSIC_PLUS;
5025 break;
5026 case INTRINSIC_DIVIDE:
5027 alt_op = INTRINSIC_TIMES;
5028 break;
5029 case INTRINSIC_AND:
5030 case INTRINSIC_OR:
5031 break;
5032 case INTRINSIC_EQV:
5033 alt_op = INTRINSIC_NEQV;
5034 break;
5035 case INTRINSIC_NEQV:
5036 alt_op = INTRINSIC_EQV;
5037 break;
5038 default:
5039 gfc_error ("!$OMP ATOMIC assignment operator must be binary "
5040 "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
5041 &expr2->where);
5042 return;
5043 }
5044
5045 /* Check for var = var op expr resp. var = expr op var where
5046 expr doesn't reference var and var op expr is mathematically
5047 equivalent to var op (expr) resp. expr op var equivalent to
5048 (expr) op var. We rely here on the fact that the matcher
5049 for x op1 y op2 z where op1 and op2 have equal precedence
5050 returns (x op1 y) op2 z. */
5051 e = expr2->value.op.op2;
5052 if (e->expr_type == EXPR_VARIABLE
5053 && e->symtree != NULL
5054 && e->symtree->n.sym == var)
5055 v = e;
5056 else if ((c = is_conversion (e, true)) != NULL
5057 && c->expr_type == EXPR_VARIABLE
5058 && c->symtree != NULL
5059 && c->symtree->n.sym == var)
5060 v = c;
5061 else
5062 {
5063 gfc_expr **p = NULL, **q;
5064 for (q = &expr2->value.op.op1; (e = *q) != NULL; )
5065 if (e->expr_type == EXPR_VARIABLE
5066 && e->symtree != NULL
5067 && e->symtree->n.sym == var)
5068 {
5069 v = e;
5070 break;
5071 }
5072 else if ((c = is_conversion (e, true)) != NULL)
5073 q = &e->value.function.actual->expr;
5074 else if (e->expr_type != EXPR_OP
5075 || (e->value.op.op != op
5076 && e->value.op.op != alt_op)
5077 || e->rank != 0)
5078 break;
5079 else
5080 {
5081 p = q;
5082 q = &e->value.op.op1;
5083 }
5084
5085 if (v == NULL)
5086 {
5087 gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
5088 "or var = expr op var at %L", &expr2->where);
5089 return;
5090 }
5091
5092 if (p != NULL)
5093 {
5094 e = *p;
5095 switch (e->value.op.op)
5096 {
5097 case INTRINSIC_MINUS:
5098 case INTRINSIC_DIVIDE:
5099 case INTRINSIC_EQV:
5100 case INTRINSIC_NEQV:
5101 gfc_error ("!$OMP ATOMIC var = var op expr not "
5102 "mathematically equivalent to var = var op "
5103 "(expr) at %L", &expr2->where);
5104 break;
5105 default:
5106 break;
5107 }
5108
5109 /* Canonicalize into var = var op (expr). */
5110 *p = e->value.op.op2;
5111 e->value.op.op2 = expr2;
5112 e->ts = expr2->ts;
5113 if (code->expr2 == expr2)
5114 code->expr2 = expr2 = e;
5115 else
5116 code->expr2->value.function.actual->expr = expr2 = e;
5117
5118 if (!gfc_compare_types (&expr2->value.op.op1->ts, &expr2->ts))
5119 {
5120 for (p = &expr2->value.op.op1; *p != v;
5121 p = &(*p)->value.function.actual->expr)
5122 ;
5123 *p = NULL;
5124 gfc_free_expr (expr2->value.op.op1);
5125 expr2->value.op.op1 = v;
5126 gfc_convert_type (v, &expr2->ts, 2);
5127 }
5128 }
5129 }
5130
5131 if (e->rank != 0 || expr_references_sym (code->expr2, var, v))
5132 {
5133 gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
5134 "must be scalar and cannot reference var at %L",
5135 &expr2->where);
5136 return;
5137 }
5138 }
5139 else if (expr2->expr_type == EXPR_FUNCTION
5140 && expr2->value.function.isym != NULL
5141 && expr2->value.function.esym == NULL
5142 && expr2->value.function.actual != NULL
5143 && expr2->value.function.actual->next != NULL)
5144 {
5145 gfc_actual_arglist *arg, *var_arg;
5146
5147 switch (expr2->value.function.isym->id)
5148 {
5149 case GFC_ISYM_MIN:
5150 case GFC_ISYM_MAX:
5151 break;
5152 case GFC_ISYM_IAND:
5153 case GFC_ISYM_IOR:
5154 case GFC_ISYM_IEOR:
5155 if (expr2->value.function.actual->next->next != NULL)
5156 {
5157 gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
5158 "or IEOR must have two arguments at %L",
5159 &expr2->where);
5160 return;
5161 }
5162 break;
5163 default:
5164 gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
5165 "MIN, MAX, IAND, IOR or IEOR at %L",
5166 &expr2->where);
5167 return;
5168 }
5169
5170 var_arg = NULL;
5171 for (arg = expr2->value.function.actual; arg; arg = arg->next)
5172 {
5173 if ((arg == expr2->value.function.actual
5174 || (var_arg == NULL && arg->next == NULL))
5175 && arg->expr->expr_type == EXPR_VARIABLE
5176 && arg->expr->symtree != NULL
5177 && arg->expr->symtree->n.sym == var)
5178 var_arg = arg;
5179 else if (expr_references_sym (arg->expr, var, NULL))
5180 {
5181 gfc_error ("!$OMP ATOMIC intrinsic arguments except one must "
5182 "not reference %qs at %L",
5183 var->name, &arg->expr->where);
5184 return;
5185 }
5186 if (arg->expr->rank != 0)
5187 {
5188 gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
5189 "at %L", &arg->expr->where);
5190 return;
5191 }
5192 }
5193
5194 if (var_arg == NULL)
5195 {
5196 gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
5197 "be %qs at %L", var->name, &expr2->where);
5198 return;
5199 }
5200
5201 if (var_arg != expr2->value.function.actual)
5202 {
5203 /* Canonicalize, so that var comes first. */
5204 gcc_assert (var_arg->next == NULL);
5205 for (arg = expr2->value.function.actual;
5206 arg->next != var_arg; arg = arg->next)
5207 ;
5208 var_arg->next = expr2->value.function.actual;
5209 expr2->value.function.actual = var_arg;
5210 arg->next = NULL;
5211 }
5212 }
5213 else
5214 gfc_error ("!$OMP ATOMIC assignment must have an operator or "
5215 "intrinsic on right hand side at %L", &expr2->where);
5216
5217 if (aop == GFC_OMP_ATOMIC_CAPTURE && code->next)
5218 {
5219 code = code->next;
5220 if (code->expr1->expr_type != EXPR_VARIABLE
5221 || code->expr1->symtree == NULL
5222 || code->expr1->rank != 0
5223 || (code->expr1->ts.type != BT_INTEGER
5224 && code->expr1->ts.type != BT_REAL
5225 && code->expr1->ts.type != BT_COMPLEX
5226 && code->expr1->ts.type != BT_LOGICAL))
5227 {
5228 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must set "
5229 "a scalar variable of intrinsic type at %L",
5230 &code->expr1->where);
5231 return;
5232 }
5233
5234 expr2 = is_conversion (code->expr2, false);
5235 if (expr2 == NULL)
5236 {
5237 expr2 = is_conversion (code->expr2, true);
5238 if (expr2 == NULL)
5239 expr2 = code->expr2;
5240 }
5241
5242 if (expr2->expr_type != EXPR_VARIABLE
5243 || expr2->symtree == NULL
5244 || expr2->rank != 0
5245 || (expr2->ts.type != BT_INTEGER
5246 && expr2->ts.type != BT_REAL
5247 && expr2->ts.type != BT_COMPLEX
5248 && expr2->ts.type != BT_LOGICAL))
5249 {
5250 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read "
5251 "from a scalar variable of intrinsic type at %L",
5252 &expr2->where);
5253 return;
5254 }
5255 if (expr2->symtree->n.sym != var)
5256 {
5257 gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
5258 "different variable than update statement writes "
5259 "into at %L", &expr2->where);
5260 return;
5261 }
5262 }
5263 }
5264
5265
5266 struct fortran_omp_context
5267 {
5268 gfc_code *code;
5269 hash_set<gfc_symbol *> *sharing_clauses;
5270 hash_set<gfc_symbol *> *private_iterators;
5271 struct fortran_omp_context *previous;
5272 bool is_openmp;
5273 } *omp_current_ctx;
5274 static gfc_code *omp_current_do_code;
5275 static int omp_current_do_collapse;
5276
5277 void
5278 gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
5279 {
5280 if (code->block->next && code->block->next->op == EXEC_DO)
5281 {
5282 int i;
5283 gfc_code *c;
5284
5285 omp_current_do_code = code->block->next;
5286 if (code->ext.omp_clauses->orderedc)
5287 omp_current_do_collapse = code->ext.omp_clauses->orderedc;
5288 else
5289 omp_current_do_collapse = code->ext.omp_clauses->collapse;
5290 for (i = 1, c = omp_current_do_code; i < omp_current_do_collapse; i++)
5291 {
5292 c = c->block;
5293 if (c->op != EXEC_DO || c->next == NULL)
5294 break;
5295 c = c->next;
5296 if (c->op != EXEC_DO)
5297 break;
5298 }
5299 if (i < omp_current_do_collapse || omp_current_do_collapse <= 0)
5300 omp_current_do_collapse = 1;
5301 }
5302 gfc_resolve_blocks (code->block, ns);
5303 omp_current_do_collapse = 0;
5304 omp_current_do_code = NULL;
5305 }
5306
5307
5308 void
5309 gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
5310 {
5311 struct fortran_omp_context ctx;
5312 gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
5313 gfc_omp_namelist *n;
5314 int list;
5315
5316 ctx.code = code;
5317 ctx.sharing_clauses = new hash_set<gfc_symbol *>;
5318 ctx.private_iterators = new hash_set<gfc_symbol *>;
5319 ctx.previous = omp_current_ctx;
5320 ctx.is_openmp = true;
5321 omp_current_ctx = &ctx;
5322
5323 for (list = 0; list < OMP_LIST_NUM; list++)
5324 switch (list)
5325 {
5326 case OMP_LIST_SHARED:
5327 case OMP_LIST_PRIVATE:
5328 case OMP_LIST_FIRSTPRIVATE:
5329 case OMP_LIST_LASTPRIVATE:
5330 case OMP_LIST_REDUCTION:
5331 case OMP_LIST_LINEAR:
5332 for (n = omp_clauses->lists[list]; n; n = n->next)
5333 ctx.sharing_clauses->add (n->sym);
5334 break;
5335 default:
5336 break;
5337 }
5338
5339 switch (code->op)
5340 {
5341 case EXEC_OMP_PARALLEL_DO:
5342 case EXEC_OMP_PARALLEL_DO_SIMD:
5343 case EXEC_OMP_TARGET_PARALLEL_DO:
5344 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
5345 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
5346 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
5347 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5348 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
5349 case EXEC_OMP_TEAMS_DISTRIBUTE:
5350 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
5351 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5352 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
5353 gfc_resolve_omp_do_blocks (code, ns);
5354 break;
5355 default:
5356 gfc_resolve_blocks (code->block, ns);
5357 }
5358
5359 omp_current_ctx = ctx.previous;
5360 delete ctx.sharing_clauses;
5361 delete ctx.private_iterators;
5362 }
5363
5364
5365 /* Save and clear openmp.c private state. */
5366
5367 void
5368 gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *state)
5369 {
5370 state->ptrs[0] = omp_current_ctx;
5371 state->ptrs[1] = omp_current_do_code;
5372 state->ints[0] = omp_current_do_collapse;
5373 omp_current_ctx = NULL;
5374 omp_current_do_code = NULL;
5375 omp_current_do_collapse = 0;
5376 }
5377
5378
5379 /* Restore openmp.c private state from the saved state. */
5380
5381 void
5382 gfc_omp_restore_state (struct gfc_omp_saved_state *state)
5383 {
5384 omp_current_ctx = (struct fortran_omp_context *) state->ptrs[0];
5385 omp_current_do_code = (gfc_code *) state->ptrs[1];
5386 omp_current_do_collapse = state->ints[0];
5387 }
5388
5389
5390 /* Note a DO iterator variable. This is special in !$omp parallel
5391 construct, where they are predetermined private. */
5392
5393 void
5394 gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym)
5395 {
5396 int i = omp_current_do_collapse;
5397 gfc_code *c = omp_current_do_code;
5398
5399 if (sym->attr.threadprivate)
5400 return;
5401
5402 /* !$omp do and !$omp parallel do iteration variable is predetermined
5403 private just in the !$omp do resp. !$omp parallel do construct,
5404 with no implications for the outer parallel constructs. */
5405
5406 while (i-- >= 1)
5407 {
5408 if (code == c)
5409 return;
5410
5411 c = c->block->next;
5412 }
5413
5414 if (omp_current_ctx == NULL)
5415 return;
5416
5417 /* An openacc context may represent a data clause. Abort if so. */
5418 if (!omp_current_ctx->is_openmp && !oacc_is_loop (omp_current_ctx->code))
5419 return;
5420
5421 if (omp_current_ctx->is_openmp
5422 && omp_current_ctx->sharing_clauses->contains (sym))
5423 return;
5424
5425 if (! omp_current_ctx->private_iterators->add (sym))
5426 {
5427 gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses;
5428 gfc_omp_namelist *p;
5429
5430 p = gfc_get_omp_namelist ();
5431 p->sym = sym;
5432 p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
5433 omp_clauses->lists[OMP_LIST_PRIVATE] = p;
5434 }
5435 }
5436
5437
5438 static void
5439 resolve_omp_do (gfc_code *code)
5440 {
5441 gfc_code *do_code, *c;
5442 int list, i, collapse;
5443 gfc_omp_namelist *n;
5444 gfc_symbol *dovar;
5445 const char *name;
5446 bool is_simd = false;
5447
5448 switch (code->op)
5449 {
5450 case EXEC_OMP_DISTRIBUTE: name = "!$OMP DISTRIBUTE"; break;
5451 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
5452 name = "!$OMP DISTRIBUTE PARALLEL DO";
5453 break;
5454 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
5455 name = "!$OMP DISTRIBUTE PARALLEL DO SIMD";
5456 is_simd = true;
5457 break;
5458 case EXEC_OMP_DISTRIBUTE_SIMD:
5459 name = "!$OMP DISTRIBUTE SIMD";
5460 is_simd = true;
5461 break;
5462 case EXEC_OMP_DO: name = "!$OMP DO"; break;
5463 case EXEC_OMP_DO_SIMD: name = "!$OMP DO SIMD"; is_simd = true; break;
5464 case EXEC_OMP_PARALLEL_DO: name = "!$OMP PARALLEL DO"; break;
5465 case EXEC_OMP_PARALLEL_DO_SIMD:
5466 name = "!$OMP PARALLEL DO SIMD";
5467 is_simd = true;
5468 break;
5469 case EXEC_OMP_SIMD: name = "!$OMP SIMD"; is_simd = true; break;
5470 case EXEC_OMP_TARGET_PARALLEL_DO: name = "!$OMP TARGET PARALLEL DO"; break;
5471 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
5472 name = "!$OMP TARGET PARALLEL DO SIMD";
5473 is_simd = true;
5474 break;
5475 case EXEC_OMP_TARGET_SIMD:
5476 name = "!$OMP TARGET SIMD";
5477 is_simd = true;
5478 break;
5479 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
5480 name = "!$OMP TARGET TEAMS DISTRIBUTE";
5481 break;
5482 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
5483 name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
5484 break;
5485 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5486 name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
5487 is_simd = true;
5488 break;
5489 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
5490 name = "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
5491 is_simd = true;
5492 break;
5493 case EXEC_OMP_TASKLOOP: name = "!$OMP TASKLOOP"; break;
5494 case EXEC_OMP_TASKLOOP_SIMD:
5495 name = "!$OMP TASKLOOP SIMD";
5496 is_simd = true;
5497 break;
5498 case EXEC_OMP_TEAMS_DISTRIBUTE: name = "!$OMP TEAMS DISTRIBUTE"; break;
5499 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
5500 name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
5501 break;
5502 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5503 name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
5504 is_simd = true;
5505 break;
5506 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
5507 name = "!$OMP TEAMS DISTRIBUTE SIMD";
5508 is_simd = true;
5509 break;
5510 default: gcc_unreachable ();
5511 }
5512
5513 if (code->ext.omp_clauses)
5514 resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
5515
5516 do_code = code->block->next;
5517 if (code->ext.omp_clauses->orderedc)
5518 collapse = code->ext.omp_clauses->orderedc;
5519 else
5520 {
5521 collapse = code->ext.omp_clauses->collapse;
5522 if (collapse <= 0)
5523 collapse = 1;
5524 }
5525 for (i = 1; i <= collapse; i++)
5526 {
5527 if (do_code->op == EXEC_DO_WHILE)
5528 {
5529 gfc_error ("%s cannot be a DO WHILE or DO without loop control "
5530 "at %L", name, &do_code->loc);
5531 break;
5532 }
5533 if (do_code->op == EXEC_DO_CONCURRENT)
5534 {
5535 gfc_error ("%s cannot be a DO CONCURRENT loop at %L", name,
5536 &do_code->loc);
5537 break;
5538 }
5539 gcc_assert (do_code->op == EXEC_DO);
5540 if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
5541 gfc_error ("%s iteration variable must be of type integer at %L",
5542 name, &do_code->loc);
5543 dovar = do_code->ext.iterator->var->symtree->n.sym;
5544 if (dovar->attr.threadprivate)
5545 gfc_error ("%s iteration variable must not be THREADPRIVATE "
5546 "at %L", name, &do_code->loc);
5547 if (code->ext.omp_clauses)
5548 for (list = 0; list < OMP_LIST_NUM; list++)
5549 if (!is_simd
5550 ? (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE)
5551 : code->ext.omp_clauses->collapse > 1
5552 ? (list != OMP_LIST_LASTPRIVATE)
5553 : (list != OMP_LIST_LINEAR))
5554 for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
5555 if (dovar == n->sym)
5556 {
5557 if (!is_simd)
5558 gfc_error ("%s iteration variable present on clause "
5559 "other than PRIVATE or LASTPRIVATE at %L",
5560 name, &do_code->loc);
5561 else if (code->ext.omp_clauses->collapse > 1)
5562 gfc_error ("%s iteration variable present on clause "
5563 "other than LASTPRIVATE at %L",
5564 name, &do_code->loc);
5565 else
5566 gfc_error ("%s iteration variable present on clause "
5567 "other than LINEAR at %L",
5568 name, &do_code->loc);
5569 break;
5570 }
5571 if (i > 1)
5572 {
5573 gfc_code *do_code2 = code->block->next;
5574 int j;
5575
5576 for (j = 1; j < i; j++)
5577 {
5578 gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
5579 if (dovar == ivar
5580 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
5581 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
5582 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
5583 {
5584 gfc_error ("%s collapsed loops don't form rectangular "
5585 "iteration space at %L", name, &do_code->loc);
5586 break;
5587 }
5588 if (j < i)
5589 break;
5590 do_code2 = do_code2->block->next;
5591 }
5592 }
5593 if (i == collapse)
5594 break;
5595 for (c = do_code->next; c; c = c->next)
5596 if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
5597 {
5598 gfc_error ("collapsed %s loops not perfectly nested at %L",
5599 name, &c->loc);
5600 break;
5601 }
5602 if (c)
5603 break;
5604 do_code = do_code->block;
5605 if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE)
5606 {
5607 gfc_error ("not enough DO loops for collapsed %s at %L",
5608 name, &code->loc);
5609 break;
5610 }
5611 do_code = do_code->next;
5612 if (do_code == NULL
5613 || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE))
5614 {
5615 gfc_error ("not enough DO loops for collapsed %s at %L",
5616 name, &code->loc);
5617 break;
5618 }
5619 }
5620 }
5621
5622 static bool
5623 oacc_is_parallel (gfc_code *code)
5624 {
5625 return code->op == EXEC_OACC_PARALLEL || code->op == EXEC_OACC_PARALLEL_LOOP;
5626 }
5627
5628 static bool
5629 oacc_is_kernels (gfc_code *code)
5630 {
5631 return code->op == EXEC_OACC_KERNELS || code->op == EXEC_OACC_KERNELS_LOOP;
5632 }
5633
5634 static gfc_statement
5635 omp_code_to_statement (gfc_code *code)
5636 {
5637 switch (code->op)
5638 {
5639 case EXEC_OMP_PARALLEL:
5640 return ST_OMP_PARALLEL;
5641 case EXEC_OMP_PARALLEL_SECTIONS:
5642 return ST_OMP_PARALLEL_SECTIONS;
5643 case EXEC_OMP_SECTIONS:
5644 return ST_OMP_SECTIONS;
5645 case EXEC_OMP_ORDERED:
5646 return ST_OMP_ORDERED;
5647 case EXEC_OMP_CRITICAL:
5648 return ST_OMP_CRITICAL;
5649 case EXEC_OMP_MASTER:
5650 return ST_OMP_MASTER;
5651 case EXEC_OMP_SINGLE:
5652 return ST_OMP_SINGLE;
5653 case EXEC_OMP_TASK:
5654 return ST_OMP_TASK;
5655 case EXEC_OMP_WORKSHARE:
5656 return ST_OMP_WORKSHARE;
5657 case EXEC_OMP_PARALLEL_WORKSHARE:
5658 return ST_OMP_PARALLEL_WORKSHARE;
5659 case EXEC_OMP_DO:
5660 return ST_OMP_DO;
5661 default:
5662 gcc_unreachable ();
5663 }
5664 }
5665
5666 static gfc_statement
5667 oacc_code_to_statement (gfc_code *code)
5668 {
5669 switch (code->op)
5670 {
5671 case EXEC_OACC_PARALLEL:
5672 return ST_OACC_PARALLEL;
5673 case EXEC_OACC_KERNELS:
5674 return ST_OACC_KERNELS;
5675 case EXEC_OACC_DATA:
5676 return ST_OACC_DATA;
5677 case EXEC_OACC_HOST_DATA:
5678 return ST_OACC_HOST_DATA;
5679 case EXEC_OACC_PARALLEL_LOOP:
5680 return ST_OACC_PARALLEL_LOOP;
5681 case EXEC_OACC_KERNELS_LOOP:
5682 return ST_OACC_KERNELS_LOOP;
5683 case EXEC_OACC_LOOP:
5684 return ST_OACC_LOOP;
5685 case EXEC_OACC_ATOMIC:
5686 return ST_OACC_ATOMIC;
5687 default:
5688 gcc_unreachable ();
5689 }
5690 }
5691
5692 static void
5693 resolve_oacc_directive_inside_omp_region (gfc_code *code)
5694 {
5695 if (omp_current_ctx != NULL && omp_current_ctx->is_openmp)
5696 {
5697 gfc_statement st = omp_code_to_statement (omp_current_ctx->code);
5698 gfc_statement oacc_st = oacc_code_to_statement (code);
5699 gfc_error ("The %s directive cannot be specified within "
5700 "a %s region at %L", gfc_ascii_statement (oacc_st),
5701 gfc_ascii_statement (st), &code->loc);
5702 }
5703 }
5704
5705 static void
5706 resolve_omp_directive_inside_oacc_region (gfc_code *code)
5707 {
5708 if (omp_current_ctx != NULL && !omp_current_ctx->is_openmp)
5709 {
5710 gfc_statement st = oacc_code_to_statement (omp_current_ctx->code);
5711 gfc_statement omp_st = omp_code_to_statement (code);
5712 gfc_error ("The %s directive cannot be specified within "
5713 "a %s region at %L", gfc_ascii_statement (omp_st),
5714 gfc_ascii_statement (st), &code->loc);
5715 }
5716 }
5717
5718
5719 static void
5720 resolve_oacc_nested_loops (gfc_code *code, gfc_code* do_code, int collapse,
5721 const char *clause)
5722 {
5723 gfc_symbol *dovar;
5724 gfc_code *c;
5725 int i;
5726
5727 for (i = 1; i <= collapse; i++)
5728 {
5729 if (do_code->op == EXEC_DO_WHILE)
5730 {
5731 gfc_error ("!$ACC LOOP cannot be a DO WHILE or DO without loop control "
5732 "at %L", &do_code->loc);
5733 break;
5734 }
5735 gcc_assert (do_code->op == EXEC_DO || do_code->op == EXEC_DO_CONCURRENT);
5736 if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
5737 gfc_error ("!$ACC LOOP iteration variable must be of type integer at %L",
5738 &do_code->loc);
5739 dovar = do_code->ext.iterator->var->symtree->n.sym;
5740 if (i > 1)
5741 {
5742 gfc_code *do_code2 = code->block->next;
5743 int j;
5744
5745 for (j = 1; j < i; j++)
5746 {
5747 gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
5748 if (dovar == ivar
5749 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
5750 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
5751 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
5752 {
5753 gfc_error ("!$ACC LOOP %s loops don't form rectangular iteration space at %L",
5754 clause, &do_code->loc);
5755 break;
5756 }
5757 if (j < i)
5758 break;
5759 do_code2 = do_code2->block->next;
5760 }
5761 }
5762 if (i == collapse)
5763 break;
5764 for (c = do_code->next; c; c = c->next)
5765 if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
5766 {
5767 gfc_error ("%s !$ACC LOOP loops not perfectly nested at %L",
5768 clause, &c->loc);
5769 break;
5770 }
5771 if (c)
5772 break;
5773 do_code = do_code->block;
5774 if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
5775 && do_code->op != EXEC_DO_CONCURRENT)
5776 {
5777 gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
5778 clause, &code->loc);
5779 break;
5780 }
5781 do_code = do_code->next;
5782 if (do_code == NULL
5783 || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
5784 && do_code->op != EXEC_DO_CONCURRENT))
5785 {
5786 gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
5787 clause, &code->loc);
5788 break;
5789 }
5790 }
5791 }
5792
5793
5794 static void
5795 resolve_oacc_params_in_parallel (gfc_code *code, const char *clause,
5796 const char *arg)
5797 {
5798 fortran_omp_context *c;
5799
5800 if (oacc_is_parallel (code))
5801 gfc_error ("!$ACC LOOP %s in PARALLEL region doesn't allow "
5802 "%s arguments at %L", clause, arg, &code->loc);
5803 for (c = omp_current_ctx; c; c = c->previous)
5804 {
5805 if (oacc_is_loop (c->code))
5806 break;
5807 if (oacc_is_parallel (c->code))
5808 gfc_error ("!$ACC LOOP %s in PARALLEL region doesn't allow "
5809 "%s arguments at %L", clause, arg, &code->loc);
5810 }
5811 }
5812
5813
5814 static void
5815 resolve_oacc_loop_blocks (gfc_code *code)
5816 {
5817 fortran_omp_context *c;
5818
5819 if (!oacc_is_loop (code))
5820 return;
5821
5822 if (code->op == EXEC_OACC_LOOP)
5823 for (c = omp_current_ctx; c; c = c->previous)
5824 {
5825 if (oacc_is_loop (c->code))
5826 {
5827 if (code->ext.omp_clauses->gang)
5828 {
5829 if (c->code->ext.omp_clauses->gang)
5830 gfc_error ("Loop parallelized across gangs is not allowed "
5831 "inside another loop parallelized across gangs at %L",
5832 &code->loc);
5833 if (c->code->ext.omp_clauses->worker)
5834 gfc_error ("Loop parallelized across gangs is not allowed "
5835 "inside loop parallelized across workers at %L",
5836 &code->loc);
5837 if (c->code->ext.omp_clauses->vector)
5838 gfc_error ("Loop parallelized across gangs is not allowed "
5839 "inside loop parallelized across workers at %L",
5840 &code->loc);
5841 }
5842 if (code->ext.omp_clauses->worker)
5843 {
5844 if (c->code->ext.omp_clauses->worker)
5845 gfc_error ("Loop parallelized across workers is not allowed "
5846 "inside another loop parallelized across workers at %L",
5847 &code->loc);
5848 if (c->code->ext.omp_clauses->vector)
5849 gfc_error ("Loop parallelized across workers is not allowed "
5850 "inside another loop parallelized across vectors at %L",
5851 &code->loc);
5852 }
5853 if (code->ext.omp_clauses->vector)
5854 if (c->code->ext.omp_clauses->vector)
5855 gfc_error ("Loop parallelized across vectors is not allowed "
5856 "inside another loop parallelized across vectors at %L",
5857 &code->loc);
5858 }
5859
5860 if (oacc_is_parallel (c->code) || oacc_is_kernels (c->code))
5861 break;
5862 }
5863
5864 if (code->ext.omp_clauses->seq)
5865 {
5866 if (code->ext.omp_clauses->independent)
5867 gfc_error ("Clause SEQ conflicts with INDEPENDENT at %L", &code->loc);
5868 if (code->ext.omp_clauses->gang)
5869 gfc_error ("Clause SEQ conflicts with GANG at %L", &code->loc);
5870 if (code->ext.omp_clauses->worker)
5871 gfc_error ("Clause SEQ conflicts with WORKER at %L", &code->loc);
5872 if (code->ext.omp_clauses->vector)
5873 gfc_error ("Clause SEQ conflicts with VECTOR at %L", &code->loc);
5874 if (code->ext.omp_clauses->par_auto)
5875 gfc_error ("Clause SEQ conflicts with AUTO at %L", &code->loc);
5876 }
5877 if (code->ext.omp_clauses->par_auto)
5878 {
5879 if (code->ext.omp_clauses->gang)
5880 gfc_error ("Clause AUTO conflicts with GANG at %L", &code->loc);
5881 if (code->ext.omp_clauses->worker)
5882 gfc_error ("Clause AUTO conflicts with WORKER at %L", &code->loc);
5883 if (code->ext.omp_clauses->vector)
5884 gfc_error ("Clause AUTO conflicts with VECTOR at %L", &code->loc);
5885 }
5886 if (code->ext.omp_clauses->tile_list && code->ext.omp_clauses->gang
5887 && code->ext.omp_clauses->worker && code->ext.omp_clauses->vector)
5888 gfc_error ("Tiled loop cannot be parallelized across gangs, workers and "
5889 "vectors at the same time at %L", &code->loc);
5890
5891 if (code->ext.omp_clauses->gang
5892 && code->ext.omp_clauses->gang_num_expr)
5893 resolve_oacc_params_in_parallel (code, "GANG", "num");
5894
5895 if (code->ext.omp_clauses->worker
5896 && code->ext.omp_clauses->worker_expr)
5897 resolve_oacc_params_in_parallel (code, "WORKER", "num");
5898
5899 if (code->ext.omp_clauses->vector
5900 && code->ext.omp_clauses->vector_expr)
5901 resolve_oacc_params_in_parallel (code, "VECTOR", "length");
5902
5903 if (code->ext.omp_clauses->tile_list)
5904 {
5905 gfc_expr_list *el;
5906 int num = 0;
5907 for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
5908 {
5909 num++;
5910 if (el->expr == NULL)
5911 {
5912 /* NULL expressions are used to represent '*' arguments.
5913 Convert those to a 0 expressions. */
5914 el->expr = gfc_get_constant_expr (BT_INTEGER,
5915 gfc_default_integer_kind,
5916 &code->loc);
5917 mpz_set_si (el->expr->value.integer, 0);
5918 }
5919 else
5920 {
5921 resolve_positive_int_expr (el->expr, "TILE");
5922 if (el->expr->expr_type != EXPR_CONSTANT)
5923 gfc_error ("TILE requires constant expression at %L",
5924 &code->loc);
5925 }
5926 }
5927 resolve_oacc_nested_loops (code, code->block->next, num, "tiled");
5928 }
5929 }
5930
5931
5932 void
5933 gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns)
5934 {
5935 fortran_omp_context ctx;
5936
5937 resolve_oacc_loop_blocks (code);
5938
5939 ctx.code = code;
5940 ctx.sharing_clauses = NULL;
5941 ctx.private_iterators = new hash_set<gfc_symbol *>;
5942 ctx.previous = omp_current_ctx;
5943 ctx.is_openmp = false;
5944 omp_current_ctx = &ctx;
5945
5946 gfc_resolve_blocks (code->block, ns);
5947
5948 omp_current_ctx = ctx.previous;
5949 delete ctx.private_iterators;
5950 }
5951
5952
5953 static void
5954 resolve_oacc_loop (gfc_code *code)
5955 {
5956 gfc_code *do_code;
5957 int collapse;
5958
5959 if (code->ext.omp_clauses)
5960 resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
5961
5962 do_code = code->block->next;
5963 collapse = code->ext.omp_clauses->collapse;
5964
5965 if (collapse <= 0)
5966 collapse = 1;
5967 resolve_oacc_nested_loops (code, do_code, collapse, "collapsed");
5968 }
5969
5970 void
5971 gfc_resolve_oacc_declare (gfc_namespace *ns)
5972 {
5973 int list;
5974 gfc_omp_namelist *n;
5975 gfc_oacc_declare *oc;
5976
5977 if (ns->oacc_declare == NULL)
5978 return;
5979
5980 for (oc = ns->oacc_declare; oc; oc = oc->next)
5981 {
5982 for (list = 0; list < OMP_LIST_NUM; list++)
5983 for (n = oc->clauses->lists[list]; n; n = n->next)
5984 {
5985 n->sym->mark = 0;
5986 if (n->sym->attr.flavor == FL_PARAMETER)
5987 {
5988 gfc_error ("PARAMETER object %qs is not allowed at %L",
5989 n->sym->name, &oc->loc);
5990 continue;
5991 }
5992
5993 if (n->expr && n->expr->ref->type == REF_ARRAY)
5994 {
5995 gfc_error ("Array sections: %qs not allowed in"
5996 " !$ACC DECLARE at %L", n->sym->name, &oc->loc);
5997 continue;
5998 }
5999 }
6000
6001 for (n = oc->clauses->lists[OMP_LIST_DEVICE_RESIDENT]; n; n = n->next)
6002 check_array_not_assumed (n->sym, oc->loc, "DEVICE_RESIDENT");
6003 }
6004
6005 for (oc = ns->oacc_declare; oc; oc = oc->next)
6006 {
6007 for (list = 0; list < OMP_LIST_NUM; list++)
6008 for (n = oc->clauses->lists[list]; n; n = n->next)
6009 {
6010 if (n->sym->mark)
6011 {
6012 gfc_error ("Symbol %qs present on multiple clauses at %L",
6013 n->sym->name, &oc->loc);
6014 continue;
6015 }
6016 else
6017 n->sym->mark = 1;
6018 }
6019 }
6020
6021 for (oc = ns->oacc_declare; oc; oc = oc->next)
6022 {
6023 for (list = 0; list < OMP_LIST_NUM; list++)
6024 for (n = oc->clauses->lists[list]; n; n = n->next)
6025 n->sym->mark = 0;
6026 }
6027 }
6028
6029 void
6030 gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
6031 {
6032 resolve_oacc_directive_inside_omp_region (code);
6033
6034 switch (code->op)
6035 {
6036 case EXEC_OACC_PARALLEL:
6037 case EXEC_OACC_KERNELS:
6038 case EXEC_OACC_DATA:
6039 case EXEC_OACC_HOST_DATA:
6040 case EXEC_OACC_UPDATE:
6041 case EXEC_OACC_ENTER_DATA:
6042 case EXEC_OACC_EXIT_DATA:
6043 case EXEC_OACC_WAIT:
6044 case EXEC_OACC_CACHE:
6045 resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
6046 break;
6047 case EXEC_OACC_PARALLEL_LOOP:
6048 case EXEC_OACC_KERNELS_LOOP:
6049 case EXEC_OACC_LOOP:
6050 resolve_oacc_loop (code);
6051 break;
6052 case EXEC_OACC_ATOMIC:
6053 resolve_omp_atomic (code);
6054 break;
6055 default:
6056 break;
6057 }
6058 }
6059
6060
6061 /* Resolve OpenMP directive clauses and check various requirements
6062 of each directive. */
6063
6064 void
6065 gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
6066 {
6067 resolve_omp_directive_inside_oacc_region (code);
6068
6069 if (code->op != EXEC_OMP_ATOMIC)
6070 gfc_maybe_initialize_eh ();
6071
6072 switch (code->op)
6073 {
6074 case EXEC_OMP_DISTRIBUTE:
6075 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
6076 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
6077 case EXEC_OMP_DISTRIBUTE_SIMD:
6078 case EXEC_OMP_DO:
6079 case EXEC_OMP_DO_SIMD:
6080 case EXEC_OMP_PARALLEL_DO:
6081 case EXEC_OMP_PARALLEL_DO_SIMD:
6082 case EXEC_OMP_SIMD:
6083 case EXEC_OMP_TARGET_PARALLEL_DO:
6084 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
6085 case EXEC_OMP_TARGET_SIMD:
6086 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
6087 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
6088 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
6089 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
6090 case EXEC_OMP_TASKLOOP:
6091 case EXEC_OMP_TASKLOOP_SIMD:
6092 case EXEC_OMP_TEAMS_DISTRIBUTE:
6093 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
6094 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
6095 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
6096 resolve_omp_do (code);
6097 break;
6098 case EXEC_OMP_CANCEL:
6099 case EXEC_OMP_PARALLEL_WORKSHARE:
6100 case EXEC_OMP_PARALLEL:
6101 case EXEC_OMP_PARALLEL_SECTIONS:
6102 case EXEC_OMP_SECTIONS:
6103 case EXEC_OMP_SINGLE:
6104 case EXEC_OMP_TARGET:
6105 case EXEC_OMP_TARGET_DATA:
6106 case EXEC_OMP_TARGET_ENTER_DATA:
6107 case EXEC_OMP_TARGET_EXIT_DATA:
6108 case EXEC_OMP_TARGET_PARALLEL:
6109 case EXEC_OMP_TARGET_TEAMS:
6110 case EXEC_OMP_TASK:
6111 case EXEC_OMP_TEAMS:
6112 case EXEC_OMP_WORKSHARE:
6113 if (code->ext.omp_clauses)
6114 resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
6115 break;
6116 case EXEC_OMP_TARGET_UPDATE:
6117 if (code->ext.omp_clauses)
6118 resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
6119 if (code->ext.omp_clauses == NULL
6120 || (code->ext.omp_clauses->lists[OMP_LIST_TO] == NULL
6121 && code->ext.omp_clauses->lists[OMP_LIST_FROM] == NULL))
6122 gfc_error ("OMP TARGET UPDATE at %L requires at least one TO or "
6123 "FROM clause", &code->loc);
6124 break;
6125 case EXEC_OMP_ATOMIC:
6126 resolve_omp_atomic (code);
6127 break;
6128 default:
6129 break;
6130 }
6131 }
6132
6133 /* Resolve !$omp declare simd constructs in NS. */
6134
6135 void
6136 gfc_resolve_omp_declare_simd (gfc_namespace *ns)
6137 {
6138 gfc_omp_declare_simd *ods;
6139
6140 for (ods = ns->omp_declare_simd; ods; ods = ods->next)
6141 {
6142 if (ods->proc_name != NULL
6143 && ods->proc_name != ns->proc_name)
6144 gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure "
6145 "%qs at %L", ns->proc_name->name, &ods->where);
6146 if (ods->clauses)
6147 resolve_omp_clauses (NULL, ods->clauses, ns);
6148 }
6149 }
6150
6151 struct omp_udr_callback_data
6152 {
6153 gfc_omp_udr *omp_udr;
6154 bool is_initializer;
6155 };
6156
6157 static int
6158 omp_udr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
6159 void *data)
6160 {
6161 struct omp_udr_callback_data *cd = (struct omp_udr_callback_data *) data;
6162 if ((*e)->expr_type == EXPR_VARIABLE)
6163 {
6164 if (cd->is_initializer)
6165 {
6166 if ((*e)->symtree->n.sym != cd->omp_udr->omp_priv
6167 && (*e)->symtree->n.sym != cd->omp_udr->omp_orig)
6168 gfc_error ("Variable other than OMP_PRIV or OMP_ORIG used in "
6169 "INITIALIZER clause of !$OMP DECLARE REDUCTION at %L",
6170 &(*e)->where);
6171 }
6172 else
6173 {
6174 if ((*e)->symtree->n.sym != cd->omp_udr->omp_out
6175 && (*e)->symtree->n.sym != cd->omp_udr->omp_in)
6176 gfc_error ("Variable other than OMP_OUT or OMP_IN used in "
6177 "combiner of !$OMP DECLARE REDUCTION at %L",
6178 &(*e)->where);
6179 }
6180 }
6181 return 0;
6182 }
6183
6184 /* Resolve !$omp declare reduction constructs. */
6185
6186 static void
6187 gfc_resolve_omp_udr (gfc_omp_udr *omp_udr)
6188 {
6189 gfc_actual_arglist *a;
6190 const char *predef_name = NULL;
6191
6192 switch (omp_udr->rop)
6193 {
6194 case OMP_REDUCTION_PLUS:
6195 case OMP_REDUCTION_TIMES:
6196 case OMP_REDUCTION_MINUS:
6197 case OMP_REDUCTION_AND:
6198 case OMP_REDUCTION_OR:
6199 case OMP_REDUCTION_EQV:
6200 case OMP_REDUCTION_NEQV:
6201 case OMP_REDUCTION_MAX:
6202 case OMP_REDUCTION_USER:
6203 break;
6204 default:
6205 gfc_error ("Invalid operator for !$OMP DECLARE REDUCTION %s at %L",
6206 omp_udr->name, &omp_udr->where);
6207 return;
6208 }
6209
6210 if (gfc_omp_udr_predef (omp_udr->rop, omp_udr->name,
6211 &omp_udr->ts, &predef_name))
6212 {
6213 if (predef_name)
6214 gfc_error_now ("Redefinition of predefined %s "
6215 "!$OMP DECLARE REDUCTION at %L",
6216 predef_name, &omp_udr->where);
6217 else
6218 gfc_error_now ("Redefinition of predefined "
6219 "!$OMP DECLARE REDUCTION at %L", &omp_udr->where);
6220 return;
6221 }
6222
6223 if (omp_udr->ts.type == BT_CHARACTER
6224 && omp_udr->ts.u.cl->length
6225 && omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
6226 {
6227 gfc_error ("CHARACTER length in !$OMP DECLARE REDUCTION %s not "
6228 "constant at %L", omp_udr->name, &omp_udr->where);
6229 return;
6230 }
6231
6232 struct omp_udr_callback_data cd;
6233 cd.omp_udr = omp_udr;
6234 cd.is_initializer = false;
6235 gfc_code_walker (&omp_udr->combiner_ns->code, gfc_dummy_code_callback,
6236 omp_udr_callback, &cd);
6237 if (omp_udr->combiner_ns->code->op == EXEC_CALL)
6238 {
6239 for (a = omp_udr->combiner_ns->code->ext.actual; a; a = a->next)
6240 if (a->expr == NULL)
6241 break;
6242 if (a)
6243 gfc_error ("Subroutine call with alternate returns in combiner "
6244 "of !$OMP DECLARE REDUCTION at %L",
6245 &omp_udr->combiner_ns->code->loc);
6246 }
6247 if (omp_udr->initializer_ns)
6248 {
6249 cd.is_initializer = true;
6250 gfc_code_walker (&omp_udr->initializer_ns->code, gfc_dummy_code_callback,
6251 omp_udr_callback, &cd);
6252 if (omp_udr->initializer_ns->code->op == EXEC_CALL)
6253 {
6254 for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
6255 if (a->expr == NULL)
6256 break;
6257 if (a)
6258 gfc_error ("Subroutine call with alternate returns in "
6259 "INITIALIZER clause of !$OMP DECLARE REDUCTION "
6260 "at %L", &omp_udr->initializer_ns->code->loc);
6261 for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
6262 if (a->expr
6263 && a->expr->expr_type == EXPR_VARIABLE
6264 && a->expr->symtree->n.sym == omp_udr->omp_priv
6265 && a->expr->ref == NULL)
6266 break;
6267 if (a == NULL)
6268 gfc_error ("One of actual subroutine arguments in INITIALIZER "
6269 "clause of !$OMP DECLARE REDUCTION must be OMP_PRIV "
6270 "at %L", &omp_udr->initializer_ns->code->loc);
6271 }
6272 }
6273 else if (omp_udr->ts.type == BT_DERIVED
6274 && !gfc_has_default_initializer (omp_udr->ts.u.derived))
6275 {
6276 gfc_error ("Missing INITIALIZER clause for !$OMP DECLARE REDUCTION "
6277 "of derived type without default initializer at %L",
6278 &omp_udr->where);
6279 return;
6280 }
6281 }
6282
6283 void
6284 gfc_resolve_omp_udrs (gfc_symtree *st)
6285 {
6286 gfc_omp_udr *omp_udr;
6287
6288 if (st == NULL)
6289 return;
6290 gfc_resolve_omp_udrs (st->left);
6291 gfc_resolve_omp_udrs (st->right);
6292 for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
6293 gfc_resolve_omp_udr (omp_udr);
6294 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org