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