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