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