?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
PR rtl-optimization/82913
[official-gcc.git] / gcc / fortran / openmp.c
blob2606323d42a71584ec45e4302c4351495ec94015
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 {
2190 gfc_error ("WAIT clause at %L requires a scalar INTEGER expression",
2191 &el->expr->where);
2192
2193 return MATCH_ERROR;
2194 }
2195 }
2196 c->wait_list = wait_list;
2197 new_st.op = EXEC_OACC_WAIT;
2198 new_st.ext.omp_clauses = c;
2199 return MATCH_YES;
2200 }
2201
2202
2203 match
2204 gfc_match_oacc_cache (void)
2205 {
2206 gfc_omp_clauses *c = gfc_get_omp_clauses ();
2207 /* The OpenACC cache directive explicitly only allows "array elements or
2208 subarrays", which we're currently not checking here. Either check this
2209 after the call of gfc_match_omp_variable_list, or add something like a
2210 only_sections variant next to its allow_sections parameter. */
2211 match m = gfc_match_omp_variable_list (" (",
2212 &c->lists[OMP_LIST_CACHE], true,
2213 NULL, NULL, true);
2214 if (m != MATCH_YES)
2215 {
2216 gfc_free_omp_clauses(c);
2217 return m;
2218 }
2219
2220 if (gfc_current_state() != COMP_DO
2221 && gfc_current_state() != COMP_DO_CONCURRENT)
2222 {
2223 gfc_error ("ACC CACHE directive must be inside of loop %C");
2224 gfc_free_omp_clauses(c);
2225 return MATCH_ERROR;
2226 }
2227
2228 new_st.op = EXEC_OACC_CACHE;
2229 new_st.ext.omp_clauses = c;
2230 return MATCH_YES;
2231 }
2232
2233 /* Determine the loop level for a routine. */
2234
2235 static int
2236 gfc_oacc_routine_dims (gfc_omp_clauses *clauses)
2237 {
2238 int level = -1;
2239
2240 if (clauses)
2241 {
2242 unsigned mask = 0;
2243
2244 if (clauses->gang)
2245 level = GOMP_DIM_GANG, mask |= GOMP_DIM_MASK (level);
2246 if (clauses->worker)
2247 level = GOMP_DIM_WORKER, mask |= GOMP_DIM_MASK (level);
2248 if (clauses->vector)
2249 level = GOMP_DIM_VECTOR, mask |= GOMP_DIM_MASK (level);
2250 if (clauses->seq)
2251 level = GOMP_DIM_MAX, mask |= GOMP_DIM_MASK (level);
2252
2253 if (mask != (mask & -mask))
2254 gfc_error ("Multiple loop axes specified for routine");
2255 }
2256
2257 if (level < 0)
2258 level = GOMP_DIM_MAX;
2259
2260 return level;
2261 }
2262
2263 match
2264 gfc_match_oacc_routine (void)
2265 {
2266 locus old_loc;
2267 gfc_symbol *sym = NULL;
2268 match m;
2269 gfc_omp_clauses *c = NULL;
2270 gfc_oacc_routine_name *n = NULL;
2271
2272 old_loc = gfc_current_locus;
2273
2274 m = gfc_match (" (");
2275
2276 if (gfc_current_ns->proc_name
2277 && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
2278 && m == MATCH_YES)
2279 {
2280 gfc_error ("Only the !$ACC ROUTINE form without "
2281 "list is allowed in interface block at %C");
2282 goto cleanup;
2283 }
2284
2285 if (m == MATCH_YES)
2286 {
2287 char buffer[GFC_MAX_SYMBOL_LEN + 1];
2288 gfc_symtree *st;
2289
2290 m = gfc_match_name (buffer);
2291 if (m == MATCH_YES)
2292 {
2293 st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);
2294 if (st)
2295 {
2296 sym = st->n.sym;
2297 if (gfc_current_ns->proc_name != NULL
2298 && strcmp (sym->name, gfc_current_ns->proc_name->name) == 0)
2299 sym = NULL;
2300 }
2301
2302 if (st == NULL
2303 || (sym
2304 && !sym->attr.external
2305 && !sym->attr.function
2306 && !sym->attr.subroutine))
2307 {
2308 gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, "
2309 "invalid function name %s",
2310 (sym) ? sym->name : buffer);
2311 gfc_current_locus = old_loc;
2312 return MATCH_ERROR;
2313 }
2314 }
2315 else
2316 {
2317 gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C");
2318 gfc_current_locus = old_loc;
2319 return MATCH_ERROR;
2320 }
2321
2322 if (gfc_match_char (')') != MATCH_YES)
2323 {
2324 gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting"
2325 " ')' after NAME");
2326 gfc_current_locus = old_loc;
2327 return MATCH_ERROR;
2328 }
2329 }
2330
2331 if (gfc_match_omp_eos () != MATCH_YES
2332 && (gfc_match_omp_clauses (&c, OACC_ROUTINE_CLAUSES, false, false, true)
2333 != MATCH_YES))
2334 return MATCH_ERROR;
2335
2336 if (sym != NULL)
2337 {
2338 n = gfc_get_oacc_routine_name ();
2339 n->sym = sym;
2340 n->clauses = NULL;
2341 n->next = NULL;
2342 if (gfc_current_ns->oacc_routine_names != NULL)
2343 n->next = gfc_current_ns->oacc_routine_names;
2344
2345 gfc_current_ns->oacc_routine_names = n;
2346 }
2347 else if (gfc_current_ns->proc_name)
2348 {
2349 if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
2350 gfc_current_ns->proc_name->name,
2351 &old_loc))
2352 goto cleanup;
2353 gfc_current_ns->proc_name->attr.oacc_function
2354 = gfc_oacc_routine_dims (c) + 1;
2355 }
2356
2357 if (n)
2358 n->clauses = c;
2359 else if (gfc_current_ns->oacc_routine)
2360 gfc_current_ns->oacc_routine_clauses = c;
2361
2362 new_st.op = EXEC_OACC_ROUTINE;
2363 new_st.ext.omp_clauses = c;
2364 return MATCH_YES;
2365
2366 cleanup:
2367 gfc_current_locus = old_loc;
2368 return MATCH_ERROR;
2369 }
2370
2371
2372 #define OMP_PARALLEL_CLAUSES \
2373 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
2374 | OMP_CLAUSE_SHARED | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION \
2375 | OMP_CLAUSE_IF | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT \
2376 | OMP_CLAUSE_PROC_BIND)
2377 #define OMP_DECLARE_SIMD_CLAUSES \
2378 (omp_mask (OMP_CLAUSE_SIMDLEN) | OMP_CLAUSE_LINEAR \
2379 | OMP_CLAUSE_UNIFORM | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_INBRANCH \
2380 | OMP_CLAUSE_NOTINBRANCH)
2381 #define OMP_DO_CLAUSES \
2382 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
2383 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
2384 | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE \
2385 | OMP_CLAUSE_LINEAR)
2386 #define OMP_SECTIONS_CLAUSES \
2387 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
2388 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
2389 #define OMP_SIMD_CLAUSES \
2390 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_LASTPRIVATE \
2391 | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_SAFELEN \
2392 | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_SIMDLEN)
2393 #define OMP_TASK_CLAUSES \
2394 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
2395 | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT \
2396 | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE \
2397 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_PRIORITY)
2398 #define OMP_TASKLOOP_CLAUSES \
2399 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
2400 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF \
2401 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL \
2402 | OMP_CLAUSE_MERGEABLE | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_GRAINSIZE \
2403 | OMP_CLAUSE_NUM_TASKS | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_NOGROUP)
2404 #define OMP_TARGET_CLAUSES \
2405 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
2406 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_PRIVATE \
2407 | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULTMAP \
2408 | OMP_CLAUSE_IS_DEVICE_PTR)
2409 #define OMP_TARGET_DATA_CLAUSES \
2410 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
2411 | OMP_CLAUSE_USE_DEVICE_PTR)
2412 #define OMP_TARGET_ENTER_DATA_CLAUSES \
2413 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
2414 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
2415 #define OMP_TARGET_EXIT_DATA_CLAUSES \
2416 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
2417 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
2418 #define OMP_TARGET_UPDATE_CLAUSES \
2419 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_IF | OMP_CLAUSE_TO \
2420 | OMP_CLAUSE_FROM | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
2421 #define OMP_TEAMS_CLAUSES \
2422 (omp_mask (OMP_CLAUSE_NUM_TEAMS) | OMP_CLAUSE_THREAD_LIMIT \
2423 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
2424 | OMP_CLAUSE_SHARED | OMP_CLAUSE_REDUCTION)
2425 #define OMP_DISTRIBUTE_CLAUSES \
2426 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
2427 | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_DIST_SCHEDULE)
2428 #define OMP_SINGLE_CLAUSES \
2429 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE)
2430 #define OMP_ORDERED_CLAUSES \
2431 (omp_mask (OMP_CLAUSE_THREADS) | OMP_CLAUSE_SIMD)
2432 #define OMP_DECLARE_TARGET_CLAUSES \
2433 (omp_mask (OMP_CLAUSE_TO) | OMP_CLAUSE_LINK)
2434
2435
2436 static match
2437 match_omp (gfc_exec_op op, const omp_mask mask)
2438 {
2439 gfc_omp_clauses *c;
2440 if (gfc_match_omp_clauses (&c, mask) != MATCH_YES)
2441 return MATCH_ERROR;
2442 new_st.op = op;
2443 new_st.ext.omp_clauses = c;
2444 return MATCH_YES;
2445 }
2446
2447
2448 match
2449 gfc_match_omp_critical (void)
2450 {
2451 char n[GFC_MAX_SYMBOL_LEN+1];
2452 gfc_omp_clauses *c = NULL;
2453
2454 if (gfc_match (" ( %n )", n) != MATCH_YES)
2455 {
2456 n[0] = '\0';
2457 if (gfc_match_omp_eos () != MATCH_YES)
2458 {
2459 gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
2460 return MATCH_ERROR;
2461 }
2462 }
2463 else if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_HINT)) != MATCH_YES)
2464 return MATCH_ERROR;
2465
2466 new_st.op = EXEC_OMP_CRITICAL;
2467 new_st.ext.omp_clauses = c;
2468 if (n[0])
2469 c->critical_name = xstrdup (n);
2470 return MATCH_YES;
2471 }
2472
2473
2474 match
2475 gfc_match_omp_end_critical (void)
2476 {
2477 char n[GFC_MAX_SYMBOL_LEN+1];
2478
2479 if (gfc_match (" ( %n )", n) != MATCH_YES)
2480 n[0] = '\0';
2481 if (gfc_match_omp_eos () != MATCH_YES)
2482 {
2483 gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
2484 return MATCH_ERROR;
2485 }
2486
2487 new_st.op = EXEC_OMP_END_CRITICAL;
2488 new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
2489 return MATCH_YES;
2490 }
2491
2492
2493 match
2494 gfc_match_omp_distribute (void)
2495 {
2496 return match_omp (EXEC_OMP_DISTRIBUTE, OMP_DISTRIBUTE_CLAUSES);
2497 }
2498
2499
2500 match
2501 gfc_match_omp_distribute_parallel_do (void)
2502 {
2503 return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO,
2504 (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
2505 | OMP_DO_CLAUSES)
2506 & ~(omp_mask (OMP_CLAUSE_ORDERED))
2507 & ~(omp_mask (OMP_CLAUSE_LINEAR)));
2508 }
2509
2510
2511 match
2512 gfc_match_omp_distribute_parallel_do_simd (void)
2513 {
2514 return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD,
2515 (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
2516 | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
2517 & ~(omp_mask (OMP_CLAUSE_ORDERED)));
2518 }
2519
2520
2521 match
2522 gfc_match_omp_distribute_simd (void)
2523 {
2524 return match_omp (EXEC_OMP_DISTRIBUTE_SIMD,
2525 OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
2526 }
2527
2528
2529 match
2530 gfc_match_omp_do (void)
2531 {
2532 return match_omp (EXEC_OMP_DO, OMP_DO_CLAUSES);
2533 }
2534
2535
2536 match
2537 gfc_match_omp_do_simd (void)
2538 {
2539 return match_omp (EXEC_OMP_DO_SIMD, OMP_DO_CLAUSES | OMP_SIMD_CLAUSES);
2540 }
2541
2542
2543 match
2544 gfc_match_omp_flush (void)
2545 {
2546 gfc_omp_namelist *list = NULL;
2547 gfc_match_omp_variable_list (" (", &list, true);
2548 if (gfc_match_omp_eos () != MATCH_YES)
2549 {
2550 gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
2551 gfc_free_omp_namelist (list);
2552 return MATCH_ERROR;
2553 }
2554 new_st.op = EXEC_OMP_FLUSH;
2555 new_st.ext.omp_namelist = list;
2556 return MATCH_YES;
2557 }
2558
2559
2560 match
2561 gfc_match_omp_declare_simd (void)
2562 {
2563 locus where = gfc_current_locus;
2564 gfc_symbol *proc_name;
2565 gfc_omp_clauses *c;
2566 gfc_omp_declare_simd *ods;
2567 bool needs_space = false;
2568
2569 switch (gfc_match (" ( %s ) ", &proc_name))
2570 {
2571 case MATCH_YES: break;
2572 case MATCH_NO: proc_name = NULL; needs_space = true; break;
2573 case MATCH_ERROR: return MATCH_ERROR;
2574 }
2575
2576 if (gfc_match_omp_clauses (&c, OMP_DECLARE_SIMD_CLAUSES, true,
2577 needs_space) != MATCH_YES)
2578 return MATCH_ERROR;
2579
2580 if (gfc_current_ns->is_block_data)
2581 {
2582 gfc_free_omp_clauses (c);
2583 return MATCH_YES;
2584 }
2585
2586 ods = gfc_get_omp_declare_simd ();
2587 ods->where = where;
2588 ods->proc_name = proc_name;
2589 ods->clauses = c;
2590 ods->next = gfc_current_ns->omp_declare_simd;
2591 gfc_current_ns->omp_declare_simd = ods;
2592 return MATCH_YES;
2593 }
2594
2595
2596 static bool
2597 match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2)
2598 {
2599 match m;
2600 locus old_loc = gfc_current_locus;
2601 char sname[GFC_MAX_SYMBOL_LEN + 1];
2602 gfc_symbol *sym;
2603 gfc_namespace *ns = gfc_current_ns;
2604 gfc_expr *lvalue = NULL, *rvalue = NULL;
2605 gfc_symtree *st;
2606 gfc_actual_arglist *arglist;
2607
2608 m = gfc_match (" %v =", &lvalue);
2609 if (m != MATCH_YES)
2610 gfc_current_locus = old_loc;
2611 else
2612 {
2613 m = gfc_match (" %e )", &rvalue);
2614 if (m == MATCH_YES)
2615 {
2616 ns->code = gfc_get_code (EXEC_ASSIGN);
2617 ns->code->expr1 = lvalue;
2618 ns->code->expr2 = rvalue;
2619 ns->code->loc = old_loc;
2620 return true;
2621 }
2622
2623 gfc_current_locus = old_loc;
2624 gfc_free_expr (lvalue);
2625 }
2626
2627 m = gfc_match (" %n", sname);
2628 if (m != MATCH_YES)
2629 return false;
2630
2631 if (strcmp (sname, omp_sym1->name) == 0
2632 || strcmp (sname, omp_sym2->name) == 0)
2633 return false;
2634
2635 gfc_current_ns = ns->parent;
2636 if (gfc_get_ha_sym_tree (sname, &st))
2637 return false;
2638
2639 sym = st->n.sym;
2640 if (sym->attr.flavor != FL_PROCEDURE
2641 && sym->attr.flavor != FL_UNKNOWN)
2642 return false;
2643
2644 if (!sym->attr.generic
2645 && !sym->attr.subroutine
2646 && !sym->attr.function)
2647 {
2648 if (!(sym->attr.external && !sym->attr.referenced))
2649 {
2650 /* ...create a symbol in this scope... */
2651 if (sym->ns != gfc_current_ns
2652 && gfc_get_sym_tree (sname, NULL, &st, false) == 1)
2653 return false;
2654
2655 if (sym != st->n.sym)
2656 sym = st->n.sym;
2657 }
2658
2659 /* ...and then to try to make the symbol into a subroutine. */
2660 if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
2661 return false;
2662 }
2663
2664 gfc_set_sym_referenced (sym);
2665 gfc_gobble_whitespace ();
2666 if (gfc_peek_ascii_char () != '(')
2667 return false;
2668
2669 gfc_current_ns = ns;
2670 m = gfc_match_actual_arglist (1, &arglist);
2671 if (m != MATCH_YES)
2672 return false;
2673
2674 if (gfc_match_char (')') != MATCH_YES)
2675 return false;
2676
2677 ns->code = gfc_get_code (EXEC_CALL);
2678 ns->code->symtree = st;
2679 ns->code->ext.actual = arglist;
2680 ns->code->loc = old_loc;
2681 return true;
2682 }
2683
2684 static bool
2685 gfc_omp_udr_predef (gfc_omp_reduction_op rop, const char *name,
2686 gfc_typespec *ts, const char **n)
2687 {
2688 if (!gfc_numeric_ts (ts) && ts->type != BT_LOGICAL)
2689 return false;
2690
2691 switch (rop)
2692 {
2693 case OMP_REDUCTION_PLUS:
2694 case OMP_REDUCTION_MINUS:
2695 case OMP_REDUCTION_TIMES:
2696 return ts->type != BT_LOGICAL;
2697 case OMP_REDUCTION_AND:
2698 case OMP_REDUCTION_OR:
2699 case OMP_REDUCTION_EQV:
2700 case OMP_REDUCTION_NEQV:
2701 return ts->type == BT_LOGICAL;
2702 case OMP_REDUCTION_USER:
2703 if (name[0] != '.' && (ts->type == BT_INTEGER || ts->type == BT_REAL))
2704 {
2705 gfc_symbol *sym;
2706
2707 gfc_find_symbol (name, NULL, 1, &sym);
2708 if (sym != NULL)
2709 {
2710 if (sym->attr.intrinsic)
2711 *n = sym->name;
2712 else if ((sym->attr.flavor != FL_UNKNOWN
2713 && sym->attr.flavor != FL_PROCEDURE)
2714 || sym->attr.external
2715 || sym->attr.generic
2716 || sym->attr.entry
2717 || sym->attr.result
2718 || sym->attr.dummy
2719 || sym->attr.subroutine
2720 || sym->attr.pointer
2721 || sym->attr.target
2722 || sym->attr.cray_pointer
2723 || sym->attr.cray_pointee
2724 || (sym->attr.proc != PROC_UNKNOWN
2725 && sym->attr.proc != PROC_INTRINSIC)
2726 || sym->attr.if_source != IFSRC_UNKNOWN
2727 || sym == sym->ns->proc_name)
2728 *n = NULL;
2729 else
2730 *n = sym->name;
2731 }
2732 else
2733 *n = name;
2734 if (*n
2735 && (strcmp (*n, "max") == 0 || strcmp (*n, "min") == 0))
2736 return true;
2737 else if (*n
2738 && ts->type == BT_INTEGER
2739 && (strcmp (*n, "iand") == 0
2740 || strcmp (*n, "ior") == 0
2741 || strcmp (*n, "ieor") == 0))
2742 return true;
2743 }
2744 break;
2745 default:
2746 break;
2747 }
2748 return false;
2749 }
2750
2751 gfc_omp_udr *
2752 gfc_omp_udr_find (gfc_symtree *st, gfc_typespec *ts)
2753 {
2754 gfc_omp_udr *omp_udr;
2755
2756 if (st == NULL)
2757 return NULL;
2758
2759 for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
2760 if (omp_udr->ts.type == ts->type
2761 || ((omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
2762 && (ts->type == BT_DERIVED || ts->type == BT_CLASS)))
2763 {
2764 if (omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
2765 {
2766 if (strcmp (omp_udr->ts.u.derived->name, ts->u.derived->name) == 0)
2767 return omp_udr;
2768 }
2769 else if (omp_udr->ts.kind == ts->kind)
2770 {
2771 if (omp_udr->ts.type == BT_CHARACTER)
2772 {
2773 if (omp_udr->ts.u.cl->length == NULL
2774 || ts->u.cl->length == NULL)
2775 return omp_udr;
2776 if (omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
2777 return omp_udr;
2778 if (ts->u.cl->length->expr_type != EXPR_CONSTANT)
2779 return omp_udr;
2780 if (omp_udr->ts.u.cl->length->ts.type != BT_INTEGER)
2781 return omp_udr;
2782 if (ts->u.cl->length->ts.type != BT_INTEGER)
2783 return omp_udr;
2784 if (gfc_compare_expr (omp_udr->ts.u.cl->length,
2785 ts->u.cl->length, INTRINSIC_EQ) != 0)
2786 continue;
2787 }
2788 return omp_udr;
2789 }
2790 }
2791 return NULL;
2792 }
2793
2794 match
2795 gfc_match_omp_declare_reduction (void)
2796 {
2797 match m;
2798 gfc_intrinsic_op op;
2799 char name[GFC_MAX_SYMBOL_LEN + 3];
2800 auto_vec<gfc_typespec, 5> tss;
2801 gfc_typespec ts;
2802 unsigned int i;
2803 gfc_symtree *st;
2804 locus where = gfc_current_locus;
2805 locus end_loc = gfc_current_locus;
2806 bool end_loc_set = false;
2807 gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
2808
2809 if (gfc_match_char ('(') != MATCH_YES)
2810 return MATCH_ERROR;
2811
2812 m = gfc_match (" %o : ", &op);
2813 if (m == MATCH_ERROR)
2814 return MATCH_ERROR;
2815 if (m == MATCH_YES)
2816 {
2817 snprintf (name, sizeof name, "operator %s", gfc_op2string (op));
2818 rop = (gfc_omp_reduction_op) op;
2819 }
2820 else
2821 {
2822 m = gfc_match_defined_op_name (name + 1, 1);
2823 if (m == MATCH_ERROR)
2824 return MATCH_ERROR;
2825 if (m == MATCH_YES)
2826 {
2827 name[0] = '.';
2828 strcat (name, ".");
2829 if (gfc_match (" : ") != MATCH_YES)
2830 return MATCH_ERROR;
2831 }
2832 else
2833 {
2834 if (gfc_match (" %n : ", name) != MATCH_YES)
2835 return MATCH_ERROR;
2836 }
2837 rop = OMP_REDUCTION_USER;
2838 }
2839
2840 m = gfc_match_type_spec (&ts);
2841 if (m != MATCH_YES)
2842 return MATCH_ERROR;
2843 /* Treat len=: the same as len=*. */
2844 if (ts.type == BT_CHARACTER)
2845 ts.deferred = false;
2846 tss.safe_push (ts);
2847
2848 while (gfc_match_char (',') == MATCH_YES)
2849 {
2850 m = gfc_match_type_spec (&ts);
2851 if (m != MATCH_YES)
2852 return MATCH_ERROR;
2853 tss.safe_push (ts);
2854 }
2855 if (gfc_match_char (':') != MATCH_YES)
2856 return MATCH_ERROR;
2857
2858 st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
2859 for (i = 0; i < tss.length (); i++)
2860 {
2861 gfc_symtree *omp_out, *omp_in;
2862 gfc_symtree *omp_priv = NULL, *omp_orig = NULL;
2863 gfc_namespace *combiner_ns, *initializer_ns = NULL;
2864 gfc_omp_udr *prev_udr, *omp_udr;
2865 const char *predef_name = NULL;
2866
2867 omp_udr = gfc_get_omp_udr ();
2868 omp_udr->name = gfc_get_string ("%s", name);
2869 omp_udr->rop = rop;
2870 omp_udr->ts = tss[i];
2871 omp_udr->where = where;
2872
2873 gfc_current_ns = combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
2874 combiner_ns->proc_name = combiner_ns->parent->proc_name;
2875
2876 gfc_get_sym_tree ("omp_out", combiner_ns, &omp_out, false);
2877 gfc_get_sym_tree ("omp_in", combiner_ns, &omp_in, false);
2878 combiner_ns->omp_udr_ns = 1;
2879 omp_out->n.sym->ts = tss[i];
2880 omp_in->n.sym->ts = tss[i];
2881 omp_out->n.sym->attr.omp_udr_artificial_var = 1;
2882 omp_in->n.sym->attr.omp_udr_artificial_var = 1;
2883 omp_out->n.sym->attr.flavor = FL_VARIABLE;
2884 omp_in->n.sym->attr.flavor = FL_VARIABLE;
2885 gfc_commit_symbols ();
2886 omp_udr->combiner_ns = combiner_ns;
2887 omp_udr->omp_out = omp_out->n.sym;
2888 omp_udr->omp_in = omp_in->n.sym;
2889
2890 locus old_loc = gfc_current_locus;
2891
2892 if (!match_udr_expr (omp_out, omp_in))
2893 {
2894 syntax:
2895 gfc_current_locus = old_loc;
2896 gfc_current_ns = combiner_ns->parent;
2897 gfc_undo_symbols ();
2898 gfc_free_omp_udr (omp_udr);
2899 return MATCH_ERROR;
2900 }
2901
2902 if (gfc_match (" initializer ( ") == MATCH_YES)
2903 {
2904 gfc_current_ns = combiner_ns->parent;
2905 initializer_ns = gfc_get_namespace (gfc_current_ns, 1);
2906 gfc_current_ns = initializer_ns;
2907 initializer_ns->proc_name = initializer_ns->parent->proc_name;
2908
2909 gfc_get_sym_tree ("omp_priv", initializer_ns, &omp_priv, false);
2910 gfc_get_sym_tree ("omp_orig", initializer_ns, &omp_orig, false);
2911 initializer_ns->omp_udr_ns = 1;
2912 omp_priv->n.sym->ts = tss[i];
2913 omp_orig->n.sym->ts = tss[i];
2914 omp_priv->n.sym->attr.omp_udr_artificial_var = 1;
2915 omp_orig->n.sym->attr.omp_udr_artificial_var = 1;
2916 omp_priv->n.sym->attr.flavor = FL_VARIABLE;
2917 omp_orig->n.sym->attr.flavor = FL_VARIABLE;
2918 gfc_commit_symbols ();
2919 omp_udr->initializer_ns = initializer_ns;
2920 omp_udr->omp_priv = omp_priv->n.sym;
2921 omp_udr->omp_orig = omp_orig->n.sym;
2922
2923 if (!match_udr_expr (omp_priv, omp_orig))
2924 goto syntax;
2925 }
2926
2927 gfc_current_ns = combiner_ns->parent;
2928 if (!end_loc_set)
2929 {
2930 end_loc_set = true;
2931 end_loc = gfc_current_locus;
2932 }
2933 gfc_current_locus = old_loc;
2934
2935 prev_udr = gfc_omp_udr_find (st, &tss[i]);
2936 if (gfc_omp_udr_predef (rop, name, &tss[i], &predef_name)
2937 /* Don't error on !$omp declare reduction (min : integer : ...)
2938 just yet, there could be integer :: min afterwards,
2939 making it valid. When the UDR is resolved, we'll get
2940 to it again. */
2941 && (rop != OMP_REDUCTION_USER || name[0] == '.'))
2942 {
2943 if (predef_name)
2944 gfc_error_now ("Redefinition of predefined %s "
2945 "!$OMP DECLARE REDUCTION at %L",
2946 predef_name, &where);
2947 else
2948 gfc_error_now ("Redefinition of predefined "
2949 "!$OMP DECLARE REDUCTION at %L", &where);
2950 }
2951 else if (prev_udr)
2952 {
2953 gfc_error_now ("Redefinition of !$OMP DECLARE REDUCTION at %L",
2954 &where);
2955 gfc_error_now ("Previous !$OMP DECLARE REDUCTION at %L",
2956 &prev_udr->where);
2957 }
2958 else if (st)
2959 {
2960 omp_udr->next = st->n.omp_udr;
2961 st->n.omp_udr = omp_udr;
2962 }
2963 else
2964 {
2965 st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name);
2966 st->n.omp_udr = omp_udr;
2967 }
2968 }
2969
2970 if (end_loc_set)
2971 {
2972 gfc_current_locus = end_loc;
2973 if (gfc_match_omp_eos () != MATCH_YES)
2974 {
2975 gfc_error ("Unexpected junk after !$OMP DECLARE REDUCTION at %C");
2976 gfc_current_locus = where;
2977 return MATCH_ERROR;
2978 }
2979
2980 return MATCH_YES;
2981 }
2982 gfc_clear_error ();
2983 return MATCH_ERROR;
2984 }
2985
2986
2987 match
2988 gfc_match_omp_declare_target (void)
2989 {
2990 locus old_loc;
2991 match m;
2992 gfc_omp_clauses *c = NULL;
2993 int list;
2994 gfc_omp_namelist *n;
2995 gfc_symbol *s;
2996
2997 old_loc = gfc_current_locus;
2998
2999 if (gfc_current_ns->proc_name
3000 && gfc_match_omp_eos () == MATCH_YES)
3001 {
3002 if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
3003 gfc_current_ns->proc_name->name,
3004 &old_loc))
3005 goto cleanup;
3006 return MATCH_YES;
3007 }
3008
3009 if (gfc_current_ns->proc_name
3010 && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY)
3011 {
3012 gfc_error ("Only the !$OMP DECLARE TARGET form without "
3013 "clauses is allowed in interface block at %C");
3014 goto cleanup;
3015 }
3016
3017 m = gfc_match (" (");
3018 if (m == MATCH_YES)
3019 {
3020 c = gfc_get_omp_clauses ();
3021 gfc_current_locus = old_loc;
3022 m = gfc_match_omp_to_link (" (", &c->lists[OMP_LIST_TO]);
3023 if (m != MATCH_YES)
3024 goto syntax;
3025 if (gfc_match_omp_eos () != MATCH_YES)
3026 {
3027 gfc_error ("Unexpected junk after !$OMP DECLARE TARGET at %C");
3028 goto cleanup;
3029 }
3030 }
3031 else if (gfc_match_omp_clauses (&c, OMP_DECLARE_TARGET_CLAUSES) != MATCH_YES)
3032 return MATCH_ERROR;
3033
3034 gfc_buffer_error (false);
3035
3036 for (list = OMP_LIST_TO; list != OMP_LIST_NUM;
3037 list = (list == OMP_LIST_TO ? OMP_LIST_LINK : OMP_LIST_NUM))
3038 for (n = c->lists[list]; n; n = n->next)
3039 if (n->sym)
3040 n->sym->mark = 0;
3041 else if (n->u.common->head)
3042 n->u.common->head->mark = 0;
3043
3044 for (list = OMP_LIST_TO; list != OMP_LIST_NUM;
3045 list = (list == OMP_LIST_TO ? OMP_LIST_LINK : OMP_LIST_NUM))
3046 for (n = c->lists[list]; n; n = n->next)
3047 if (n->sym)
3048 {
3049 if (n->sym->attr.in_common)
3050 gfc_error_now ("OMP DECLARE TARGET variable at %L is an "
3051 "element of a COMMON block", &n->where);
3052 else if (n->sym->attr.omp_declare_target
3053 && n->sym->attr.omp_declare_target_link
3054 && list != OMP_LIST_LINK)
3055 gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
3056 "mentioned in LINK clause and later in TO clause",
3057 &n->where);
3058 else if (n->sym->attr.omp_declare_target
3059 && !n->sym->attr.omp_declare_target_link
3060 && list == OMP_LIST_LINK)
3061 gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
3062 "mentioned in TO clause and later in LINK clause",
3063 &n->where);
3064 else if (n->sym->mark)
3065 gfc_error_now ("Variable at %L mentioned multiple times in "
3066 "clauses of the same OMP DECLARE TARGET directive",
3067 &n->where);
3068 else if (gfc_add_omp_declare_target (&n->sym->attr, n->sym->name,
3069 &n->sym->declared_at))
3070 {
3071 if (list == OMP_LIST_LINK)
3072 gfc_add_omp_declare_target_link (&n->sym->attr, n->sym->name,
3073 &n->sym->declared_at);
3074 }
3075 n->sym->mark = 1;
3076 }
3077 else if (n->u.common->omp_declare_target
3078 && n->u.common->omp_declare_target_link
3079 && list != OMP_LIST_LINK)
3080 gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously "
3081 "mentioned in LINK clause and later in TO clause",
3082 &n->where);
3083 else if (n->u.common->omp_declare_target
3084 && !n->u.common->omp_declare_target_link
3085 && list == OMP_LIST_LINK)
3086 gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously "
3087 "mentioned in TO clause and later in LINK clause",
3088 &n->where);
3089 else if (n->u.common->head && n->u.common->head->mark)
3090 gfc_error_now ("COMMON at %L mentioned multiple times in "
3091 "clauses of the same OMP DECLARE TARGET directive",
3092 &n->where);
3093 else
3094 {
3095 n->u.common->omp_declare_target = 1;
3096 n->u.common->omp_declare_target_link = (list == OMP_LIST_LINK);
3097 for (s = n->u.common->head; s; s = s->common_next)
3098 {
3099 s->mark = 1;
3100 if (gfc_add_omp_declare_target (&s->attr, s->name,
3101 &s->declared_at))
3102 {
3103 if (list == OMP_LIST_LINK)
3104 gfc_add_omp_declare_target_link (&s->attr, s->name,
3105 &s->declared_at);
3106 }
3107 }
3108 }
3109
3110 gfc_buffer_error (true);
3111
3112 if (c)
3113 gfc_free_omp_clauses (c);
3114 return MATCH_YES;
3115
3116 syntax:
3117 gfc_error ("Syntax error in !$OMP DECLARE TARGET list at %C");
3118
3119 cleanup:
3120 gfc_current_locus = old_loc;
3121 if (c)
3122 gfc_free_omp_clauses (c);
3123 return MATCH_ERROR;
3124 }
3125
3126
3127 match
3128 gfc_match_omp_threadprivate (void)
3129 {
3130 locus old_loc;
3131 char n[GFC_MAX_SYMBOL_LEN+1];
3132 gfc_symbol *sym;
3133 match m;
3134 gfc_symtree *st;
3135
3136 old_loc = gfc_current_locus;
3137
3138 m = gfc_match (" (");
3139 if (m != MATCH_YES)
3140 return m;
3141
3142 for (;;)
3143 {
3144 m = gfc_match_symbol (&sym, 0);
3145 switch (m)
3146 {
3147 case MATCH_YES:
3148 if (sym->attr.in_common)
3149 gfc_error_now ("Threadprivate variable at %C is an element of "
3150 "a COMMON block");
3151 else if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at))
3152 goto cleanup;
3153 goto next_item;
3154 case MATCH_NO:
3155 break;
3156 case MATCH_ERROR:
3157 goto cleanup;
3158 }
3159
3160 m = gfc_match (" / %n /", n);
3161 if (m == MATCH_ERROR)
3162 goto cleanup;
3163 if (m == MATCH_NO || n[0] == '\0')
3164 goto syntax;
3165
3166 st = gfc_find_symtree (gfc_current_ns->common_root, n);
3167 if (st == NULL)
3168 {
3169 gfc_error ("COMMON block /%s/ not found at %C", n);
3170 goto cleanup;
3171 }
3172 st->n.common->threadprivate = 1;
3173 for (sym = st->n.common->head; sym; sym = sym->common_next)
3174 if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at))
3175 goto cleanup;
3176
3177 next_item:
3178 if (gfc_match_char (')') == MATCH_YES)
3179 break;
3180 if (gfc_match_char (',') != MATCH_YES)
3181 goto syntax;
3182 }
3183
3184 if (gfc_match_omp_eos () != MATCH_YES)
3185 {
3186 gfc_error ("Unexpected junk after OMP THREADPRIVATE at %C");
3187 goto cleanup;
3188 }
3189
3190 return MATCH_YES;
3191
3192 syntax:
3193 gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C");
3194
3195 cleanup:
3196 gfc_current_locus = old_loc;
3197 return MATCH_ERROR;
3198 }
3199
3200
3201 match
3202 gfc_match_omp_parallel (void)
3203 {
3204 return match_omp (EXEC_OMP_PARALLEL, OMP_PARALLEL_CLAUSES);
3205 }
3206
3207
3208 match
3209 gfc_match_omp_parallel_do (void)
3210 {
3211 return match_omp (EXEC_OMP_PARALLEL_DO,
3212 OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES);
3213 }
3214
3215
3216 match
3217 gfc_match_omp_parallel_do_simd (void)
3218 {
3219 return match_omp (EXEC_OMP_PARALLEL_DO_SIMD,
3220 OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES);
3221 }
3222
3223
3224 match
3225 gfc_match_omp_parallel_sections (void)
3226 {
3227 return match_omp (EXEC_OMP_PARALLEL_SECTIONS,
3228 OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES);
3229 }
3230
3231
3232 match
3233 gfc_match_omp_parallel_workshare (void)
3234 {
3235 return match_omp (EXEC_OMP_PARALLEL_WORKSHARE, OMP_PARALLEL_CLAUSES);
3236 }
3237
3238
3239 match
3240 gfc_match_omp_sections (void)
3241 {
3242 return match_omp (EXEC_OMP_SECTIONS, OMP_SECTIONS_CLAUSES);
3243 }
3244
3245
3246 match
3247 gfc_match_omp_simd (void)
3248 {
3249 return match_omp (EXEC_OMP_SIMD, OMP_SIMD_CLAUSES);
3250 }
3251
3252
3253 match
3254 gfc_match_omp_single (void)
3255 {
3256 return match_omp (EXEC_OMP_SINGLE, OMP_SINGLE_CLAUSES);
3257 }
3258
3259
3260 match
3261 gfc_match_omp_target (void)
3262 {
3263 return match_omp (EXEC_OMP_TARGET, OMP_TARGET_CLAUSES);
3264 }
3265
3266
3267 match
3268 gfc_match_omp_target_data (void)
3269 {
3270 return match_omp (EXEC_OMP_TARGET_DATA, OMP_TARGET_DATA_CLAUSES);
3271 }
3272
3273
3274 match
3275 gfc_match_omp_target_enter_data (void)
3276 {
3277 return match_omp (EXEC_OMP_TARGET_ENTER_DATA, OMP_TARGET_ENTER_DATA_CLAUSES);
3278 }
3279
3280
3281 match
3282 gfc_match_omp_target_exit_data (void)
3283 {
3284 return match_omp (EXEC_OMP_TARGET_EXIT_DATA, OMP_TARGET_EXIT_DATA_CLAUSES);
3285 }
3286
3287
3288 match
3289 gfc_match_omp_target_parallel (void)
3290 {
3291 return match_omp (EXEC_OMP_TARGET_PARALLEL,
3292 (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES)
3293 & ~(omp_mask (OMP_CLAUSE_COPYIN)));
3294 }
3295
3296
3297 match
3298 gfc_match_omp_target_parallel_do (void)
3299 {
3300 return match_omp (EXEC_OMP_TARGET_PARALLEL_DO,
3301 (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES
3302 | OMP_DO_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN)));
3303 }
3304
3305
3306 match
3307 gfc_match_omp_target_parallel_do_simd (void)
3308 {
3309 return match_omp (EXEC_OMP_TARGET_PARALLEL_DO_SIMD,
3310 (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
3311 | OMP_SIMD_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN)));
3312 }
3313
3314
3315 match
3316 gfc_match_omp_target_simd (void)
3317 {
3318 return match_omp (EXEC_OMP_TARGET_SIMD,
3319 OMP_TARGET_CLAUSES | OMP_SIMD_CLAUSES);
3320 }
3321
3322
3323 match
3324 gfc_match_omp_target_teams (void)
3325 {
3326 return match_omp (EXEC_OMP_TARGET_TEAMS,
3327 OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES);
3328 }
3329
3330
3331 match
3332 gfc_match_omp_target_teams_distribute (void)
3333 {
3334 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE,
3335 OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
3336 | OMP_DISTRIBUTE_CLAUSES);
3337 }
3338
3339
3340 match
3341 gfc_match_omp_target_teams_distribute_parallel_do (void)
3342 {
3343 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO,
3344 (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
3345 | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
3346 | OMP_DO_CLAUSES)
3347 & ~(omp_mask (OMP_CLAUSE_ORDERED))
3348 & ~(omp_mask (OMP_CLAUSE_LINEAR)));
3349 }
3350
3351
3352 match
3353 gfc_match_omp_target_teams_distribute_parallel_do_simd (void)
3354 {
3355 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
3356 (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
3357 | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
3358 | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
3359 & ~(omp_mask (OMP_CLAUSE_ORDERED)));
3360 }
3361
3362
3363 match
3364 gfc_match_omp_target_teams_distribute_simd (void)
3365 {
3366 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD,
3367 OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
3368 | OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
3369 }
3370
3371
3372 match
3373 gfc_match_omp_target_update (void)
3374 {
3375 return match_omp (EXEC_OMP_TARGET_UPDATE, OMP_TARGET_UPDATE_CLAUSES);
3376 }
3377
3378
3379 match
3380 gfc_match_omp_task (void)
3381 {
3382 return match_omp (EXEC_OMP_TASK, OMP_TASK_CLAUSES);
3383 }
3384
3385
3386 match
3387 gfc_match_omp_taskloop (void)
3388 {
3389 return match_omp (EXEC_OMP_TASKLOOP, OMP_TASKLOOP_CLAUSES);
3390 }
3391
3392
3393 match
3394 gfc_match_omp_taskloop_simd (void)
3395 {
3396 return match_omp (EXEC_OMP_TASKLOOP_SIMD,
3397 (OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES)
3398 & ~(omp_mask (OMP_CLAUSE_REDUCTION)));
3399 }
3400
3401
3402 match
3403 gfc_match_omp_taskwait (void)
3404 {
3405 if (gfc_match_omp_eos () != MATCH_YES)
3406 {
3407 gfc_error ("Unexpected junk after TASKWAIT clause at %C");
3408 return MATCH_ERROR;
3409 }
3410 new_st.op = EXEC_OMP_TASKWAIT;
3411 new_st.ext.omp_clauses = NULL;
3412 return MATCH_YES;
3413 }
3414
3415
3416 match
3417 gfc_match_omp_taskyield (void)
3418 {
3419 if (gfc_match_omp_eos () != MATCH_YES)
3420 {
3421 gfc_error ("Unexpected junk after TASKYIELD clause at %C");
3422 return MATCH_ERROR;
3423 }
3424 new_st.op = EXEC_OMP_TASKYIELD;
3425 new_st.ext.omp_clauses = NULL;
3426 return MATCH_YES;
3427 }
3428
3429
3430 match
3431 gfc_match_omp_teams (void)
3432 {
3433 return match_omp (EXEC_OMP_TEAMS, OMP_TEAMS_CLAUSES);
3434 }
3435
3436
3437 match
3438 gfc_match_omp_teams_distribute (void)
3439 {
3440 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE,
3441 OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES);
3442 }
3443
3444
3445 match
3446 gfc_match_omp_teams_distribute_parallel_do (void)
3447 {
3448 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO,
3449 (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
3450 | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
3451 & ~(omp_mask (OMP_CLAUSE_ORDERED))
3452 & ~(omp_mask (OMP_CLAUSE_LINEAR)));
3453 }
3454
3455
3456 match
3457 gfc_match_omp_teams_distribute_parallel_do_simd (void)
3458 {
3459 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
3460 (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
3461 | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
3462 | OMP_SIMD_CLAUSES) & ~(omp_mask (OMP_CLAUSE_ORDERED)));
3463 }
3464
3465
3466 match
3467 gfc_match_omp_teams_distribute_simd (void)
3468 {
3469 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_SIMD,
3470 OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
3471 | OMP_SIMD_CLAUSES);
3472 }
3473
3474
3475 match
3476 gfc_match_omp_workshare (void)
3477 {
3478 if (gfc_match_omp_eos () != MATCH_YES)
3479 {
3480 gfc_error ("Unexpected junk after $OMP WORKSHARE statement at %C");
3481 return MATCH_ERROR;
3482 }
3483 new_st.op = EXEC_OMP_WORKSHARE;
3484 new_st.ext.omp_clauses = gfc_get_omp_clauses ();
3485 return MATCH_YES;
3486 }
3487
3488
3489 match
3490 gfc_match_omp_master (void)
3491 {
3492 if (gfc_match_omp_eos () != MATCH_YES)
3493 {
3494 gfc_error ("Unexpected junk after $OMP MASTER statement at %C");
3495 return MATCH_ERROR;
3496 }
3497 new_st.op = EXEC_OMP_MASTER;
3498 new_st.ext.omp_clauses = NULL;
3499 return MATCH_YES;
3500 }
3501
3502
3503 match
3504 gfc_match_omp_ordered (void)
3505 {
3506 return match_omp (EXEC_OMP_ORDERED, OMP_ORDERED_CLAUSES);
3507 }
3508
3509
3510 match
3511 gfc_match_omp_ordered_depend (void)
3512 {
3513 return match_omp (EXEC_OMP_ORDERED, omp_mask (OMP_CLAUSE_DEPEND));
3514 }
3515
3516
3517 static match
3518 gfc_match_omp_oacc_atomic (bool omp_p)
3519 {
3520 gfc_omp_atomic_op op = GFC_OMP_ATOMIC_UPDATE;
3521 int seq_cst = 0;
3522 if (gfc_match ("% seq_cst") == MATCH_YES)
3523 seq_cst = 1;
3524 locus old_loc = gfc_current_locus;
3525 if (seq_cst && gfc_match_char (',') == MATCH_YES)
3526 seq_cst = 2;
3527 if (seq_cst == 2
3528 || gfc_match_space () == MATCH_YES)
3529 {
3530 gfc_gobble_whitespace ();
3531 if (gfc_match ("update") == MATCH_YES)
3532 op = GFC_OMP_ATOMIC_UPDATE;
3533 else if (gfc_match ("read") == MATCH_YES)
3534 op = GFC_OMP_ATOMIC_READ;
3535 else if (gfc_match ("write") == MATCH_YES)
3536 op = GFC_OMP_ATOMIC_WRITE;
3537 else if (gfc_match ("capture") == MATCH_YES)
3538 op = GFC_OMP_ATOMIC_CAPTURE;
3539 else
3540 {
3541 if (seq_cst == 2)
3542 gfc_current_locus = old_loc;
3543 goto finish;
3544 }
3545 if (!seq_cst
3546 && (gfc_match (", seq_cst") == MATCH_YES
3547 || gfc_match ("% seq_cst") == MATCH_YES))
3548 seq_cst = 1;
3549 }
3550 finish:
3551 if (gfc_match_omp_eos () != MATCH_YES)
3552 {
3553 gfc_error ("Unexpected junk after $OMP ATOMIC statement at %C");
3554 return MATCH_ERROR;
3555 }
3556 new_st.op = (omp_p ? EXEC_OMP_ATOMIC : EXEC_OACC_ATOMIC);
3557 if (seq_cst)
3558 op = (gfc_omp_atomic_op) (op | GFC_OMP_ATOMIC_SEQ_CST);
3559 new_st.ext.omp_atomic = op;
3560 return MATCH_YES;
3561 }
3562
3563 match
3564 gfc_match_oacc_atomic (void)
3565 {
3566 return gfc_match_omp_oacc_atomic (false);
3567 }
3568
3569 match
3570 gfc_match_omp_atomic (void)
3571 {
3572 return gfc_match_omp_oacc_atomic (true);
3573 }
3574
3575 match
3576 gfc_match_omp_barrier (void)
3577 {
3578 if (gfc_match_omp_eos () != MATCH_YES)
3579 {
3580 gfc_error ("Unexpected junk after $OMP BARRIER statement at %C");
3581 return MATCH_ERROR;
3582 }
3583 new_st.op = EXEC_OMP_BARRIER;
3584 new_st.ext.omp_clauses = NULL;
3585 return MATCH_YES;
3586 }
3587
3588
3589 match
3590 gfc_match_omp_taskgroup (void)
3591 {
3592 if (gfc_match_omp_eos () != MATCH_YES)
3593 {
3594 gfc_error ("Unexpected junk after $OMP TASKGROUP statement at %C");
3595 return MATCH_ERROR;
3596 }
3597 new_st.op = EXEC_OMP_TASKGROUP;
3598 return MATCH_YES;
3599 }
3600
3601
3602 static enum gfc_omp_cancel_kind
3603 gfc_match_omp_cancel_kind (void)
3604 {
3605 if (gfc_match_space () != MATCH_YES)
3606 return OMP_CANCEL_UNKNOWN;
3607 if (gfc_match ("parallel") == MATCH_YES)
3608 return OMP_CANCEL_PARALLEL;
3609 if (gfc_match ("sections") == MATCH_YES)
3610 return OMP_CANCEL_SECTIONS;
3611 if (gfc_match ("do") == MATCH_YES)
3612 return OMP_CANCEL_DO;
3613 if (gfc_match ("taskgroup") == MATCH_YES)
3614 return OMP_CANCEL_TASKGROUP;
3615 return OMP_CANCEL_UNKNOWN;
3616 }
3617
3618
3619 match
3620 gfc_match_omp_cancel (void)
3621 {
3622 gfc_omp_clauses *c;
3623 enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
3624 if (kind == OMP_CANCEL_UNKNOWN)
3625 return MATCH_ERROR;
3626 if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_IF), false) != MATCH_YES)
3627 return MATCH_ERROR;
3628 c->cancel = kind;
3629 new_st.op = EXEC_OMP_CANCEL;
3630 new_st.ext.omp_clauses = c;
3631 return MATCH_YES;
3632 }
3633
3634
3635 match
3636 gfc_match_omp_cancellation_point (void)
3637 {
3638 gfc_omp_clauses *c;
3639 enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
3640 if (kind == OMP_CANCEL_UNKNOWN)
3641 return MATCH_ERROR;
3642 if (gfc_match_omp_eos () != MATCH_YES)
3643 {
3644 gfc_error ("Unexpected junk after $OMP CANCELLATION POINT statement "
3645 "at %C");
3646 return MATCH_ERROR;
3647 }
3648 c = gfc_get_omp_clauses ();
3649 c->cancel = kind;
3650 new_st.op = EXEC_OMP_CANCELLATION_POINT;
3651 new_st.ext.omp_clauses = c;
3652 return MATCH_YES;
3653 }
3654
3655
3656 match
3657 gfc_match_omp_end_nowait (void)
3658 {
3659 bool nowait = false;
3660 if (gfc_match ("% nowait") == MATCH_YES)
3661 nowait = true;
3662 if (gfc_match_omp_eos () != MATCH_YES)
3663 {
3664 gfc_error ("Unexpected junk after NOWAIT clause at %C");
3665 return MATCH_ERROR;
3666 }
3667 new_st.op = EXEC_OMP_END_NOWAIT;
3668 new_st.ext.omp_bool = nowait;
3669 return MATCH_YES;
3670 }
3671
3672
3673 match
3674 gfc_match_omp_end_single (void)
3675 {
3676 gfc_omp_clauses *c;
3677 if (gfc_match ("% nowait") == MATCH_YES)
3678 {
3679 new_st.op = EXEC_OMP_END_NOWAIT;
3680 new_st.ext.omp_bool = true;
3681 return MATCH_YES;
3682 }
3683 if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_COPYPRIVATE))
3684 != MATCH_YES)
3685 return MATCH_ERROR;
3686 new_st.op = EXEC_OMP_END_SINGLE;
3687 new_st.ext.omp_clauses = c;
3688 return MATCH_YES;
3689 }
3690
3691
3692 static bool
3693 oacc_is_loop (gfc_code *code)
3694 {
3695 return code->op == EXEC_OACC_PARALLEL_LOOP
3696 || code->op == EXEC_OACC_KERNELS_LOOP
3697 || code->op == EXEC_OACC_LOOP;
3698 }
3699
3700 static void
3701 resolve_scalar_int_expr (gfc_expr *expr, const char *clause)
3702 {
3703 if (!gfc_resolve_expr (expr)
3704 || expr->ts.type != BT_INTEGER
3705 || expr->rank != 0)
3706 gfc_error ("%s clause at %L requires a scalar INTEGER expression",
3707 clause, &expr->where);
3708 }
3709
3710 static void
3711 resolve_positive_int_expr (gfc_expr *expr, const char *clause)
3712 {
3713 resolve_scalar_int_expr (expr, clause);
3714 if (expr->expr_type == EXPR_CONSTANT
3715 && expr->ts.type == BT_INTEGER
3716 && mpz_sgn (expr->value.integer) <= 0)
3717 gfc_warning (0, "INTEGER expression of %s clause at %L must be positive",
3718 clause, &expr->where);
3719 }
3720
3721 static void
3722 resolve_nonnegative_int_expr (gfc_expr *expr, const char *clause)
3723 {
3724 resolve_scalar_int_expr (expr, clause);
3725 if (expr->expr_type == EXPR_CONSTANT
3726 && expr->ts.type == BT_INTEGER
3727 && mpz_sgn (expr->value.integer) < 0)
3728 gfc_warning (0, "INTEGER expression of %s clause at %L must be "
3729 "non-negative", clause, &expr->where);
3730 }
3731
3732 /* Emits error when symbol is pointer, cray pointer or cray pointee
3733 of derived of polymorphic type. */
3734
3735 static void
3736 check_symbol_not_pointer (gfc_symbol *sym, locus loc, const char *name)
3737 {
3738 if (sym->ts.type == BT_DERIVED && sym->attr.pointer)
3739 gfc_error ("POINTER object %qs of derived type in %s clause at %L",
3740 sym->name, name, &loc);
3741 if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointer)
3742 gfc_error ("Cray pointer object %qs of derived type in %s clause at %L",
3743 sym->name, name, &loc);
3744 if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointee)
3745 gfc_error ("Cray pointee object %qs of derived type in %s clause at %L",
3746 sym->name, name, &loc);
3747
3748 if ((sym->ts.type == BT_ASSUMED && sym->attr.pointer)
3749 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
3750 && CLASS_DATA (sym)->attr.pointer))
3751 gfc_error ("POINTER object %qs of polymorphic type in %s clause at %L",
3752 sym->name, name, &loc);
3753 if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointer)
3754 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
3755 && CLASS_DATA (sym)->attr.cray_pointer))
3756 gfc_error ("Cray pointer object %qs of polymorphic type in %s clause at %L",
3757 sym->name, name, &loc);
3758 if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointee)
3759 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
3760 && CLASS_DATA (sym)->attr.cray_pointee))
3761 gfc_error ("Cray pointee object %qs of polymorphic type in %s clause at %L",
3762 sym->name, name, &loc);
3763 }
3764
3765 /* Emits error when symbol represents assumed size/rank array. */
3766
3767 static void
3768 check_array_not_assumed (gfc_symbol *sym, locus loc, const char *name)
3769 {
3770 if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
3771 gfc_error ("Assumed size array %qs in %s clause at %L",
3772 sym->name, name, &loc);
3773 if (sym->as && sym->as->type == AS_ASSUMED_RANK)
3774 gfc_error ("Assumed rank array %qs in %s clause at %L",
3775 sym->name, name, &loc);
3776 if (sym->as && sym->as->type == AS_DEFERRED && sym->attr.pointer
3777 && !sym->attr.contiguous)
3778 gfc_error ("Noncontiguous deferred shape array %qs in %s clause at %L",
3779 sym->name, name, &loc);
3780 }
3781
3782 static void
3783 resolve_oacc_data_clauses (gfc_symbol *sym, locus loc, const char *name)
3784 {
3785 if (sym->ts.type == BT_DERIVED && sym->attr.allocatable)
3786 gfc_error ("ALLOCATABLE object %qs of derived type in %s clause at %L",
3787 sym->name, name, &loc);
3788 if ((sym->ts.type == BT_ASSUMED && sym->attr.allocatable)
3789 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
3790 && CLASS_DATA (sym)->attr.allocatable))
3791 gfc_error ("ALLOCATABLE object %qs of polymorphic type "
3792 "in %s clause at %L", sym->name, name, &loc);
3793 check_symbol_not_pointer (sym, loc, name);
3794 check_array_not_assumed (sym, loc, name);
3795 }
3796
3797 static void
3798 resolve_oacc_deviceptr_clause (gfc_symbol *sym, locus loc, const char *name)
3799 {
3800 if (sym->attr.pointer
3801 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
3802 && CLASS_DATA (sym)->attr.class_pointer))
3803 gfc_error ("POINTER object %qs in %s clause at %L",
3804 sym->name, name, &loc);
3805 if (sym->attr.cray_pointer
3806 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
3807 && CLASS_DATA (sym)->attr.cray_pointer))
3808 gfc_error ("Cray pointer object %qs in %s clause at %L",
3809 sym->name, name, &loc);
3810 if (sym->attr.cray_pointee
3811 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
3812 && CLASS_DATA (sym)->attr.cray_pointee))
3813 gfc_error ("Cray pointee object %qs in %s clause at %L",
3814 sym->name, name, &loc);
3815 if (sym->attr.allocatable
3816 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
3817 && CLASS_DATA (sym)->attr.allocatable))
3818 gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
3819 sym->name, name, &loc);
3820 if (sym->attr.value)
3821 gfc_error ("VALUE object %qs in %s clause at %L",
3822 sym->name, name, &loc);
3823 check_array_not_assumed (sym, loc, name);
3824 }
3825
3826
3827 struct resolve_omp_udr_callback_data
3828 {
3829 gfc_symbol *sym1, *sym2;
3830 };
3831
3832
3833 static int
3834 resolve_omp_udr_callback (gfc_expr **e, int *, void *data)
3835 {
3836 struct resolve_omp_udr_callback_data *rcd
3837 = (struct resolve_omp_udr_callback_data *) data;
3838 if ((*e)->expr_type == EXPR_VARIABLE
3839 && ((*e)->symtree->n.sym == rcd->sym1
3840 || (*e)->symtree->n.sym == rcd->sym2))
3841 {
3842 gfc_ref *ref = gfc_get_ref ();
3843 ref->type = REF_ARRAY;
3844 ref->u.ar.where = (*e)->where;
3845 ref->u.ar.as = (*e)->symtree->n.sym->as;
3846 ref->u.ar.type = AR_FULL;
3847 ref->u.ar.dimen = 0;
3848 ref->next = (*e)->ref;
3849 (*e)->ref = ref;
3850 }
3851 return 0;
3852 }
3853
3854
3855 static int
3856 resolve_omp_udr_callback2 (gfc_expr **e, int *, void *)
3857 {
3858 if ((*e)->expr_type == EXPR_FUNCTION
3859 && (*e)->value.function.isym == NULL)
3860 {
3861 gfc_symbol *sym = (*e)->symtree->n.sym;
3862 if (!sym->attr.intrinsic
3863 && sym->attr.if_source == IFSRC_UNKNOWN)
3864 gfc_error ("Implicitly declared function %s used in "
3865 "!$OMP DECLARE REDUCTION at %L", sym->name, &(*e)->where);
3866 }
3867 return 0;
3868 }
3869
3870
3871 static gfc_code *
3872 resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns,
3873 gfc_symbol *sym1, gfc_symbol *sym2)
3874 {
3875 gfc_code *copy;
3876 gfc_symbol sym1_copy, sym2_copy;
3877
3878 if (ns->code->op == EXEC_ASSIGN)
3879 {
3880 copy = gfc_get_code (EXEC_ASSIGN);
3881 copy->expr1 = gfc_copy_expr (ns->code->expr1);
3882 copy->expr2 = gfc_copy_expr (ns->code->expr2);
3883 }
3884 else
3885 {
3886 copy = gfc_get_code (EXEC_CALL);
3887 copy->symtree = ns->code->symtree;
3888 copy->ext.actual = gfc_copy_actual_arglist (ns->code->ext.actual);
3889 }
3890 copy->loc = ns->code->loc;
3891 sym1_copy = *sym1;
3892 sym2_copy = *sym2;
3893 *sym1 = *n->sym;
3894 *sym2 = *n->sym;
3895 sym1->name = sym1_copy.name;
3896 sym2->name = sym2_copy.name;
3897 ns->proc_name = ns->parent->proc_name;
3898 if (n->sym->attr.dimension)
3899 {
3900 struct resolve_omp_udr_callback_data rcd;
3901 rcd.sym1 = sym1;
3902 rcd.sym2 = sym2;
3903 gfc_code_walker (&copy, gfc_dummy_code_callback,
3904 resolve_omp_udr_callback, &rcd);
3905 }
3906 gfc_resolve_code (copy, gfc_current_ns);
3907 if (copy->op == EXEC_CALL && copy->resolved_isym == NULL)
3908 {
3909 gfc_symbol *sym = copy->resolved_sym;
3910 if (sym
3911 && !sym->attr.intrinsic
3912 && sym->attr.if_source == IFSRC_UNKNOWN)
3913 gfc_error ("Implicitly declared subroutine %s used in "
3914 "!$OMP DECLARE REDUCTION at %L", sym->name,
3915 &copy->loc);
3916 }
3917 gfc_code_walker (&copy, gfc_dummy_code_callback,
3918 resolve_omp_udr_callback2, NULL);
3919 *sym1 = sym1_copy;
3920 *sym2 = sym2_copy;
3921 return copy;
3922 }
3923
3924 /* OpenMP directive resolving routines. */
3925
3926 static void
3927 resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
3928 gfc_namespace *ns, bool openacc = false)
3929 {
3930 gfc_omp_namelist *n;
3931 gfc_expr_list *el;
3932 int list;
3933 int ifc;
3934 bool if_without_mod = false;
3935 gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
3936 static const char *clause_names[]
3937 = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
3938 "COPYIN", "UNIFORM", "ALIGNED", "LINEAR", "DEPEND", "MAP",
3939 "TO", "FROM", "REDUCTION", "DEVICE_RESIDENT", "LINK", "USE_DEVICE",
3940 "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR" };
3941
3942 if (omp_clauses == NULL)
3943 return;
3944
3945 if (omp_clauses->orderedc && omp_clauses->orderedc < omp_clauses->collapse)
3946 gfc_error ("ORDERED clause parameter is less than COLLAPSE at %L",
3947 &code->loc);
3948
3949 if (omp_clauses->if_expr)
3950 {
3951 gfc_expr *expr = omp_clauses->if_expr;
3952 if (!gfc_resolve_expr (expr)
3953 || expr->ts.type != BT_LOGICAL || expr->rank != 0)
3954 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
3955 &expr->where);
3956 if_without_mod = true;
3957 }
3958 for (ifc = 0; ifc < OMP_IF_LAST; ifc++)
3959 if (omp_clauses->if_exprs[ifc])
3960 {
3961 gfc_expr *expr = omp_clauses->if_exprs[ifc];
3962 bool ok = true;
3963 if (!gfc_resolve_expr (expr)
3964 || expr->ts.type != BT_LOGICAL || expr->rank != 0)
3965 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
3966 &expr->where);
3967 else if (if_without_mod)
3968 {
3969 gfc_error ("IF clause without modifier at %L used together with "
3970 "IF clauses with modifiers",
3971 &omp_clauses->if_expr->where);
3972 if_without_mod = false;
3973 }
3974 else
3975 switch (code->op)
3976 {
3977 case EXEC_OMP_PARALLEL:
3978 case EXEC_OMP_PARALLEL_DO:
3979 case EXEC_OMP_PARALLEL_SECTIONS:
3980 case EXEC_OMP_PARALLEL_WORKSHARE:
3981 case EXEC_OMP_PARALLEL_DO_SIMD:
3982 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
3983 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
3984 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
3985 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
3986 ok = ifc == OMP_IF_PARALLEL;
3987 break;
3988
3989 case EXEC_OMP_TASK:
3990 ok = ifc == OMP_IF_TASK;
3991 break;
3992
3993 case EXEC_OMP_TASKLOOP:
3994 case EXEC_OMP_TASKLOOP_SIMD:
3995 ok = ifc == OMP_IF_TASKLOOP;
3996 break;
3997
3998 case EXEC_OMP_TARGET:
3999 case EXEC_OMP_TARGET_TEAMS:
4000 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
4001 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
4002 case EXEC_OMP_TARGET_SIMD:
4003 ok = ifc == OMP_IF_TARGET;
4004 break;
4005
4006 case EXEC_OMP_TARGET_DATA:
4007 ok = ifc == OMP_IF_TARGET_DATA;
4008 break;
4009
4010 case EXEC_OMP_TARGET_UPDATE:
4011 ok = ifc == OMP_IF_TARGET_UPDATE;
4012 break;
4013
4014 case EXEC_OMP_TARGET_ENTER_DATA:
4015 ok = ifc == OMP_IF_TARGET_ENTER_DATA;
4016 break;
4017
4018 case EXEC_OMP_TARGET_EXIT_DATA:
4019 ok = ifc == OMP_IF_TARGET_EXIT_DATA;
4020 break;
4021
4022 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
4023 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4024 case EXEC_OMP_TARGET_PARALLEL:
4025 case EXEC_OMP_TARGET_PARALLEL_DO:
4026 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
4027 ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_PARALLEL;
4028 break;
4029
4030 default:
4031 ok = false;
4032 break;
4033 }
4034 if (!ok)
4035 {
4036 static const char *ifs[] = {
4037 "PARALLEL",
4038 "TASK",
4039 "TASKLOOP",
4040 "TARGET",
4041 "TARGET DATA",
4042 "TARGET UPDATE",
4043 "TARGET ENTER DATA",
4044 "TARGET EXIT DATA"
4045 };
4046 gfc_error ("IF clause modifier %s at %L not appropriate for "
4047 "the current OpenMP construct", ifs[ifc], &expr->where);
4048 }
4049 }
4050
4051 if (omp_clauses->final_expr)
4052 {
4053 gfc_expr *expr = omp_clauses->final_expr;
4054 if (!gfc_resolve_expr (expr)
4055 || expr->ts.type != BT_LOGICAL || expr->rank != 0)
4056 gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression",
4057 &expr->where);
4058 }
4059 if (omp_clauses->num_threads)
4060 resolve_positive_int_expr (omp_clauses->num_threads, "NUM_THREADS");
4061 if (omp_clauses->chunk_size)
4062 {
4063 gfc_expr *expr = omp_clauses->chunk_size;
4064 if (!gfc_resolve_expr (expr)
4065 || expr->ts.type != BT_INTEGER || expr->rank != 0)
4066 gfc_error ("SCHEDULE clause's chunk_size at %L requires "
4067 "a scalar INTEGER expression", &expr->where);
4068 else if (expr->expr_type == EXPR_CONSTANT
4069 && expr->ts.type == BT_INTEGER
4070 && mpz_sgn (expr->value.integer) <= 0)
4071 gfc_warning (0, "INTEGER expression of SCHEDULE clause's chunk_size "
4072 "at %L must be positive", &expr->where);
4073 }
4074
4075 /* Check that no symbol appears on multiple clauses, except that
4076 a symbol can appear on both firstprivate and lastprivate. */
4077 for (list = 0; list < OMP_LIST_NUM; list++)
4078 for (n = omp_clauses->lists[list]; n; n = n->next)
4079 {
4080 n->sym->mark = 0;
4081 if (n->sym->attr.flavor == FL_VARIABLE
4082 || n->sym->attr.proc_pointer
4083 || (!code && (!n->sym->attr.dummy || n->sym->ns != ns)))
4084 {
4085 if (!code && (!n->sym->attr.dummy || n->sym->ns != ns))
4086 gfc_error ("Variable %qs is not a dummy argument at %L",
4087 n->sym->name, &n->where);
4088 continue;
4089 }
4090 if (n->sym->attr.flavor == FL_PROCEDURE
4091 && n->sym->result == n->sym
4092 && n->sym->attr.function)
4093 {
4094 if (gfc_current_ns->proc_name == n->sym
4095 || (gfc_current_ns->parent
4096 && gfc_current_ns->parent->proc_name == n->sym))
4097 continue;
4098 if (gfc_current_ns->proc_name->attr.entry_master)
4099 {
4100 gfc_entry_list *el = gfc_current_ns->entries;
4101 for (; el; el = el->next)
4102 if (el->sym == n->sym)
4103 break;
4104 if (el)
4105 continue;
4106 }
4107 if (gfc_current_ns->parent
4108 && gfc_current_ns->parent->proc_name->attr.entry_master)
4109 {
4110 gfc_entry_list *el = gfc_current_ns->parent->entries;
4111 for (; el; el = el->next)
4112 if (el->sym == n->sym)
4113 break;
4114 if (el)
4115 continue;
4116 }
4117 }
4118 gfc_error ("Object %qs is not a variable at %L", n->sym->name,
4119 &n->where);
4120 }
4121
4122 for (list = 0; list < OMP_LIST_NUM; list++)
4123 if (list != OMP_LIST_FIRSTPRIVATE
4124 && list != OMP_LIST_LASTPRIVATE
4125 && list != OMP_LIST_ALIGNED
4126 && list != OMP_LIST_DEPEND
4127 && (list != OMP_LIST_MAP || openacc)
4128 && list != OMP_LIST_FROM
4129 && list != OMP_LIST_TO
4130 && (list != OMP_LIST_REDUCTION || !openacc))
4131 for (n = omp_clauses->lists[list]; n; n = n->next)
4132 {
4133 if (n->sym->mark)
4134 gfc_error ("Symbol %qs present on multiple clauses at %L",
4135 n->sym->name, &n->where);
4136 else
4137 n->sym->mark = 1;
4138 }
4139
4140 gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1);
4141 for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE; list++)
4142 for (n = omp_clauses->lists[list]; n; n = n->next)
4143 if (n->sym->mark)
4144 {
4145 gfc_error ("Symbol %qs present on multiple clauses at %L",
4146 n->sym->name, &n->where);
4147 n->sym->mark = 0;
4148 }
4149
4150 for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next)
4151 {
4152 if (n->sym->mark)
4153 gfc_error ("Symbol %qs present on multiple clauses at %L",
4154 n->sym->name, &n->where);
4155 else
4156 n->sym->mark = 1;
4157 }
4158 for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
4159 n->sym->mark = 0;
4160
4161 for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
4162 {
4163 if (n->sym->mark)
4164 gfc_error ("Symbol %qs present on multiple clauses at %L",
4165 n->sym->name, &n->where);
4166 else
4167 n->sym->mark = 1;
4168 }
4169
4170 for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
4171 n->sym->mark = 0;
4172
4173 for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
4174 {
4175 if (n->sym->mark)
4176 gfc_error ("Symbol %qs present on multiple clauses at %L",
4177 n->sym->name, &n->where);
4178 else
4179 n->sym->mark = 1;
4180 }
4181
4182 /* OpenACC reductions. */
4183 if (openacc)
4184 {
4185 for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next)
4186 n->sym->mark = 0;
4187
4188 for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next)
4189 {
4190 if (n->sym->mark)
4191 gfc_error ("Symbol %qs present on multiple clauses at %L",
4192 n->sym->name, &n->where);
4193 else
4194 n->sym->mark = 1;
4195
4196 /* OpenACC does not support reductions on arrays. */
4197 if (n->sym->as)
4198 gfc_error ("Array %qs is not permitted in reduction at %L",
4199 n->sym->name, &n->where);
4200 }
4201 }
4202
4203 for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
4204 n->sym->mark = 0;
4205 for (n = omp_clauses->lists[OMP_LIST_FROM]; n; n = n->next)
4206 if (n->expr == NULL)
4207 n->sym->mark = 1;
4208 for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
4209 {
4210 if (n->expr == NULL && n->sym->mark)
4211 gfc_error ("Symbol %qs present on both FROM and TO clauses at %L",
4212 n->sym->name, &n->where);
4213 else
4214 n->sym->mark = 1;
4215 }
4216
4217 for (list = 0; list < OMP_LIST_NUM; list++)
4218 if ((n = omp_clauses->lists[list]) != NULL)
4219 {
4220 const char *name;
4221
4222 if (list < OMP_LIST_NUM)
4223 name = clause_names[list];
4224 else
4225 gcc_unreachable ();
4226
4227 switch (list)
4228 {
4229 case OMP_LIST_COPYIN:
4230 for (; n != NULL; n = n->next)
4231 {
4232 if (!n->sym->attr.threadprivate)
4233 gfc_error ("Non-THREADPRIVATE object %qs in COPYIN clause"
4234 " at %L", n->sym->name, &n->where);
4235 }
4236 break;
4237 case OMP_LIST_COPYPRIVATE:
4238 for (; n != NULL; n = n->next)
4239 {
4240 if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
4241 gfc_error ("Assumed size array %qs in COPYPRIVATE clause "
4242 "at %L", n->sym->name, &n->where);
4243 if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
4244 gfc_error ("INTENT(IN) POINTER %qs in COPYPRIVATE clause "
4245 "at %L", n->sym->name, &n->where);
4246 }
4247 break;
4248 case OMP_LIST_SHARED:
4249 for (; n != NULL; n = n->next)
4250 {
4251 if (n->sym->attr.threadprivate)
4252 gfc_error ("THREADPRIVATE object %qs in SHARED clause at "
4253 "%L", n->sym->name, &n->where);
4254 if (n->sym->attr.cray_pointee)
4255 gfc_error ("Cray pointee %qs in SHARED clause at %L",
4256 n->sym->name, &n->where);
4257 if (n->sym->attr.associate_var)
4258 gfc_error ("ASSOCIATE name %qs in SHARED clause at %L",
4259 n->sym->name, &n->where);
4260 }
4261 break;
4262 case OMP_LIST_ALIGNED:
4263 for (; n != NULL; n = n->next)
4264 {
4265 if (!n->sym->attr.pointer
4266 && !n->sym->attr.allocatable
4267 && !n->sym->attr.cray_pointer
4268 && (n->sym->ts.type != BT_DERIVED
4269 || (n->sym->ts.u.derived->from_intmod
4270 != INTMOD_ISO_C_BINDING)
4271 || (n->sym->ts.u.derived->intmod_sym_id
4272 != ISOCBINDING_PTR)))
4273 gfc_error ("%qs in ALIGNED clause must be POINTER, "
4274 "ALLOCATABLE, Cray pointer or C_PTR at %L",
4275 n->sym->name, &n->where);
4276 else if (n->expr)
4277 {
4278 gfc_expr *expr = n->expr;
4279 int alignment = 0;
4280 if (!gfc_resolve_expr (expr)
4281 || expr->ts.type != BT_INTEGER
4282 || expr->rank != 0
4283 || gfc_extract_int (expr, &alignment)
4284 || alignment <= 0)
4285 gfc_error ("%qs in ALIGNED clause at %L requires a scalar "
4286 "positive constant integer alignment "
4287 "expression", n->sym->name, &n->where);
4288 }
4289 }
4290 break;
4291 case OMP_LIST_DEPEND:
4292 case OMP_LIST_MAP:
4293 case OMP_LIST_TO:
4294 case OMP_LIST_FROM:
4295 case OMP_LIST_CACHE:
4296 for (; n != NULL; n = n->next)
4297 {
4298 if (list == OMP_LIST_DEPEND)
4299 {
4300 if (n->u.depend_op == OMP_DEPEND_SINK_FIRST
4301 || n->u.depend_op == OMP_DEPEND_SINK)
4302 {
4303 if (code->op != EXEC_OMP_ORDERED)
4304 gfc_error ("SINK dependence type only allowed "
4305 "on ORDERED directive at %L", &n->where);
4306 else if (omp_clauses->depend_source)
4307 {
4308 gfc_error ("DEPEND SINK used together with "
4309 "DEPEND SOURCE on the same construct "
4310 "at %L", &n->where);
4311 omp_clauses->depend_source = false;
4312 }
4313 else if (n->expr)
4314 {
4315 if (!gfc_resolve_expr (n->expr)
4316 || n->expr->ts.type != BT_INTEGER
4317 || n->expr->rank != 0)
4318 gfc_error ("SINK addend not a constant integer "
4319 "at %L", &n->where);
4320 }
4321 continue;
4322 }
4323 else if (code->op == EXEC_OMP_ORDERED)
4324 gfc_error ("Only SOURCE or SINK dependence types "
4325 "are allowed on ORDERED directive at %L",
4326 &n->where);
4327 }
4328 if (n->expr)
4329 {
4330 if (!gfc_resolve_expr (n->expr)
4331 || n->expr->expr_type != EXPR_VARIABLE
4332 || n->expr->ref == NULL
4333 || n->expr->ref->next
4334 || n->expr->ref->type != REF_ARRAY)
4335 gfc_error ("%qs in %s clause at %L is not a proper "
4336 "array section", n->sym->name, name,
4337 &n->where);
4338 else if (n->expr->ref->u.ar.codimen)
4339 gfc_error ("Coarrays not supported in %s clause at %L",
4340 name, &n->where);
4341 else
4342 {
4343 int i;
4344 gfc_array_ref *ar = &n->expr->ref->u.ar;
4345 for (i = 0; i < ar->dimen; i++)
4346 if (ar->stride[i])
4347 {
4348 gfc_error ("Stride should not be specified for "
4349 "array section in %s clause at %L",
4350 name, &n->where);
4351 break;
4352 }
4353 else if (ar->dimen_type[i] != DIMEN_ELEMENT
4354 && ar->dimen_type[i] != DIMEN_RANGE)
4355 {
4356 gfc_error ("%qs in %s clause at %L is not a "
4357 "proper array section",
4358 n->sym->name, name, &n->where);
4359 break;
4360 }
4361 else if (list == OMP_LIST_DEPEND
4362 && ar->start[i]
4363 && ar->start[i]->expr_type == EXPR_CONSTANT
4364 && ar->end[i]
4365 && ar->end[i]->expr_type == EXPR_CONSTANT
4366 && mpz_cmp (ar->start[i]->value.integer,
4367 ar->end[i]->value.integer) > 0)
4368 {
4369 gfc_error ("%qs in DEPEND clause at %L is a "
4370 "zero size array section",
4371 n->sym->name, &n->where);
4372 break;
4373 }
4374 }
4375 }
4376 else if (openacc)
4377 {
4378 if (list == OMP_LIST_MAP
4379 && n->u.map_op == OMP_MAP_FORCE_DEVICEPTR)
4380 resolve_oacc_deviceptr_clause (n->sym, n->where, name);
4381 else
4382 resolve_oacc_data_clauses (n->sym, n->where, name);
4383 }
4384 else if (list != OMP_LIST_DEPEND
4385 && n->sym->as
4386 && n->sym->as->type == AS_ASSUMED_SIZE)
4387 gfc_error ("Assumed size array %qs in %s clause at %L",
4388 n->sym->name, name, &n->where);
4389 if (list == OMP_LIST_MAP && !openacc)
4390 switch (code->op)
4391 {
4392 case EXEC_OMP_TARGET:
4393 case EXEC_OMP_TARGET_DATA:
4394 switch (n->u.map_op)
4395 {
4396 case OMP_MAP_TO:
4397 case OMP_MAP_ALWAYS_TO:
4398 case OMP_MAP_FROM:
4399 case OMP_MAP_ALWAYS_FROM:
4400 case OMP_MAP_TOFROM:
4401 case OMP_MAP_ALWAYS_TOFROM:
4402 case OMP_MAP_ALLOC:
4403 break;
4404 default:
4405 gfc_error ("TARGET%s with map-type other than TO, "
4406 "FROM, TOFROM, or ALLOC on MAP clause "
4407 "at %L",
4408 code->op == EXEC_OMP_TARGET
4409 ? "" : " DATA", &n->where);
4410 break;
4411 }
4412 break;
4413 case EXEC_OMP_TARGET_ENTER_DATA:
4414 switch (n->u.map_op)
4415 {
4416 case OMP_MAP_TO:
4417 case OMP_MAP_ALWAYS_TO:
4418 case OMP_MAP_ALLOC:
4419 break;
4420 default:
4421 gfc_error ("TARGET ENTER DATA with map-type other "
4422 "than TO, or ALLOC on MAP clause at %L",
4423 &n->where);
4424 break;
4425 }
4426 break;
4427 case EXEC_OMP_TARGET_EXIT_DATA:
4428 switch (n->u.map_op)
4429 {
4430 case OMP_MAP_FROM:
4431 case OMP_MAP_ALWAYS_FROM:
4432 case OMP_MAP_RELEASE:
4433 case OMP_MAP_DELETE:
4434 break;
4435 default:
4436 gfc_error ("TARGET EXIT DATA with map-type other "
4437 "than FROM, RELEASE, or DELETE on MAP "
4438 "clause at %L", &n->where);
4439 break;
4440 }
4441 break;
4442 default:
4443 break;
4444 }
4445 }
4446
4447 if (list != OMP_LIST_DEPEND)
4448 for (n = omp_clauses->lists[list]; n != NULL; n = n->next)
4449 {
4450 n->sym->attr.referenced = 1;
4451 if (n->sym->attr.threadprivate)
4452 gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
4453 n->sym->name, name, &n->where);
4454 if (n->sym->attr.cray_pointee)
4455 gfc_error ("Cray pointee %qs in %s clause at %L",
4456 n->sym->name, name, &n->where);
4457 }
4458 break;
4459 case OMP_LIST_IS_DEVICE_PTR:
4460 case OMP_LIST_USE_DEVICE_PTR:
4461 /* FIXME: Handle these. */
4462 break;
4463 default:
4464 for (; n != NULL; n = n->next)
4465 {
4466 bool bad = false;
4467 if (n->sym->attr.threadprivate)
4468 gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
4469 n->sym->name, name, &n->where);
4470 if (n->sym->attr.cray_pointee)
4471 gfc_error ("Cray pointee %qs in %s clause at %L",
4472 n->sym->name, name, &n->where);
4473 if (n->sym->attr.associate_var)
4474 gfc_error ("ASSOCIATE name %qs in %s clause at %L",
4475 n->sym->name, name, &n->where);
4476 if (list != OMP_LIST_PRIVATE)
4477 {
4478 if (n->sym->attr.proc_pointer && list == OMP_LIST_REDUCTION)
4479 gfc_error ("Procedure pointer %qs in %s clause at %L",
4480 n->sym->name, name, &n->where);
4481 if (n->sym->attr.pointer && list == OMP_LIST_REDUCTION)
4482 gfc_error ("POINTER object %qs in %s clause at %L",
4483 n->sym->name, name, &n->where);
4484 if (n->sym->attr.cray_pointer && list == OMP_LIST_REDUCTION)
4485 gfc_error ("Cray pointer %qs in %s clause at %L",
4486 n->sym->name, name, &n->where);
4487 }
4488 if (code
4489 && (oacc_is_loop (code) || code->op == EXEC_OACC_PARALLEL))
4490 check_array_not_assumed (n->sym, n->where, name);
4491 else if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
4492 gfc_error ("Assumed size array %qs in %s clause at %L",
4493 n->sym->name, name, &n->where);
4494 if (n->sym->attr.in_namelist && list != OMP_LIST_REDUCTION)
4495 gfc_error ("Variable %qs in %s clause is used in "
4496 "NAMELIST statement at %L",
4497 n->sym->name, name, &n->where);
4498 if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
4499 switch (list)
4500 {
4501 case OMP_LIST_PRIVATE:
4502 case OMP_LIST_LASTPRIVATE:
4503 case OMP_LIST_LINEAR:
4504 /* case OMP_LIST_REDUCTION: */
4505 gfc_error ("INTENT(IN) POINTER %qs in %s clause at %L",
4506 n->sym->name, name, &n->where);
4507 break;
4508 default:
4509 break;
4510 }
4511
4512 switch (list)
4513 {
4514 case OMP_LIST_REDUCTION:
4515 switch (n->u.reduction_op)
4516 {
4517 case OMP_REDUCTION_PLUS:
4518 case OMP_REDUCTION_TIMES:
4519 case OMP_REDUCTION_MINUS:
4520 if (!gfc_numeric_ts (&n->sym->ts))
4521 bad = true;
4522 break;
4523 case OMP_REDUCTION_AND:
4524 case OMP_REDUCTION_OR:
4525 case OMP_REDUCTION_EQV:
4526 case OMP_REDUCTION_NEQV:
4527 if (n->sym->ts.type != BT_LOGICAL)
4528 bad = true;
4529 break;
4530 case OMP_REDUCTION_MAX:
4531 case OMP_REDUCTION_MIN:
4532 if (n->sym->ts.type != BT_INTEGER
4533 && n->sym->ts.type != BT_REAL)
4534 bad = true;
4535 break;
4536 case OMP_REDUCTION_IAND:
4537 case OMP_REDUCTION_IOR:
4538 case OMP_REDUCTION_IEOR:
4539 if (n->sym->ts.type != BT_INTEGER)
4540 bad = true;
4541 break;
4542 case OMP_REDUCTION_USER:
4543 bad = true;
4544 break;
4545 default:
4546 break;
4547 }
4548 if (!bad)
4549 n->udr = NULL;
4550 else
4551 {
4552 const char *udr_name = NULL;
4553 if (n->udr)
4554 {
4555 udr_name = n->udr->udr->name;
4556 n->udr->udr
4557 = gfc_find_omp_udr (NULL, udr_name,
4558 &n->sym->ts);
4559 if (n->udr->udr == NULL)
4560 {
4561 free (n->udr);
4562 n->udr = NULL;
4563 }
4564 }
4565 if (n->udr == NULL)
4566 {
4567 if (udr_name == NULL)
4568 switch (n->u.reduction_op)
4569 {
4570 case OMP_REDUCTION_PLUS:
4571 case OMP_REDUCTION_TIMES:
4572 case OMP_REDUCTION_MINUS:
4573 case OMP_REDUCTION_AND:
4574 case OMP_REDUCTION_OR:
4575 case OMP_REDUCTION_EQV:
4576 case OMP_REDUCTION_NEQV:
4577 udr_name = gfc_op2string ((gfc_intrinsic_op)
4578 n->u.reduction_op);
4579 break;
4580 case OMP_REDUCTION_MAX:
4581 udr_name = "max";
4582 break;
4583 case OMP_REDUCTION_MIN:
4584 udr_name = "min";
4585 break;
4586 case OMP_REDUCTION_IAND:
4587 udr_name = "iand";
4588 break;
4589 case OMP_REDUCTION_IOR:
4590 udr_name = "ior";
4591 break;
4592 case OMP_REDUCTION_IEOR:
4593 udr_name = "ieor";
4594 break;
4595 default:
4596 gcc_unreachable ();
4597 }
4598 gfc_error ("!$OMP DECLARE REDUCTION %s not found "
4599 "for type %s at %L", udr_name,
4600 gfc_typename (&n->sym->ts), &n->where);
4601 }
4602 else
4603 {
4604 gfc_omp_udr *udr = n->udr->udr;
4605 n->u.reduction_op = OMP_REDUCTION_USER;
4606 n->udr->combiner
4607 = resolve_omp_udr_clause (n, udr->combiner_ns,
4608 udr->omp_out,
4609 udr->omp_in);
4610 if (udr->initializer_ns)
4611 n->udr->initializer
4612 = resolve_omp_udr_clause (n,
4613 udr->initializer_ns,
4614 udr->omp_priv,
4615 udr->omp_orig);
4616 }
4617 }
4618 break;
4619 case OMP_LIST_LINEAR:
4620 if (code
4621 && n->u.linear_op != OMP_LINEAR_DEFAULT
4622 && n->u.linear_op != linear_op)
4623 {
4624 gfc_error ("LINEAR clause modifier used on DO or SIMD"
4625 " construct at %L", &n->where);
4626 linear_op = n->u.linear_op;
4627 }
4628 else if (omp_clauses->orderedc)
4629 gfc_error ("LINEAR clause specified together with "
4630 "ORDERED clause with argument at %L",
4631 &n->where);
4632 else if (n->u.linear_op != OMP_LINEAR_REF
4633 && n->sym->ts.type != BT_INTEGER)
4634 gfc_error ("LINEAR variable %qs must be INTEGER "
4635 "at %L", n->sym->name, &n->where);
4636 else if ((n->u.linear_op == OMP_LINEAR_REF
4637 || n->u.linear_op == OMP_LINEAR_UVAL)
4638 && n->sym->attr.value)
4639 gfc_error ("LINEAR dummy argument %qs with VALUE "
4640 "attribute with %s modifier at %L",
4641 n->sym->name,
4642 n->u.linear_op == OMP_LINEAR_REF
4643 ? "REF" : "UVAL", &n->where);
4644 else if (n->expr)
4645 {
4646 gfc_expr *expr = n->expr;
4647 if (!gfc_resolve_expr (expr)
4648 || expr->ts.type != BT_INTEGER
4649 || expr->rank != 0)
4650 gfc_error ("%qs in LINEAR clause at %L requires "
4651 "a scalar integer linear-step expression",
4652 n->sym->name, &n->where);
4653 else if (!code && expr->expr_type != EXPR_CONSTANT)
4654 {
4655 if (expr->expr_type == EXPR_VARIABLE
4656 && expr->symtree->n.sym->attr.dummy
4657 && expr->symtree->n.sym->ns == ns)
4658 {
4659 gfc_omp_namelist *n2;
4660 for (n2 = omp_clauses->lists[OMP_LIST_UNIFORM];
4661 n2; n2 = n2->next)
4662 if (n2->sym == expr->symtree->n.sym)
4663 break;
4664 if (n2)
4665 break;
4666 }
4667 gfc_error ("%qs in LINEAR clause at %L requires "
4668 "a constant integer linear-step "
4669 "expression or dummy argument "
4670 "specified in UNIFORM clause",
4671 n->sym->name, &n->where);
4672 }
4673 }
4674 break;
4675 /* Workaround for PR middle-end/26316, nothing really needs
4676 to be done here for OMP_LIST_PRIVATE. */
4677 case OMP_LIST_PRIVATE:
4678 gcc_assert (code && code->op != EXEC_NOP);
4679 break;
4680 case OMP_LIST_USE_DEVICE:
4681 if (n->sym->attr.allocatable
4682 || (n->sym->ts.type == BT_CLASS && CLASS_DATA (n->sym)
4683 && CLASS_DATA (n->sym)->attr.allocatable))
4684 gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
4685 n->sym->name, name, &n->where);
4686 if (n->sym->ts.type == BT_CLASS
4687 && CLASS_DATA (n->sym)
4688 && CLASS_DATA (n->sym)->attr.class_pointer)
4689 gfc_error ("POINTER object %qs of polymorphic type in "
4690 "%s clause at %L", n->sym->name, name,
4691 &n->where);
4692 if (n->sym->attr.cray_pointer)
4693 gfc_error ("Cray pointer object %qs in %s clause at %L",
4694 n->sym->name, name, &n->where);
4695 else if (n->sym->attr.cray_pointee)
4696 gfc_error ("Cray pointee object %qs in %s clause at %L",
4697 n->sym->name, name, &n->where);
4698 else if (n->sym->attr.flavor == FL_VARIABLE
4699 && !n->sym->as
4700 && !n->sym->attr.pointer)
4701 gfc_error ("%s clause variable %qs at %L is neither "
4702 "a POINTER nor an array", name,
4703 n->sym->name, &n->where);
4704 /* FALLTHRU */
4705 case OMP_LIST_DEVICE_RESIDENT:
4706 check_symbol_not_pointer (n->sym, n->where, name);
4707 check_array_not_assumed (n->sym, n->where, name);
4708 break;
4709 default:
4710 break;
4711 }
4712 }
4713 break;
4714 }
4715 }
4716 if (omp_clauses->safelen_expr)
4717 resolve_positive_int_expr (omp_clauses->safelen_expr, "SAFELEN");
4718 if (omp_clauses->simdlen_expr)
4719 resolve_positive_int_expr (omp_clauses->simdlen_expr, "SIMDLEN");
4720 if (omp_clauses->num_teams)
4721 resolve_positive_int_expr (omp_clauses->num_teams, "NUM_TEAMS");
4722 if (omp_clauses->device)
4723 resolve_nonnegative_int_expr (omp_clauses->device, "DEVICE");
4724 if (omp_clauses->hint)
4725 resolve_scalar_int_expr (omp_clauses->hint, "HINT");
4726 if (omp_clauses->priority)
4727 resolve_nonnegative_int_expr (omp_clauses->priority, "PRIORITY");
4728 if (omp_clauses->dist_chunk_size)
4729 {
4730 gfc_expr *expr = omp_clauses->dist_chunk_size;
4731 if (!gfc_resolve_expr (expr)
4732 || expr->ts.type != BT_INTEGER || expr->rank != 0)
4733 gfc_error ("DIST_SCHEDULE clause's chunk_size at %L requires "
4734 "a scalar INTEGER expression", &expr->where);
4735 }
4736 if (omp_clauses->thread_limit)
4737 resolve_positive_int_expr (omp_clauses->thread_limit, "THREAD_LIMIT");
4738 if (omp_clauses->grainsize)
4739 resolve_positive_int_expr (omp_clauses->grainsize, "GRAINSIZE");
4740 if (omp_clauses->num_tasks)
4741 resolve_positive_int_expr (omp_clauses->num_tasks, "NUM_TASKS");
4742 if (omp_clauses->async)
4743 if (omp_clauses->async_expr)
4744 resolve_scalar_int_expr (omp_clauses->async_expr, "ASYNC");
4745 if (omp_clauses->num_gangs_expr)
4746 resolve_positive_int_expr (omp_clauses->num_gangs_expr, "NUM_GANGS");
4747 if (omp_clauses->num_workers_expr)
4748 resolve_positive_int_expr (omp_clauses->num_workers_expr, "NUM_WORKERS");
4749 if (omp_clauses->vector_length_expr)
4750 resolve_positive_int_expr (omp_clauses->vector_length_expr,
4751 "VECTOR_LENGTH");
4752 if (omp_clauses->gang_num_expr)
4753 resolve_positive_int_expr (omp_clauses->gang_num_expr, "GANG");
4754 if (omp_clauses->gang_static_expr)
4755 resolve_positive_int_expr (omp_clauses->gang_static_expr, "GANG");
4756 if (omp_clauses->worker_expr)
4757 resolve_positive_int_expr (omp_clauses->worker_expr, "WORKER");
4758 if (omp_clauses->vector_expr)
4759 resolve_positive_int_expr (omp_clauses->vector_expr, "VECTOR");
4760 if (omp_clauses->wait)
4761 if (omp_clauses->wait_list)
4762 for (el = omp_clauses->wait_list; el; el = el->next)
4763 resolve_scalar_int_expr (el->expr, "WAIT");
4764 if (omp_clauses->collapse && omp_clauses->tile_list)
4765 gfc_error ("Incompatible use of TILE and COLLAPSE at %L", &code->loc);
4766 if (omp_clauses->depend_source && code->op != EXEC_OMP_ORDERED)
4767 gfc_error ("SOURCE dependence type only allowed "
4768 "on ORDERED directive at %L", &code->loc);
4769 if (!openacc && code && omp_clauses->lists[OMP_LIST_MAP] == NULL)
4770 {
4771 const char *p = NULL;
4772 switch (code->op)
4773 {
4774 case EXEC_OMP_TARGET_DATA: p = "TARGET DATA"; break;
4775 case EXEC_OMP_TARGET_ENTER_DATA: p = "TARGET ENTER DATA"; break;
4776 case EXEC_OMP_TARGET_EXIT_DATA: p = "TARGET EXIT DATA"; break;
4777 default: break;
4778 }
4779 if (p)
4780 gfc_error ("%s must contain at least one MAP clause at %L",
4781 p, &code->loc);
4782 }
4783 }
4784
4785
4786 /* Return true if SYM is ever referenced in EXPR except in the SE node. */
4787
4788 static bool
4789 expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
4790 {
4791 gfc_actual_arglist *arg;
4792 if (e == NULL || e == se)
4793 return false;
4794 switch (e->expr_type)
4795 {
4796 case EXPR_CONSTANT:
4797 case EXPR_NULL:
4798 case EXPR_VARIABLE:
4799 case EXPR_STRUCTURE:
4800 case EXPR_ARRAY:
4801 if (e->symtree != NULL
4802 && e->symtree->n.sym == s)
4803 return true;
4804 return false;
4805 case EXPR_SUBSTRING:
4806 if (e->ref != NULL
4807 && (expr_references_sym (e->ref->u.ss.start, s, se)
4808 || expr_references_sym (e->ref->u.ss.end, s, se)))
4809 return true;
4810 return false;
4811 case EXPR_OP:
4812 if (expr_references_sym (e->value.op.op2, s, se))
4813 return true;
4814 return expr_references_sym (e->value.op.op1, s, se);
4815 case EXPR_FUNCTION:
4816 for (arg = e->value.function.actual; arg; arg = arg->next)
4817 if (expr_references_sym (arg->expr, s, se))
4818 return true;
4819 return false;
4820 default:
4821 gcc_unreachable ();
4822 }
4823 }
4824
4825
4826 /* If EXPR is a conversion function that widens the type
4827 if WIDENING is true or narrows the type if WIDENING is false,
4828 return the inner expression, otherwise return NULL. */
4829
4830 static gfc_expr *
4831 is_conversion (gfc_expr *expr, bool widening)
4832 {
4833 gfc_typespec *ts1, *ts2;
4834
4835 if (expr->expr_type != EXPR_FUNCTION
4836 || expr->value.function.isym == NULL
4837 || expr->value.function.esym != NULL
4838 || expr->value.function.isym->id != GFC_ISYM_CONVERSION)
4839 return NULL;
4840
4841 if (widening)
4842 {
4843 ts1 = &expr->ts;
4844 ts2 = &expr->value.function.actual->expr->ts;
4845 }
4846 else
4847 {
4848 ts1 = &expr->value.function.actual->expr->ts;
4849 ts2 = &expr->ts;
4850 }
4851
4852 if (ts1->type > ts2->type
4853 || (ts1->type == ts2->type && ts1->kind > ts2->kind))
4854 return expr->value.function.actual->expr;
4855
4856 return NULL;
4857 }
4858
4859
4860 static void
4861 resolve_omp_atomic (gfc_code *code)
4862 {
4863 gfc_code *atomic_code = code;
4864 gfc_symbol *var;
4865 gfc_expr *expr2, *expr2_tmp;
4866 gfc_omp_atomic_op aop
4867 = (gfc_omp_atomic_op) (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK);
4868
4869 code = code->block->next;
4870 /* resolve_blocks asserts this is initially EXEC_ASSIGN.
4871 If it changed to EXEC_NOP, assume an error has been emitted already. */
4872 if (code->op == EXEC_NOP)
4873 return;
4874 if (code->op != EXEC_ASSIGN)
4875 {
4876 unexpected:
4877 gfc_error ("unexpected !$OMP ATOMIC expression at %L", &code->loc);
4878 return;
4879 }
4880 if (aop != GFC_OMP_ATOMIC_CAPTURE)
4881 {
4882 if (code->next != NULL)
4883 goto unexpected;
4884 }
4885 else
4886 {
4887 if (code->next == NULL)
4888 goto unexpected;
4889 if (code->next->op == EXEC_NOP)
4890 return;
4891 if (code->next->op != EXEC_ASSIGN || code->next->next)
4892 {
4893 code = code->next;
4894 goto unexpected;
4895 }
4896 }
4897
4898 if (code->expr1->expr_type != EXPR_VARIABLE
4899 || code->expr1->symtree == NULL
4900 || code->expr1->rank != 0
4901 || (code->expr1->ts.type != BT_INTEGER
4902 && code->expr1->ts.type != BT_REAL
4903 && code->expr1->ts.type != BT_COMPLEX
4904 && code->expr1->ts.type != BT_LOGICAL))
4905 {
4906 gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
4907 "intrinsic type at %L", &code->loc);
4908 return;
4909 }
4910
4911 var = code->expr1->symtree->n.sym;
4912 expr2 = is_conversion (code->expr2, false);
4913 if (expr2 == NULL)
4914 {
4915 if (aop == GFC_OMP_ATOMIC_READ || aop == GFC_OMP_ATOMIC_WRITE)
4916 expr2 = is_conversion (code->expr2, true);
4917 if (expr2 == NULL)
4918 expr2 = code->expr2;
4919 }
4920
4921 switch (aop)
4922 {
4923 case GFC_OMP_ATOMIC_READ:
4924 if (expr2->expr_type != EXPR_VARIABLE
4925 || expr2->symtree == NULL
4926 || expr2->rank != 0
4927 || (expr2->ts.type != BT_INTEGER
4928 && expr2->ts.type != BT_REAL
4929 && expr2->ts.type != BT_COMPLEX
4930 && expr2->ts.type != BT_LOGICAL))
4931 gfc_error ("!$OMP ATOMIC READ statement must read from a scalar "
4932 "variable of intrinsic type at %L", &expr2->where);
4933 return;
4934 case GFC_OMP_ATOMIC_WRITE:
4935 if (expr2->rank != 0 || expr_references_sym (code->expr2, var, NULL))
4936 gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr "
4937 "must be scalar and cannot reference var at %L",
4938 &expr2->where);
4939 return;
4940 case GFC_OMP_ATOMIC_CAPTURE:
4941 expr2_tmp = expr2;
4942 if (expr2 == code->expr2)
4943 {
4944 expr2_tmp = is_conversion (code->expr2, true);
4945 if (expr2_tmp == NULL)
4946 expr2_tmp = expr2;
4947 }
4948 if (expr2_tmp->expr_type == EXPR_VARIABLE)
4949 {
4950 if (expr2_tmp->symtree == NULL
4951 || expr2_tmp->rank != 0
4952 || (expr2_tmp->ts.type != BT_INTEGER
4953 && expr2_tmp->ts.type != BT_REAL
4954 && expr2_tmp->ts.type != BT_COMPLEX
4955 && expr2_tmp->ts.type != BT_LOGICAL)
4956 || expr2_tmp->symtree->n.sym == var)
4957 {
4958 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read from "
4959 "a scalar variable of intrinsic type at %L",
4960 &expr2_tmp->where);
4961 return;
4962 }
4963 var = expr2_tmp->symtree->n.sym;
4964 code = code->next;
4965 if (code->expr1->expr_type != EXPR_VARIABLE
4966 || code->expr1->symtree == NULL
4967 || code->expr1->rank != 0
4968 || (code->expr1->ts.type != BT_INTEGER
4969 && code->expr1->ts.type != BT_REAL
4970 && code->expr1->ts.type != BT_COMPLEX
4971 && code->expr1->ts.type != BT_LOGICAL))
4972 {
4973 gfc_error ("!$OMP ATOMIC CAPTURE update statement must set "
4974 "a scalar variable of intrinsic type at %L",
4975 &code->expr1->where);
4976 return;
4977 }
4978 if (code->expr1->symtree->n.sym != var)
4979 {
4980 gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
4981 "different variable than update statement writes "
4982 "into at %L", &code->expr1->where);
4983 return;
4984 }
4985 expr2 = is_conversion (code->expr2, false);
4986 if (expr2 == NULL)
4987 expr2 = code->expr2;
4988 }
4989 break;
4990 default:
4991 break;
4992 }
4993
4994 if (gfc_expr_attr (code->expr1).allocatable)
4995 {
4996 gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L",
4997 &code->loc);
4998 return;
4999 }
5000
5001 if (aop == GFC_OMP_ATOMIC_CAPTURE
5002 && code->next == NULL
5003 && code->expr2->rank == 0
5004 && !expr_references_sym (code->expr2, var, NULL))
5005 atomic_code->ext.omp_atomic
5006 = (gfc_omp_atomic_op) (atomic_code->ext.omp_atomic
5007 | GFC_OMP_ATOMIC_SWAP);
5008 else if (expr2->expr_type == EXPR_OP)
5009 {
5010 gfc_expr *v = NULL, *e, *c;
5011 gfc_intrinsic_op op = expr2->value.op.op;
5012 gfc_intrinsic_op alt_op = INTRINSIC_NONE;
5013
5014 switch (op)
5015 {
5016 case INTRINSIC_PLUS:
5017 alt_op = INTRINSIC_MINUS;
5018 break;
5019 case INTRINSIC_TIMES:
5020 alt_op = INTRINSIC_DIVIDE;
5021 break;
5022 case INTRINSIC_MINUS:
5023 alt_op = INTRINSIC_PLUS;
5024 break;
5025 case INTRINSIC_DIVIDE:
5026 alt_op = INTRINSIC_TIMES;
5027 break;
5028 case INTRINSIC_AND:
5029 case INTRINSIC_OR:
5030 break;
5031 case INTRINSIC_EQV:
5032 alt_op = INTRINSIC_NEQV;
5033 break;
5034 case INTRINSIC_NEQV:
5035 alt_op = INTRINSIC_EQV;
5036 break;
5037 default:
5038 gfc_error ("!$OMP ATOMIC assignment operator must be binary "
5039 "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
5040 &expr2->where);
5041 return;
5042 }
5043
5044 /* Check for var = var op expr resp. var = expr op var where
5045 expr doesn't reference var and var op expr is mathematically
5046 equivalent to var op (expr) resp. expr op var equivalent to
5047 (expr) op var. We rely here on the fact that the matcher
5048 for x op1 y op2 z where op1 and op2 have equal precedence
5049 returns (x op1 y) op2 z. */
5050 e = expr2->value.op.op2;
5051 if (e->expr_type == EXPR_VARIABLE
5052 && e->symtree != NULL
5053 && e->symtree->n.sym == var)
5054 v = e;
5055 else if ((c = is_conversion (e, true)) != NULL
5056 && c->expr_type == EXPR_VARIABLE
5057 && c->symtree != NULL
5058 && c->symtree->n.sym == var)
5059 v = c;
5060 else
5061 {
5062 gfc_expr **p = NULL, **q;
5063 for (q = &expr2->value.op.op1; (e = *q) != NULL; )
5064 if (e->expr_type == EXPR_VARIABLE
5065 && e->symtree != NULL
5066 && e->symtree->n.sym == var)
5067 {
5068 v = e;
5069 break;
5070 }
5071 else if ((c = is_conversion (e, true)) != NULL)
5072 q = &e->value.function.actual->expr;
5073 else if (e->expr_type != EXPR_OP
5074 || (e->value.op.op != op
5075 && e->value.op.op != alt_op)
5076 || e->rank != 0)
5077 break;
5078 else
5079 {
5080 p = q;
5081 q = &e->value.op.op1;
5082 }
5083
5084 if (v == NULL)
5085 {
5086 gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
5087 "or var = expr op var at %L", &expr2->where);
5088 return;
5089 }
5090
5091 if (p != NULL)
5092 {
5093 e = *p;
5094 switch (e->value.op.op)
5095 {
5096 case INTRINSIC_MINUS:
5097 case INTRINSIC_DIVIDE:
5098 case INTRINSIC_EQV:
5099 case INTRINSIC_NEQV:
5100 gfc_error ("!$OMP ATOMIC var = var op expr not "
5101 "mathematically equivalent to var = var op "
5102 "(expr) at %L", &expr2->where);
5103 break;
5104 default:
5105 break;
5106 }
5107
5108 /* Canonicalize into var = var op (expr). */
5109 *p = e->value.op.op2;
5110 e->value.op.op2 = expr2;
5111 e->ts = expr2->ts;
5112 if (code->expr2 == expr2)
5113 code->expr2 = expr2 = e;
5114 else
5115 code->expr2->value.function.actual->expr = expr2 = e;
5116
5117 if (!gfc_compare_types (&expr2->value.op.op1->ts, &expr2->ts))
5118 {
5119 for (p = &expr2->value.op.op1; *p != v;
5120 p = &(*p)->value.function.actual->expr)
5121 ;
5122 *p = NULL;
5123 gfc_free_expr (expr2->value.op.op1);
5124 expr2->value.op.op1 = v;
5125 gfc_convert_type (v, &expr2->ts, 2);
5126 }
5127 }
5128 }
5129
5130 if (e->rank != 0 || expr_references_sym (code->expr2, var, v))
5131 {
5132 gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
5133 "must be scalar and cannot reference var at %L",
5134 &expr2->where);
5135 return;
5136 }
5137 }
5138 else if (expr2->expr_type == EXPR_FUNCTION
5139 && expr2->value.function.isym != NULL
5140 && expr2->value.function.esym == NULL
5141 && expr2->value.function.actual != NULL
5142 && expr2->value.function.actual->next != NULL)
5143 {
5144 gfc_actual_arglist *arg, *var_arg;
5145
5146 switch (expr2->value.function.isym->id)
5147 {
5148 case GFC_ISYM_MIN:
5149 case GFC_ISYM_MAX:
5150 break;
5151 case GFC_ISYM_IAND:
5152 case GFC_ISYM_IOR:
5153 case GFC_ISYM_IEOR:
5154 if (expr2->value.function.actual->next->next != NULL)
5155 {
5156 gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
5157 "or IEOR must have two arguments at %L",
5158 &expr2->where);
5159 return;
5160 }
5161 break;
5162 default:
5163 gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
5164 "MIN, MAX, IAND, IOR or IEOR at %L",
5165 &expr2->where);
5166 return;
5167 }
5168
5169 var_arg = NULL;
5170 for (arg = expr2->value.function.actual; arg; arg = arg->next)
5171 {
5172 if ((arg == expr2->value.function.actual
5173 || (var_arg == NULL && arg->next == NULL))
5174 && arg->expr->expr_type == EXPR_VARIABLE
5175 && arg->expr->symtree != NULL
5176 && arg->expr->symtree->n.sym == var)
5177 var_arg = arg;
5178 else if (expr_references_sym (arg->expr, var, NULL))
5179 {
5180 gfc_error ("!$OMP ATOMIC intrinsic arguments except one must "
5181 "not reference %qs at %L",
5182 var->name, &arg->expr->where);
5183 return;
5184 }
5185 if (arg->expr->rank != 0)
5186 {
5187 gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
5188 "at %L", &arg->expr->where);
5189 return;
5190 }
5191 }
5192
5193 if (var_arg == NULL)
5194 {
5195 gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
5196 "be %qs at %L", var->name, &expr2->where);
5197 return;
5198 }
5199
5200 if (var_arg != expr2->value.function.actual)
5201 {
5202 /* Canonicalize, so that var comes first. */
5203 gcc_assert (var_arg->next == NULL);
5204 for (arg = expr2->value.function.actual;
5205 arg->next != var_arg; arg = arg->next)
5206 ;
5207 var_arg->next = expr2->value.function.actual;
5208 expr2->value.function.actual = var_arg;
5209 arg->next = NULL;
5210 }
5211 }
5212 else
5213 gfc_error ("!$OMP ATOMIC assignment must have an operator or "
5214 "intrinsic on right hand side at %L", &expr2->where);
5215
5216 if (aop == GFC_OMP_ATOMIC_CAPTURE && code->next)
5217 {
5218 code = code->next;
5219 if (code->expr1->expr_type != EXPR_VARIABLE
5220 || code->expr1->symtree == NULL
5221 || code->expr1->rank != 0
5222 || (code->expr1->ts.type != BT_INTEGER
5223 && code->expr1->ts.type != BT_REAL
5224 && code->expr1->ts.type != BT_COMPLEX
5225 && code->expr1->ts.type != BT_LOGICAL))
5226 {
5227 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must set "
5228 "a scalar variable of intrinsic type at %L",
5229 &code->expr1->where);
5230 return;
5231 }
5232
5233 expr2 = is_conversion (code->expr2, false);
5234 if (expr2 == NULL)
5235 {
5236 expr2 = is_conversion (code->expr2, true);
5237 if (expr2 == NULL)
5238 expr2 = code->expr2;
5239 }
5240
5241 if (expr2->expr_type != EXPR_VARIABLE
5242 || expr2->symtree == NULL
5243 || expr2->rank != 0
5244 || (expr2->ts.type != BT_INTEGER
5245 && expr2->ts.type != BT_REAL
5246 && expr2->ts.type != BT_COMPLEX
5247 && expr2->ts.type != BT_LOGICAL))
5248 {
5249 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read "
5250 "from a scalar variable of intrinsic type at %L",
5251 &expr2->where);
5252 return;
5253 }
5254 if (expr2->symtree->n.sym != var)
5255 {
5256 gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
5257 "different variable than update statement writes "
5258 "into at %L", &expr2->where);
5259 return;
5260 }
5261 }
5262 }
5263
5264
5265 static struct fortran_omp_context
5266 {
5267 gfc_code *code;
5268 hash_set<gfc_symbol *> *sharing_clauses;
5269 hash_set<gfc_symbol *> *private_iterators;
5270 struct fortran_omp_context *previous;
5271 bool is_openmp;
5272 } *omp_current_ctx;
5273 static gfc_code *omp_current_do_code;
5274 static int omp_current_do_collapse;
5275
5276 void
5277 gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
5278 {
5279 if (code->block->next && code->block->next->op == EXEC_DO)
5280 {
5281 int i;
5282 gfc_code *c;
5283
5284 omp_current_do_code = code->block->next;
5285 if (code->ext.omp_clauses->orderedc)
5286 omp_current_do_collapse = code->ext.omp_clauses->orderedc;
5287 else
5288 omp_current_do_collapse = code->ext.omp_clauses->collapse;
5289 for (i = 1, c = omp_current_do_code; i < omp_current_do_collapse; i++)
5290 {
5291 c = c->block;
5292 if (c->op != EXEC_DO || c->next == NULL)
5293 break;
5294 c = c->next;
5295 if (c->op != EXEC_DO)
5296 break;
5297 }
5298 if (i < omp_current_do_collapse || omp_current_do_collapse <= 0)
5299 omp_current_do_collapse = 1;
5300 }
5301 gfc_resolve_blocks (code->block, ns);
5302 omp_current_do_collapse = 0;
5303 omp_current_do_code = NULL;
5304 }
5305
5306
5307 void
5308 gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
5309 {
5310 struct fortran_omp_context ctx;
5311 gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
5312 gfc_omp_namelist *n;
5313 int list;
5314
5315 ctx.code = code;
5316 ctx.sharing_clauses = new hash_set<gfc_symbol *>;
5317 ctx.private_iterators = new hash_set<gfc_symbol *>;
5318 ctx.previous = omp_current_ctx;
5319 ctx.is_openmp = true;
5320 omp_current_ctx = &ctx;
5321
5322 for (list = 0; list < OMP_LIST_NUM; list++)
5323 switch (list)
5324 {
5325 case OMP_LIST_SHARED:
5326 case OMP_LIST_PRIVATE:
5327 case OMP_LIST_FIRSTPRIVATE:
5328 case OMP_LIST_LASTPRIVATE:
5329 case OMP_LIST_REDUCTION:
5330 case OMP_LIST_LINEAR:
5331 for (n = omp_clauses->lists[list]; n; n = n->next)
5332 ctx.sharing_clauses->add (n->sym);
5333 break;
5334 default:
5335 break;
5336 }
5337
5338 switch (code->op)
5339 {
5340 case EXEC_OMP_PARALLEL_DO:
5341 case EXEC_OMP_PARALLEL_DO_SIMD:
5342 case EXEC_OMP_TARGET_PARALLEL_DO:
5343 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
5344 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
5345 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
5346 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5347 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
5348 case EXEC_OMP_TASKLOOP:
5349 case EXEC_OMP_TASKLOOP_SIMD:
5350 case EXEC_OMP_TEAMS_DISTRIBUTE:
5351 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
5352 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5353 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
5354 gfc_resolve_omp_do_blocks (code, ns);
5355 break;
5356 default:
5357 gfc_resolve_blocks (code->block, ns);
5358 }
5359
5360 omp_current_ctx = ctx.previous;
5361 delete ctx.sharing_clauses;
5362 delete ctx.private_iterators;
5363 }
5364
5365
5366 /* Save and clear openmp.c private state. */
5367
5368 void
5369 gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *state)
5370 {
5371 state->ptrs[0] = omp_current_ctx;
5372 state->ptrs[1] = omp_current_do_code;
5373 state->ints[0] = omp_current_do_collapse;
5374 omp_current_ctx = NULL;
5375 omp_current_do_code = NULL;
5376 omp_current_do_collapse = 0;
5377 }
5378
5379
5380 /* Restore openmp.c private state from the saved state. */
5381
5382 void
5383 gfc_omp_restore_state (struct gfc_omp_saved_state *state)
5384 {
5385 omp_current_ctx = (struct fortran_omp_context *) state->ptrs[0];
5386 omp_current_do_code = (gfc_code *) state->ptrs[1];
5387 omp_current_do_collapse = state->ints[0];
5388 }
5389
5390
5391 /* Note a DO iterator variable. This is special in !$omp parallel
5392 construct, where they are predetermined private. */
5393
5394 void
5395 gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym, bool add_clause)
5396 {
5397 if (omp_current_ctx == NULL)
5398 return;
5399
5400 int i = omp_current_do_collapse;
5401 gfc_code *c = omp_current_do_code;
5402
5403 if (sym->attr.threadprivate)
5404 return;
5405
5406 /* !$omp do and !$omp parallel do iteration variable is predetermined
5407 private just in the !$omp do resp. !$omp parallel do construct,
5408 with no implications for the outer parallel constructs. */
5409
5410 while (i-- >= 1)
5411 {
5412 if (code == c)
5413 return;
5414
5415 c = c->block->next;
5416 }
5417
5418 /* An openacc context may represent a data clause. Abort if so. */
5419 if (!omp_current_ctx->is_openmp && !oacc_is_loop (omp_current_ctx->code))
5420 return;
5421
5422 if (omp_current_ctx->is_openmp
5423 && omp_current_ctx->sharing_clauses->contains (sym))
5424 return;
5425
5426 if (! omp_current_ctx->private_iterators->add (sym) && add_clause)
5427 {
5428 gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses;
5429 gfc_omp_namelist *p;
5430
5431 p = gfc_get_omp_namelist ();
5432 p->sym = sym;
5433 p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
5434 omp_clauses->lists[OMP_LIST_PRIVATE] = p;
5435 }
5436 }
5437
5438 static void
5439 handle_local_var (gfc_symbol *sym)
5440 {
5441 if (sym->attr.flavor != FL_VARIABLE
5442 || sym->as != NULL
5443 || (sym->ts.type != BT_INTEGER && sym->ts.type != BT_REAL))
5444 return;
5445 gfc_resolve_do_iterator (sym->ns->code, sym, false);
5446 }
5447
5448 void
5449 gfc_resolve_omp_local_vars (gfc_namespace *ns)
5450 {
5451 if (omp_current_ctx)
5452 gfc_traverse_ns (ns, handle_local_var);
5453 }
5454
5455 static void
5456 resolve_omp_do (gfc_code *code)
5457 {
5458 gfc_code *do_code, *c;
5459 int list, i, collapse;
5460 gfc_omp_namelist *n;
5461 gfc_symbol *dovar;
5462 const char *name;
5463 bool is_simd = false;
5464
5465 switch (code->op)
5466 {
5467 case EXEC_OMP_DISTRIBUTE: name = "!$OMP DISTRIBUTE"; break;
5468 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
5469 name = "!$OMP DISTRIBUTE PARALLEL DO";
5470 break;
5471 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
5472 name = "!$OMP DISTRIBUTE PARALLEL DO SIMD";
5473 is_simd = true;
5474 break;
5475 case EXEC_OMP_DISTRIBUTE_SIMD:
5476 name = "!$OMP DISTRIBUTE SIMD";
5477 is_simd = true;
5478 break;
5479 case EXEC_OMP_DO: name = "!$OMP DO"; break;
5480 case EXEC_OMP_DO_SIMD: name = "!$OMP DO SIMD"; is_simd = true; break;
5481 case EXEC_OMP_PARALLEL_DO: name = "!$OMP PARALLEL DO"; break;
5482 case EXEC_OMP_PARALLEL_DO_SIMD:
5483 name = "!$OMP PARALLEL DO SIMD";
5484 is_simd = true;
5485 break;
5486 case EXEC_OMP_SIMD: name = "!$OMP SIMD"; is_simd = true; break;
5487 case EXEC_OMP_TARGET_PARALLEL_DO: name = "!$OMP TARGET PARALLEL DO"; break;
5488 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
5489 name = "!$OMP TARGET PARALLEL DO SIMD";
5490 is_simd = true;
5491 break;
5492 case EXEC_OMP_TARGET_SIMD:
5493 name = "!$OMP TARGET SIMD";
5494 is_simd = true;
5495 break;
5496 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
5497 name = "!$OMP TARGET TEAMS DISTRIBUTE";
5498 break;
5499 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
5500 name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
5501 break;
5502 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5503 name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
5504 is_simd = true;
5505 break;
5506 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
5507 name = "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
5508 is_simd = true;
5509 break;
5510 case EXEC_OMP_TASKLOOP: name = "!$OMP TASKLOOP"; break;
5511 case EXEC_OMP_TASKLOOP_SIMD:
5512 name = "!$OMP TASKLOOP SIMD";
5513 is_simd = true;
5514 break;
5515 case EXEC_OMP_TEAMS_DISTRIBUTE: name = "!$OMP TEAMS DISTRIBUTE"; break;
5516 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
5517 name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
5518 break;
5519 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5520 name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
5521 is_simd = true;
5522 break;
5523 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
5524 name = "!$OMP TEAMS DISTRIBUTE SIMD";
5525 is_simd = true;
5526 break;
5527 default: gcc_unreachable ();
5528 }
5529
5530 if (code->ext.omp_clauses)
5531 resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
5532
5533 do_code = code->block->next;
5534 if (code->ext.omp_clauses->orderedc)
5535 collapse = code->ext.omp_clauses->orderedc;
5536 else
5537 {
5538 collapse = code->ext.omp_clauses->collapse;
5539 if (collapse <= 0)
5540 collapse = 1;
5541 }
5542 for (i = 1; i <= collapse; i++)
5543 {
5544 if (do_code->op == EXEC_DO_WHILE)
5545 {
5546 gfc_error ("%s cannot be a DO WHILE or DO without loop control "
5547 "at %L", name, &do_code->loc);
5548 break;
5549 }
5550 if (do_code->op == EXEC_DO_CONCURRENT)
5551 {
5552 gfc_error ("%s cannot be a DO CONCURRENT loop at %L", name,
5553 &do_code->loc);
5554 break;
5555 }
5556 gcc_assert (do_code->op == EXEC_DO);
5557 if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
5558 gfc_error ("%s iteration variable must be of type integer at %L",
5559 name, &do_code->loc);
5560 dovar = do_code->ext.iterator->var->symtree->n.sym;
5561 if (dovar->attr.threadprivate)
5562 gfc_error ("%s iteration variable must not be THREADPRIVATE "
5563 "at %L", name, &do_code->loc);
5564 if (code->ext.omp_clauses)
5565 for (list = 0; list < OMP_LIST_NUM; list++)
5566 if (!is_simd
5567 ? (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE)
5568 : code->ext.omp_clauses->collapse > 1
5569 ? (list != OMP_LIST_LASTPRIVATE)
5570 : (list != OMP_LIST_LINEAR))
5571 for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
5572 if (dovar == n->sym)
5573 {
5574 if (!is_simd)
5575 gfc_error ("%s iteration variable present on clause "
5576 "other than PRIVATE or LASTPRIVATE at %L",
5577 name, &do_code->loc);
5578 else if (code->ext.omp_clauses->collapse > 1)
5579 gfc_error ("%s iteration variable present on clause "
5580 "other than LASTPRIVATE at %L",
5581 name, &do_code->loc);
5582 else
5583 gfc_error ("%s iteration variable present on clause "
5584 "other than LINEAR at %L",
5585 name, &do_code->loc);
5586 break;
5587 }
5588 if (i > 1)
5589 {
5590 gfc_code *do_code2 = code->block->next;
5591 int j;
5592
5593 for (j = 1; j < i; j++)
5594 {
5595 gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
5596 if (dovar == ivar
5597 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
5598 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
5599 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
5600 {
5601 gfc_error ("%s collapsed loops don't form rectangular "
5602 "iteration space at %L", name, &do_code->loc);
5603 break;
5604 }
5605 if (j < i)
5606 break;
5607 do_code2 = do_code2->block->next;
5608 }
5609 }
5610 if (i == collapse)
5611 break;
5612 for (c = do_code->next; c; c = c->next)
5613 if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
5614 {
5615 gfc_error ("collapsed %s loops not perfectly nested at %L",
5616 name, &c->loc);
5617 break;
5618 }
5619 if (c)
5620 break;
5621 do_code = do_code->block;
5622 if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE)
5623 {
5624 gfc_error ("not enough DO loops for collapsed %s at %L",
5625 name, &code->loc);
5626 break;
5627 }
5628 do_code = do_code->next;
5629 if (do_code == NULL
5630 || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE))
5631 {
5632 gfc_error ("not enough DO loops for collapsed %s at %L",
5633 name, &code->loc);
5634 break;
5635 }
5636 }
5637 }
5638
5639 static bool
5640 oacc_is_parallel (gfc_code *code)
5641 {
5642 return code->op == EXEC_OACC_PARALLEL || code->op == EXEC_OACC_PARALLEL_LOOP;
5643 }
5644
5645 static bool
5646 oacc_is_kernels (gfc_code *code)
5647 {
5648 return code->op == EXEC_OACC_KERNELS || code->op == EXEC_OACC_KERNELS_LOOP;
5649 }
5650
5651 static gfc_statement
5652 omp_code_to_statement (gfc_code *code)
5653 {
5654 switch (code->op)
5655 {
5656 case EXEC_OMP_PARALLEL:
5657 return ST_OMP_PARALLEL;
5658 case EXEC_OMP_PARALLEL_SECTIONS:
5659 return ST_OMP_PARALLEL_SECTIONS;
5660 case EXEC_OMP_SECTIONS:
5661 return ST_OMP_SECTIONS;
5662 case EXEC_OMP_ORDERED:
5663 return ST_OMP_ORDERED;
5664 case EXEC_OMP_CRITICAL:
5665 return ST_OMP_CRITICAL;
5666 case EXEC_OMP_MASTER:
5667 return ST_OMP_MASTER;
5668 case EXEC_OMP_SINGLE:
5669 return ST_OMP_SINGLE;
5670 case EXEC_OMP_TASK:
5671 return ST_OMP_TASK;
5672 case EXEC_OMP_WORKSHARE:
5673 return ST_OMP_WORKSHARE;
5674 case EXEC_OMP_PARALLEL_WORKSHARE:
5675 return ST_OMP_PARALLEL_WORKSHARE;
5676 case EXEC_OMP_DO:
5677 return ST_OMP_DO;
5678 default:
5679 gcc_unreachable ();
5680 }
5681 }
5682
5683 static gfc_statement
5684 oacc_code_to_statement (gfc_code *code)
5685 {
5686 switch (code->op)
5687 {
5688 case EXEC_OACC_PARALLEL:
5689 return ST_OACC_PARALLEL;
5690 case EXEC_OACC_KERNELS:
5691 return ST_OACC_KERNELS;
5692 case EXEC_OACC_DATA:
5693 return ST_OACC_DATA;
5694 case EXEC_OACC_HOST_DATA:
5695 return ST_OACC_HOST_DATA;
5696 case EXEC_OACC_PARALLEL_LOOP:
5697 return ST_OACC_PARALLEL_LOOP;
5698 case EXEC_OACC_KERNELS_LOOP:
5699 return ST_OACC_KERNELS_LOOP;
5700 case EXEC_OACC_LOOP:
5701 return ST_OACC_LOOP;
5702 case EXEC_OACC_ATOMIC:
5703 return ST_OACC_ATOMIC;
5704 default:
5705 gcc_unreachable ();
5706 }
5707 }
5708
5709 static void
5710 resolve_oacc_directive_inside_omp_region (gfc_code *code)
5711 {
5712 if (omp_current_ctx != NULL && omp_current_ctx->is_openmp)
5713 {
5714 gfc_statement st = omp_code_to_statement (omp_current_ctx->code);
5715 gfc_statement oacc_st = oacc_code_to_statement (code);
5716 gfc_error ("The %s directive cannot be specified within "
5717 "a %s region at %L", gfc_ascii_statement (oacc_st),
5718 gfc_ascii_statement (st), &code->loc);
5719 }
5720 }
5721
5722 static void
5723 resolve_omp_directive_inside_oacc_region (gfc_code *code)
5724 {
5725 if (omp_current_ctx != NULL && !omp_current_ctx->is_openmp)
5726 {
5727 gfc_statement st = oacc_code_to_statement (omp_current_ctx->code);
5728 gfc_statement omp_st = omp_code_to_statement (code);
5729 gfc_error ("The %s directive cannot be specified within "
5730 "a %s region at %L", gfc_ascii_statement (omp_st),
5731 gfc_ascii_statement (st), &code->loc);
5732 }
5733 }
5734
5735
5736 static void
5737 resolve_oacc_nested_loops (gfc_code *code, gfc_code* do_code, int collapse,
5738 const char *clause)
5739 {
5740 gfc_symbol *dovar;
5741 gfc_code *c;
5742 int i;
5743
5744 for (i = 1; i <= collapse; i++)
5745 {
5746 if (do_code->op == EXEC_DO_WHILE)
5747 {
5748 gfc_error ("!$ACC LOOP cannot be a DO WHILE or DO without loop control "
5749 "at %L", &do_code->loc);
5750 break;
5751 }
5752 gcc_assert (do_code->op == EXEC_DO || do_code->op == EXEC_DO_CONCURRENT);
5753 if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
5754 gfc_error ("!$ACC LOOP iteration variable must be of type integer at %L",
5755 &do_code->loc);
5756 dovar = do_code->ext.iterator->var->symtree->n.sym;
5757 if (i > 1)
5758 {
5759 gfc_code *do_code2 = code->block->next;
5760 int j;
5761
5762 for (j = 1; j < i; j++)
5763 {
5764 gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
5765 if (dovar == ivar
5766 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
5767 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
5768 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
5769 {
5770 gfc_error ("!$ACC LOOP %s loops don't form rectangular iteration space at %L",
5771 clause, &do_code->loc);
5772 break;
5773 }
5774 if (j < i)
5775 break;
5776 do_code2 = do_code2->block->next;
5777 }
5778 }
5779 if (i == collapse)
5780 break;
5781 for (c = do_code->next; c; c = c->next)
5782 if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
5783 {
5784 gfc_error ("%s !$ACC LOOP loops not perfectly nested at %L",
5785 clause, &c->loc);
5786 break;
5787 }
5788 if (c)
5789 break;
5790 do_code = do_code->block;
5791 if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
5792 && do_code->op != EXEC_DO_CONCURRENT)
5793 {
5794 gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
5795 clause, &code->loc);
5796 break;
5797 }
5798 do_code = do_code->next;
5799 if (do_code == NULL
5800 || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
5801 && do_code->op != EXEC_DO_CONCURRENT))
5802 {
5803 gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
5804 clause, &code->loc);
5805 break;
5806 }
5807 }
5808 }
5809
5810
5811 static void
5812 resolve_oacc_params_in_parallel (gfc_code *code, const char *clause,
5813 const char *arg)
5814 {
5815 fortran_omp_context *c;
5816
5817 if (oacc_is_parallel (code))
5818 gfc_error ("!$ACC LOOP %s in PARALLEL region doesn't allow "
5819 "%s arguments at %L", clause, arg, &code->loc);
5820 for (c = omp_current_ctx; c; c = c->previous)
5821 {
5822 if (oacc_is_loop (c->code))
5823 break;
5824 if (oacc_is_parallel (c->code))
5825 gfc_error ("!$ACC LOOP %s in PARALLEL region doesn't allow "
5826 "%s arguments at %L", clause, arg, &code->loc);
5827 }
5828 }
5829
5830
5831 static void
5832 resolve_oacc_loop_blocks (gfc_code *code)
5833 {
5834 fortran_omp_context *c;
5835
5836 if (!oacc_is_loop (code))
5837 return;
5838
5839 if (code->op == EXEC_OACC_LOOP)
5840 for (c = omp_current_ctx; c; c = c->previous)
5841 {
5842 if (oacc_is_loop (c->code))
5843 {
5844 if (code->ext.omp_clauses->gang)
5845 {
5846 if (c->code->ext.omp_clauses->gang)
5847 gfc_error ("Loop parallelized across gangs is not allowed "
5848 "inside another loop parallelized across gangs at %L",
5849 &code->loc);
5850 if (c->code->ext.omp_clauses->worker)
5851 gfc_error ("Loop parallelized across gangs is not allowed "
5852 "inside loop parallelized across workers at %L",
5853 &code->loc);
5854 if (c->code->ext.omp_clauses->vector)
5855 gfc_error ("Loop parallelized across gangs is not allowed "
5856 "inside loop parallelized across workers at %L",
5857 &code->loc);
5858 }
5859 if (code->ext.omp_clauses->worker)
5860 {
5861 if (c->code->ext.omp_clauses->worker)
5862 gfc_error ("Loop parallelized across workers is not allowed "
5863 "inside another loop parallelized across workers at %L",
5864 &code->loc);
5865 if (c->code->ext.omp_clauses->vector)
5866 gfc_error ("Loop parallelized across workers is not allowed "
5867 "inside another loop parallelized across vectors at %L",
5868 &code->loc);
5869 }
5870 if (code->ext.omp_clauses->vector)
5871 if (c->code->ext.omp_clauses->vector)
5872 gfc_error ("Loop parallelized across vectors is not allowed "
5873 "inside another loop parallelized across vectors at %L",
5874 &code->loc);
5875 }
5876
5877 if (oacc_is_parallel (c->code) || oacc_is_kernels (c->code))
5878 break;
5879 }
5880
5881 if (code->ext.omp_clauses->seq)
5882 {
5883 if (code->ext.omp_clauses->independent)
5884 gfc_error ("Clause SEQ conflicts with INDEPENDENT at %L", &code->loc);
5885 if (code->ext.omp_clauses->gang)
5886 gfc_error ("Clause SEQ conflicts with GANG at %L", &code->loc);
5887 if (code->ext.omp_clauses->worker)
5888 gfc_error ("Clause SEQ conflicts with WORKER at %L", &code->loc);
5889 if (code->ext.omp_clauses->vector)
5890 gfc_error ("Clause SEQ conflicts with VECTOR at %L", &code->loc);
5891 if (code->ext.omp_clauses->par_auto)
5892 gfc_error ("Clause SEQ conflicts with AUTO at %L", &code->loc);
5893 }
5894 if (code->ext.omp_clauses->par_auto)
5895 {
5896 if (code->ext.omp_clauses->gang)
5897 gfc_error ("Clause AUTO conflicts with GANG at %L", &code->loc);
5898 if (code->ext.omp_clauses->worker)
5899 gfc_error ("Clause AUTO conflicts with WORKER at %L", &code->loc);
5900 if (code->ext.omp_clauses->vector)
5901 gfc_error ("Clause AUTO conflicts with VECTOR at %L", &code->loc);
5902 }
5903 if (code->ext.omp_clauses->tile_list && code->ext.omp_clauses->gang
5904 && code->ext.omp_clauses->worker && code->ext.omp_clauses->vector)
5905 gfc_error ("Tiled loop cannot be parallelized across gangs, workers and "
5906 "vectors at the same time at %L", &code->loc);
5907
5908 if (code->ext.omp_clauses->gang
5909 && code->ext.omp_clauses->gang_num_expr)
5910 resolve_oacc_params_in_parallel (code, "GANG", "num");
5911
5912 if (code->ext.omp_clauses->worker
5913 && code->ext.omp_clauses->worker_expr)
5914 resolve_oacc_params_in_parallel (code, "WORKER", "num");
5915
5916 if (code->ext.omp_clauses->vector
5917 && code->ext.omp_clauses->vector_expr)
5918 resolve_oacc_params_in_parallel (code, "VECTOR", "length");
5919
5920 if (code->ext.omp_clauses->tile_list)
5921 {
5922 gfc_expr_list *el;
5923 int num = 0;
5924 for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
5925 {
5926 num++;
5927 if (el->expr == NULL)
5928 {
5929 /* NULL expressions are used to represent '*' arguments.
5930 Convert those to a 0 expressions. */
5931 el->expr = gfc_get_constant_expr (BT_INTEGER,
5932 gfc_default_integer_kind,
5933 &code->loc);
5934 mpz_set_si (el->expr->value.integer, 0);
5935 }
5936 else
5937 {
5938 resolve_positive_int_expr (el->expr, "TILE");
5939 if (el->expr->expr_type != EXPR_CONSTANT)
5940 gfc_error ("TILE requires constant expression at %L",
5941 &code->loc);
5942 }
5943 }
5944 resolve_oacc_nested_loops (code, code->block->next, num, "tiled");
5945 }
5946 }
5947
5948
5949 void
5950 gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns)
5951 {
5952 fortran_omp_context ctx;
5953
5954 resolve_oacc_loop_blocks (code);
5955
5956 ctx.code = code;
5957 ctx.sharing_clauses = NULL;
5958 ctx.private_iterators = new hash_set<gfc_symbol *>;
5959 ctx.previous = omp_current_ctx;
5960 ctx.is_openmp = false;
5961 omp_current_ctx = &ctx;
5962
5963 gfc_resolve_blocks (code->block, ns);
5964
5965 omp_current_ctx = ctx.previous;
5966 delete ctx.private_iterators;
5967 }
5968
5969
5970 static void
5971 resolve_oacc_loop (gfc_code *code)
5972 {
5973 gfc_code *do_code;
5974 int collapse;
5975
5976 if (code->ext.omp_clauses)
5977 resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
5978
5979 do_code = code->block->next;
5980 collapse = code->ext.omp_clauses->collapse;
5981
5982 if (collapse <= 0)
5983 collapse = 1;
5984 resolve_oacc_nested_loops (code, do_code, collapse, "collapsed");
5985 }
5986
5987 void
5988 gfc_resolve_oacc_declare (gfc_namespace *ns)
5989 {
5990 int list;
5991 gfc_omp_namelist *n;
5992 gfc_oacc_declare *oc;
5993
5994 if (ns->oacc_declare == NULL)
5995 return;
5996
5997 for (oc = ns->oacc_declare; oc; oc = oc->next)
5998 {
5999 for (list = 0; list < OMP_LIST_NUM; list++)
6000 for (n = oc->clauses->lists[list]; n; n = n->next)
6001 {
6002 n->sym->mark = 0;
6003 if (n->sym->attr.flavor == FL_PARAMETER)
6004 {
6005 gfc_error ("PARAMETER object %qs is not allowed at %L",
6006 n->sym->name, &oc->loc);
6007 continue;
6008 }
6009
6010 if (n->expr && n->expr->ref->type == REF_ARRAY)
6011 {
6012 gfc_error ("Array sections: %qs not allowed in"
6013 " !$ACC DECLARE at %L", n->sym->name, &oc->loc);
6014 continue;
6015 }
6016 }
6017
6018 for (n = oc->clauses->lists[OMP_LIST_DEVICE_RESIDENT]; n; n = n->next)
6019 check_array_not_assumed (n->sym, oc->loc, "DEVICE_RESIDENT");
6020 }
6021
6022 for (oc = ns->oacc_declare; oc; oc = oc->next)
6023 {
6024 for (list = 0; list < OMP_LIST_NUM; list++)
6025 for (n = oc->clauses->lists[list]; n; n = n->next)
6026 {
6027 if (n->sym->mark)
6028 {
6029 gfc_error ("Symbol %qs present on multiple clauses at %L",
6030 n->sym->name, &oc->loc);
6031 continue;
6032 }
6033 else
6034 n->sym->mark = 1;
6035 }
6036 }
6037
6038 for (oc = ns->oacc_declare; oc; oc = oc->next)
6039 {
6040 for (list = 0; list < OMP_LIST_NUM; list++)
6041 for (n = oc->clauses->lists[list]; n; n = n->next)
6042 n->sym->mark = 0;
6043 }
6044 }
6045
6046 void
6047 gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
6048 {
6049 resolve_oacc_directive_inside_omp_region (code);
6050
6051 switch (code->op)
6052 {
6053 case EXEC_OACC_PARALLEL:
6054 case EXEC_OACC_KERNELS:
6055 case EXEC_OACC_DATA:
6056 case EXEC_OACC_HOST_DATA:
6057 case EXEC_OACC_UPDATE:
6058 case EXEC_OACC_ENTER_DATA:
6059 case EXEC_OACC_EXIT_DATA:
6060 case EXEC_OACC_WAIT:
6061 case EXEC_OACC_CACHE:
6062 resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
6063 break;
6064 case EXEC_OACC_PARALLEL_LOOP:
6065 case EXEC_OACC_KERNELS_LOOP:
6066 case EXEC_OACC_LOOP:
6067 resolve_oacc_loop (code);
6068 break;
6069 case EXEC_OACC_ATOMIC:
6070 resolve_omp_atomic (code);
6071 break;
6072 default:
6073 break;
6074 }
6075 }
6076
6077
6078 /* Resolve OpenMP directive clauses and check various requirements
6079 of each directive. */
6080
6081 void
6082 gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
6083 {
6084 resolve_omp_directive_inside_oacc_region (code);
6085
6086 if (code->op != EXEC_OMP_ATOMIC)
6087 gfc_maybe_initialize_eh ();
6088
6089 switch (code->op)
6090 {
6091 case EXEC_OMP_DISTRIBUTE:
6092 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
6093 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
6094 case EXEC_OMP_DISTRIBUTE_SIMD:
6095 case EXEC_OMP_DO:
6096 case EXEC_OMP_DO_SIMD:
6097 case EXEC_OMP_PARALLEL_DO:
6098 case EXEC_OMP_PARALLEL_DO_SIMD:
6099 case EXEC_OMP_SIMD:
6100 case EXEC_OMP_TARGET_PARALLEL_DO:
6101 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
6102 case EXEC_OMP_TARGET_SIMD:
6103 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
6104 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
6105 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
6106 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
6107 case EXEC_OMP_TASKLOOP:
6108 case EXEC_OMP_TASKLOOP_SIMD:
6109 case EXEC_OMP_TEAMS_DISTRIBUTE:
6110 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
6111 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
6112 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
6113 resolve_omp_do (code);
6114 break;
6115 case EXEC_OMP_CANCEL:
6116 case EXEC_OMP_PARALLEL_WORKSHARE:
6117 case EXEC_OMP_PARALLEL:
6118 case EXEC_OMP_PARALLEL_SECTIONS:
6119 case EXEC_OMP_SECTIONS:
6120 case EXEC_OMP_SINGLE:
6121 case EXEC_OMP_TARGET:
6122 case EXEC_OMP_TARGET_DATA:
6123 case EXEC_OMP_TARGET_ENTER_DATA:
6124 case EXEC_OMP_TARGET_EXIT_DATA:
6125 case EXEC_OMP_TARGET_PARALLEL:
6126 case EXEC_OMP_TARGET_TEAMS:
6127 case EXEC_OMP_TASK:
6128 case EXEC_OMP_TEAMS:
6129 case EXEC_OMP_WORKSHARE:
6130 if (code->ext.omp_clauses)
6131 resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
6132 break;
6133 case EXEC_OMP_TARGET_UPDATE:
6134 if (code->ext.omp_clauses)
6135 resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
6136 if (code->ext.omp_clauses == NULL
6137 || (code->ext.omp_clauses->lists[OMP_LIST_TO] == NULL
6138 && code->ext.omp_clauses->lists[OMP_LIST_FROM] == NULL))
6139 gfc_error ("OMP TARGET UPDATE at %L requires at least one TO or "
6140 "FROM clause", &code->loc);
6141 break;
6142 case EXEC_OMP_ATOMIC:
6143 resolve_omp_atomic (code);
6144 break;
6145 default:
6146 break;
6147 }
6148 }
6149
6150 /* Resolve !$omp declare simd constructs in NS. */
6151
6152 void
6153 gfc_resolve_omp_declare_simd (gfc_namespace *ns)
6154 {
6155 gfc_omp_declare_simd *ods;
6156
6157 for (ods = ns->omp_declare_simd; ods; ods = ods->next)
6158 {
6159 if (ods->proc_name != NULL
6160 && ods->proc_name != ns->proc_name)
6161 gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure "
6162 "%qs at %L", ns->proc_name->name, &ods->where);
6163 if (ods->clauses)
6164 resolve_omp_clauses (NULL, ods->clauses, ns);
6165 }
6166 }
6167
6168 struct omp_udr_callback_data
6169 {
6170 gfc_omp_udr *omp_udr;
6171 bool is_initializer;
6172 };
6173
6174 static int
6175 omp_udr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
6176 void *data)
6177 {
6178 struct omp_udr_callback_data *cd = (struct omp_udr_callback_data *) data;
6179 if ((*e)->expr_type == EXPR_VARIABLE)
6180 {
6181 if (cd->is_initializer)
6182 {
6183 if ((*e)->symtree->n.sym != cd->omp_udr->omp_priv
6184 && (*e)->symtree->n.sym != cd->omp_udr->omp_orig)
6185 gfc_error ("Variable other than OMP_PRIV or OMP_ORIG used in "
6186 "INITIALIZER clause of !$OMP DECLARE REDUCTION at %L",
6187 &(*e)->where);
6188 }
6189 else
6190 {
6191 if ((*e)->symtree->n.sym != cd->omp_udr->omp_out
6192 && (*e)->symtree->n.sym != cd->omp_udr->omp_in)
6193 gfc_error ("Variable other than OMP_OUT or OMP_IN used in "
6194 "combiner of !$OMP DECLARE REDUCTION at %L",
6195 &(*e)->where);
6196 }
6197 }
6198 return 0;
6199 }
6200
6201 /* Resolve !$omp declare reduction constructs. */
6202
6203 static void
6204 gfc_resolve_omp_udr (gfc_omp_udr *omp_udr)
6205 {
6206 gfc_actual_arglist *a;
6207 const char *predef_name = NULL;
6208
6209 switch (omp_udr->rop)
6210 {
6211 case OMP_REDUCTION_PLUS:
6212 case OMP_REDUCTION_TIMES:
6213 case OMP_REDUCTION_MINUS:
6214 case OMP_REDUCTION_AND:
6215 case OMP_REDUCTION_OR:
6216 case OMP_REDUCTION_EQV:
6217 case OMP_REDUCTION_NEQV:
6218 case OMP_REDUCTION_MAX:
6219 case OMP_REDUCTION_USER:
6220 break;
6221 default:
6222 gfc_error ("Invalid operator for !$OMP DECLARE REDUCTION %s at %L",
6223 omp_udr->name, &omp_udr->where);
6224 return;
6225 }
6226
6227 if (gfc_omp_udr_predef (omp_udr->rop, omp_udr->name,
6228 &omp_udr->ts, &predef_name))
6229 {
6230 if (predef_name)
6231 gfc_error_now ("Redefinition of predefined %s "
6232 "!$OMP DECLARE REDUCTION at %L",
6233 predef_name, &omp_udr->where);
6234 else
6235 gfc_error_now ("Redefinition of predefined "
6236 "!$OMP DECLARE REDUCTION at %L", &omp_udr->where);
6237 return;
6238 }
6239
6240 if (omp_udr->ts.type == BT_CHARACTER
6241 && omp_udr->ts.u.cl->length
6242 && omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
6243 {
6244 gfc_error ("CHARACTER length in !$OMP DECLARE REDUCTION %s not "
6245 "constant at %L", omp_udr->name, &omp_udr->where);
6246 return;
6247 }
6248
6249 struct omp_udr_callback_data cd;
6250 cd.omp_udr = omp_udr;
6251 cd.is_initializer = false;
6252 gfc_code_walker (&omp_udr->combiner_ns->code, gfc_dummy_code_callback,
6253 omp_udr_callback, &cd);
6254 if (omp_udr->combiner_ns->code->op == EXEC_CALL)
6255 {
6256 for (a = omp_udr->combiner_ns->code->ext.actual; a; a = a->next)
6257 if (a->expr == NULL)
6258 break;
6259 if (a)
6260 gfc_error ("Subroutine call with alternate returns in combiner "
6261 "of !$OMP DECLARE REDUCTION at %L",
6262 &omp_udr->combiner_ns->code->loc);
6263 }
6264 if (omp_udr->initializer_ns)
6265 {
6266 cd.is_initializer = true;
6267 gfc_code_walker (&omp_udr->initializer_ns->code, gfc_dummy_code_callback,
6268 omp_udr_callback, &cd);
6269 if (omp_udr->initializer_ns->code->op == EXEC_CALL)
6270 {
6271 for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
6272 if (a->expr == NULL)
6273 break;
6274 if (a)
6275 gfc_error ("Subroutine call with alternate returns in "
6276 "INITIALIZER clause of !$OMP DECLARE REDUCTION "
6277 "at %L", &omp_udr->initializer_ns->code->loc);
6278 for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
6279 if (a->expr
6280 && a->expr->expr_type == EXPR_VARIABLE
6281 && a->expr->symtree->n.sym == omp_udr->omp_priv
6282 && a->expr->ref == NULL)
6283 break;
6284 if (a == NULL)
6285 gfc_error ("One of actual subroutine arguments in INITIALIZER "
6286 "clause of !$OMP DECLARE REDUCTION must be OMP_PRIV "
6287 "at %L", &omp_udr->initializer_ns->code->loc);
6288 }
6289 }
6290 else if (omp_udr->ts.type == BT_DERIVED
6291 && !gfc_has_default_initializer (omp_udr->ts.u.derived))
6292 {
6293 gfc_error ("Missing INITIALIZER clause for !$OMP DECLARE REDUCTION "
6294 "of derived type without default initializer at %L",
6295 &omp_udr->where);
6296 return;
6297 }
6298 }
6299
6300 void
6301 gfc_resolve_omp_udrs (gfc_symtree *st)
6302 {
6303 gfc_omp_udr *omp_udr;
6304
6305 if (st == NULL)
6306 return;
6307 gfc_resolve_omp_udrs (st->left);
6308 gfc_resolve_omp_udrs (st->right);
6309 for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
6310 gfc_resolve_omp_udr (omp_udr);
6311 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org