]> 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
Fortran/OpenMP: strict modifier on grainsize/num_tasks
[thirdparty/gcc.git] / gcc / fortran / openmp.c
CommitLineData
6c7a4dfd 1/* OpenMP directive matching and resolving.
99dee823 2 Copyright (C) 2005-2021 Free Software Foundation, Inc.
6c7a4dfd
JJ		 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
d234d788 9Software Foundation; either version 3, or (at your option) any later
6c7a4dfd
JJ		 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
d234d788
NC		 18along with GCC; see the file COPYING3. If not see
19<http://www.gnu.org/licenses/>. */
6c7a4dfd 20
6c7a4dfd
JJ		 21#include "config.h"
22#include "system.h"
953bee7c 23#include "coretypes.h"
6c7a4dfd 24#include "gfortran.h"
5f23671d 25#include "arith.h"
6c7a4dfd
JJ		 26#include "match.h"
27#include "parse.h"
9a5de4d5 28#include "constructor.h"
41dbbb37
TS		 29#include "diagnostic.h"
30#include "gomp-constants.h"
77167196 31#include "target-memory.h" /* For gfc_encode_character. */
6c7a4dfd
JJ		 32
33/* Match an end of OpenMP directive. End of OpenMP directive is optional
34 whitespace, followed by '\n' or comment '!'. */
35
8beaf167 36static match
6c7a4dfd
JJ		 37gfc_match_omp_eos (void)
38{
39 locus old_loc;
8fc541d3 40 char c;
6c7a4dfd
JJ		 41
42 old_loc = gfc_current_locus;
43 gfc_gobble_whitespace ();
44
8fc541d3 45 c = gfc_next_ascii_char ();
6c7a4dfd
JJ		 46 switch (c)
47 {
48 case '!':
49 do
8fc541d3 50 c = gfc_next_ascii_char ();
6c7a4dfd
JJ		 51 while (c != '\n');
52 /* Fall through */
53
54 case '\n':
55 return MATCH_YES;
56 }
57
58 gfc_current_locus = old_loc;
59 return MATCH_NO;
60}
61
8beaf167
TB		 62match
63gfc_match_omp_eos_error (void)
64{
65 if (gfc_match_omp_eos() == MATCH_YES)
66 return MATCH_YES;
67
68 gfc_error ("Unexpected junk at %C");
69 return MATCH_ERROR;
70}
71
72
6c7a4dfd
JJ		 73/* Free an omp_clauses structure. */
74
75void
76gfc_free_omp_clauses (gfc_omp_clauses *c)
77{
78 int i;
79 if (c == NULL)
80 return;
81
82 gfc_free_expr (c->if_expr);
20906c66 83 gfc_free_expr (c->final_expr);
6c7a4dfd
JJ		 84 gfc_free_expr (c->num_threads);
85 gfc_free_expr (c->chunk_size);
dd2fc525
JJ		 86 gfc_free_expr (c->safelen_expr);
87 gfc_free_expr (c->simdlen_expr);
f014c653
JJ		 88 gfc_free_expr (c->num_teams);
89 gfc_free_expr (c->device);
90 gfc_free_expr (c->thread_limit);
91 gfc_free_expr (c->dist_chunk_size);
b4c3a85b
JJ		 92 gfc_free_expr (c->grainsize);
93 gfc_free_expr (c->hint);
94 gfc_free_expr (c->num_tasks);
95 gfc_free_expr (c->priority);
a6d22fb2 96 gfc_free_expr (c->detach);
b4c3a85b
JJ		 97 for (i = 0; i < OMP_IF_LAST; i++)
98 gfc_free_expr (c->if_exprs[i]);
41dbbb37 99 gfc_free_expr (c->async_expr);
2a70708e
CP		 100 gfc_free_expr (c->gang_num_expr);
101 gfc_free_expr (c->gang_static_expr);
41dbbb37
TS		 102 gfc_free_expr (c->worker_expr);
103 gfc_free_expr (c->vector_expr);
104 gfc_free_expr (c->num_gangs_expr);
105 gfc_free_expr (c->num_workers_expr);
106 gfc_free_expr (c->vector_length_expr);
6c7a4dfd 107 for (i = 0; i < OMP_LIST_NUM; i++)
9a5de4d5
TB		 108 gfc_free_omp_namelist (c->lists[i],
109 i == OMP_LIST_AFFINITY || i == OMP_LIST_DEPEND);
41dbbb37
TS		 110 gfc_free_expr_list (c->wait_list);
111 gfc_free_expr_list (c->tile_list);
b4c3a85b 112 free (CONST_CAST (char *, c->critical_name));
cede9502 113 free (c);
6c7a4dfd
JJ		 114}
115
dc7a8b4b
JN		 116/* Free oacc_declare structures. */
117
118void
119gfc_free_oacc_declare_clauses (struct gfc_oacc_declare *oc)
120{
121 struct gfc_oacc_declare *decl = oc;
122
123 do
124 {
125 struct gfc_oacc_declare *next;
126
127 next = decl->next;
128 gfc_free_omp_clauses (decl->clauses);
129 free (decl);
130 decl = next;
131 }
132 while (decl);
133}
134
41dbbb37
TS		 135/* Free expression list. */
136void
137gfc_free_expr_list (gfc_expr_list *list)
138{
139 gfc_expr_list *n;
140
141 for (; list; list = n)
142 {
143 n = list->next;
144 free (list);
145 }
146}
147
dd2fc525
JJ		 148/* Free an !$omp declare simd construct list. */
149
150void
151gfc_free_omp_declare_simd (gfc_omp_declare_simd *ods)
152{
153 if (ods)
154 {
155 gfc_free_omp_clauses (ods->clauses);
156 free (ods);
157 }
158}
159
160void
161gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *list)
162{
163 while (list)
164 {
165 gfc_omp_declare_simd *current = list;
166 list = list->next;
167 gfc_free_omp_declare_simd (current);
168 }
169}
170
5f23671d
JJ		 171/* Free an !$omp declare reduction. */
172
173void
174gfc_free_omp_udr (gfc_omp_udr *omp_udr)
175{
176 if (omp_udr)
177 {
178 gfc_free_omp_udr (omp_udr->next);
179 gfc_free_namespace (omp_udr->combiner_ns);
180 if (omp_udr->initializer_ns)
181 gfc_free_namespace (omp_udr->initializer_ns);
182 free (omp_udr);
183 }
184}
185
186
187static gfc_omp_udr *
188gfc_find_omp_udr (gfc_namespace *ns, const char *name, gfc_typespec *ts)
189{
190 gfc_symtree *st;
191
192 if (ns == NULL)
193 ns = gfc_current_ns;
194 do
195 {
196 gfc_omp_udr *omp_udr;
197
198 st = gfc_find_symtree (ns->omp_udr_root, name);
199 if (st != NULL)
6b37bdaf
PP		 200 {
201 for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
202 if (ts == NULL)
5f23671d 203 return omp_udr;
6b37bdaf
PP		 204 else if (gfc_compare_types (&omp_udr->ts, ts))
205 {
206 if (ts->type == BT_CHARACTER)
207 {
208 if (omp_udr->ts.u.cl->length == NULL)
209 return omp_udr;
210 if (ts->u.cl->length == NULL)
211 continue;
212 if (gfc_compare_expr (omp_udr->ts.u.cl->length,
213 ts->u.cl->length,
214 INTRINSIC_EQ) != 0)
215 continue;
216 }
217 return omp_udr;
218 }
219 }
5f23671d
JJ		 220
221 /* Don't escape an interface block. */
222 if (ns && !ns->has_import_set
223 && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
224 break;
225
226 ns = ns->parent;
227 }
228 while (ns != NULL);
229
230 return NULL;
231}
232
dd2fc525 233
6c7a4dfd
JJ		 234/* Match a variable/common block list and construct a namelist from it. */
235
236static match
dd2fc525
JJ		 237gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list,
238 bool allow_common, bool *end_colon = NULL,
239 gfc_omp_namelist ***headp = NULL,
549188ea
JB		 240 bool allow_sections = false,
241 bool allow_derived = false)
6c7a4dfd 242{
dd2fc525
JJ		 243 gfc_omp_namelist *head, *tail, *p;
244 locus old_loc, cur_loc;
6c7a4dfd
JJ		 245 char n[GFC_MAX_SYMBOL_LEN+1];
246 gfc_symbol *sym;
247 match m;
248 gfc_symtree *st;
249
250 head = tail = NULL;
251
252 old_loc = gfc_current_locus;
253
254 m = gfc_match (str);
255 if (m != MATCH_YES)
256 return m;
257
258 for (;;)
259 {
dd2fc525 260 cur_loc = gfc_current_locus;
6c7a4dfd
JJ		 261 m = gfc_match_symbol (&sym, 1);
262 switch (m)
263 {
264 case MATCH_YES:
dd2fc525
JJ		 265 gfc_expr *expr;
266 expr = NULL;
e4aeffac 267 gfc_gobble_whitespace ();
549188ea
JB		 268 if ((allow_sections && gfc_peek_ascii_char () == '(')
269 || (allow_derived && gfc_peek_ascii_char () == '%'))
dd2fc525
JJ		 270 {
271 gfc_current_locus = cur_loc;
272 m = gfc_match_variable (&expr, 0);
273 switch (m)
274 {
275 case MATCH_ERROR:
276 goto cleanup;
277 case MATCH_NO:
278 goto syntax;
279 default:
280 break;
281 }
e565e49f
TB		 282 if (gfc_is_coindexed (expr))
283 {
284 gfc_error ("List item shall not be coindexed at %C");
285 goto cleanup;
286 }
dd2fc525 287 }
6c7a4dfd 288 gfc_set_sym_referenced (sym);
dd2fc525 289 p = gfc_get_omp_namelist ();
6c7a4dfd
JJ		 290 if (head == NULL)
291 head = tail = p;
292 else
293 {
294 tail->next = p;
295 tail = tail->next;
296 }
297 tail->sym = sym;
dd2fc525 298 tail->expr = expr;
2ac33bca 299 tail->where = cur_loc;
6c7a4dfd
JJ		 300 goto next_item;
301 case MATCH_NO:
302 break;
303 case MATCH_ERROR:
304 goto cleanup;
305 }
306
307 if (!allow_common)
308 goto syntax;
309
310 m = gfc_match (" / %n /", n);
311 if (m == MATCH_ERROR)
312 goto cleanup;
313 if (m == MATCH_NO)
314 goto syntax;
315
316 st = gfc_find_symtree (gfc_current_ns->common_root, n);
317 if (st == NULL)
318 {
319 gfc_error ("COMMON block /%s/ not found at %C", n);
320 goto cleanup;
321 }
322 for (sym = st->n.common->head; sym; sym = sym->common_next)
323 {
324 gfc_set_sym_referenced (sym);
dd2fc525 325 p = gfc_get_omp_namelist ();
6c7a4dfd
JJ		 326 if (head == NULL)
327 head = tail = p;
328 else
329 {
330 tail->next = p;
331 tail = tail->next;
332 }
333 tail->sym = sym;
2ac33bca 334 tail->where = cur_loc;
6c7a4dfd
JJ		 335 }
336
337 next_item:
dd2fc525
JJ		 338 if (end_colon && gfc_match_char (':') == MATCH_YES)
339 {
340 *end_colon = true;
341 break;
342 }
6c7a4dfd
JJ		 343 if (gfc_match_char (')') == MATCH_YES)
344 break;
345 if (gfc_match_char (',') != MATCH_YES)
346 goto syntax;
347 }
348
349 while (*list)
350 list = &(*list)->next;
351
352 *list = head;
dd2fc525
JJ		 353 if (headp)
354 *headp = list;
6c7a4dfd
JJ		 355 return MATCH_YES;
356
357syntax:
358 gfc_error ("Syntax error in OpenMP variable list at %C");
359
360cleanup:
9a5de4d5 361 gfc_free_omp_namelist (head, false);
6c7a4dfd
JJ		 362 gfc_current_locus = old_loc;
363 return MATCH_ERROR;
364}
365
b4c3a85b
JJ		 366/* Match a variable/procedure/common block list and construct a namelist
367 from it. */
368
369static match
370gfc_match_omp_to_link (const char *str, gfc_omp_namelist **list)
371{
372 gfc_omp_namelist *head, *tail, *p;
373 locus old_loc, cur_loc;
374 char n[GFC_MAX_SYMBOL_LEN+1];
375 gfc_symbol *sym;
376 match m;
377 gfc_symtree *st;
378
379 head = tail = NULL;
380
381 old_loc = gfc_current_locus;
382
383 m = gfc_match (str);
384 if (m != MATCH_YES)
385 return m;
386
387 for (;;)
388 {
389 cur_loc = gfc_current_locus;
390 m = gfc_match_symbol (&sym, 1);
391 switch (m)
392 {
393 case MATCH_YES:
394 p = gfc_get_omp_namelist ();
395 if (head == NULL)
396 head = tail = p;
397 else
398 {
399 tail->next = p;
400 tail = tail->next;
401 }
402 tail->sym = sym;
403 tail->where = cur_loc;
404 goto next_item;
405 case MATCH_NO:
406 break;
407 case MATCH_ERROR:
408 goto cleanup;
409 }
410
411 m = gfc_match (" / %n /", n);
412 if (m == MATCH_ERROR)
413 goto cleanup;
414 if (m == MATCH_NO)
415 goto syntax;
416
417 st = gfc_find_symtree (gfc_current_ns->common_root, n);
418 if (st == NULL)
419 {
420 gfc_error ("COMMON block /%s/ not found at %C", n);
421 goto cleanup;
422 }
423 p = gfc_get_omp_namelist ();
424 if (head == NULL)
425 head = tail = p;
426 else
427 {
428 tail->next = p;
429 tail = tail->next;
430 }
431 tail->u.common = st->n.common;
432 tail->where = cur_loc;
433
434 next_item:
435 if (gfc_match_char (')') == MATCH_YES)
436 break;
437 if (gfc_match_char (',') != MATCH_YES)
438 goto syntax;
439 }
440
441 while (*list)
442 list = &(*list)->next;
443
444 *list = head;
445 return MATCH_YES;
446
447syntax:
448 gfc_error ("Syntax error in OpenMP variable list at %C");
449
450cleanup:
9a5de4d5 451 gfc_free_omp_namelist (head, false);
b4c3a85b
JJ		 452 gfc_current_locus = old_loc;
453 return MATCH_ERROR;
454}
455
a6d22fb2
KCY		 456/* Match detach(event-handle). */
457
458static match
459gfc_match_omp_detach (gfc_expr **expr)
460{
461 locus old_loc = gfc_current_locus;
462
463 if (gfc_match ("detach ( ") != MATCH_YES)
464 goto syntax_error;
465
466 if (gfc_match_variable (expr, 0) != MATCH_YES)
467 goto syntax_error;
468
469 if ((*expr)->ts.type != BT_INTEGER || (*expr)->ts.kind != gfc_c_intptr_kind)
470 {
471 gfc_error ("%qs at %L should be of type "
472 "integer(kind=omp_event_handle_kind)",
473 (*expr)->symtree->n.sym->name, &(*expr)->where);
474 return MATCH_ERROR;
475 }
476
477 if (gfc_match_char (')') != MATCH_YES)
478 goto syntax_error;
479
480 return MATCH_YES;
481
482syntax_error:
483 gfc_error ("Syntax error in OpenMP detach clause at %C");
484 gfc_current_locus = old_loc;
485 return MATCH_ERROR;
486
487}
488
b4c3a85b
JJ		 489/* Match depend(sink : ...) construct a namelist from it. */
490
491static match
492gfc_match_omp_depend_sink (gfc_omp_namelist **list)
493{
494 gfc_omp_namelist *head, *tail, *p;
495 locus old_loc, cur_loc;
496 gfc_symbol *sym;
497
498 head = tail = NULL;
499
500 old_loc = gfc_current_locus;
501
502 for (;;)
503 {
504 cur_loc = gfc_current_locus;
505 switch (gfc_match_symbol (&sym, 1))
506 {
507 case MATCH_YES:
508 gfc_set_sym_referenced (sym);
509 p = gfc_get_omp_namelist ();
510 if (head == NULL)
511 {
512 head = tail = p;
513 head->u.depend_op = OMP_DEPEND_SINK_FIRST;
514 }
515 else
516 {
517 tail->next = p;
518 tail = tail->next;
519 tail->u.depend_op = OMP_DEPEND_SINK;
520 }
521 tail->sym = sym;
522 tail->expr = NULL;
523 tail->where = cur_loc;
524 if (gfc_match_char ('+') == MATCH_YES)
525 {
526 if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES)
527 goto syntax;
528 }
529 else if (gfc_match_char ('-') == MATCH_YES)
530 {
531 if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES)
532 goto syntax;
533 tail->expr = gfc_uminus (tail->expr);
534 }
535 break;
536 case MATCH_NO:
537 goto syntax;
538 case MATCH_ERROR:
539 goto cleanup;
540 }
541
542 if (gfc_match_char (')') == MATCH_YES)
543 break;
544 if (gfc_match_char (',') != MATCH_YES)
545 goto syntax;
546 }
547
548 while (*list)
549 list = &(*list)->next;
550
551 *list = head;
552 return MATCH_YES;
553
554syntax:
555 gfc_error ("Syntax error in OpenMP DEPEND SINK list at %C");
556
557cleanup:
9a5de4d5 558 gfc_free_omp_namelist (head, false);
b4c3a85b
JJ		 559 gfc_current_locus = old_loc;
560 return MATCH_ERROR;
561}
562
41dbbb37
TS		 563static match
564match_oacc_expr_list (const char *str, gfc_expr_list **list,
565 bool allow_asterisk)
566{
567 gfc_expr_list *head, *tail, *p;
568 locus old_loc;
569 gfc_expr *expr;
570 match m;
571
572 head = tail = NULL;
573
574 old_loc = gfc_current_locus;
575
576 m = gfc_match (str);
577 if (m != MATCH_YES)
578 return m;
579
580 for (;;)
581 {
582 m = gfc_match_expr (&expr);
583 if (m == MATCH_YES || allow_asterisk)
584 {
585 p = gfc_get_expr_list ();
586 if (head == NULL)
587 head = tail = p;
588 else
589 {
590 tail->next = p;
591 tail = tail->next;
592 }
593 if (m == MATCH_YES)
594 tail->expr = expr;
595 else if (gfc_match (" *") != MATCH_YES)
596 goto syntax;
597 goto next_item;
598 }
599 if (m == MATCH_ERROR)
600 goto cleanup;
601 goto syntax;
602
603 next_item:
604 if (gfc_match_char (')') == MATCH_YES)
605 break;
606 if (gfc_match_char (',') != MATCH_YES)
607 goto syntax;
608 }
609
610 while (*list)
611 list = &(*list)->next;
612
613 *list = head;
614 return MATCH_YES;
615
616syntax:
617 gfc_error ("Syntax error in OpenACC expression list at %C");
618
619cleanup:
620 gfc_free_expr_list (head);
621 gfc_current_locus = old_loc;
622 return MATCH_ERROR;
623}
624
625static match
27f67461 626match_oacc_clause_gwv (gfc_omp_clauses *cp, unsigned gwv)
41dbbb37 627{
2a70708e
CP		 628 match ret = MATCH_YES;
629
630 if (gfc_match (" ( ") != MATCH_YES)
41dbbb37 631 return MATCH_NO;
2a70708e 632
27f67461 633 if (gwv == GOMP_DIM_GANG)
41dbbb37 634 {
27f67461
CP		 635 /* The gang clause accepts two optional arguments, num and static.
636 The num argument may either be explicit (num: <val>) or
637 implicit without (<val> without num:). */
638
639 while (ret == MATCH_YES)
2a70708e 640 {
27f67461
CP		 641 if (gfc_match (" static :") == MATCH_YES)
642 {
643 if (cp->gang_static)
644 return MATCH_ERROR;
645 else
646 cp->gang_static = true;
647 if (gfc_match_char ('*') == MATCH_YES)
648 cp->gang_static_expr = NULL;
649 else if (gfc_match (" %e ", &cp->gang_static_expr) != MATCH_YES)
650 return MATCH_ERROR;
651 }
2a70708e 652 else
27f67461
CP		 653 {
654 if (cp->gang_num_expr)
655 return MATCH_ERROR;
656
657 /* The 'num' argument is optional. */
658 gfc_match (" num :");
659
660 if (gfc_match (" %e ", &cp->gang_num_expr) != MATCH_YES)
661 return MATCH_ERROR;
662 }
663
664 ret = gfc_match (" , ");
2a70708e 665 }
27f67461
CP		 666 }
667 else if (gwv == GOMP_DIM_WORKER)
668 {
669 /* The 'num' argument is optional. */
670 gfc_match (" num :");
2a70708e 671
27f67461
CP		 672 if (gfc_match (" %e ", &cp->worker_expr) != MATCH_YES)
673 return MATCH_ERROR;
41dbbb37 674 }
27f67461
CP		 675 else if (gwv == GOMP_DIM_VECTOR)
676 {
677 /* The 'length' argument is optional. */
678 gfc_match (" length :");
2a70708e 679
27f67461
CP		 680 if (gfc_match (" %e ", &cp->vector_expr) != MATCH_YES)
681 return MATCH_ERROR;
682 }
683 else
684 gfc_fatal_error ("Unexpected OpenACC parallelism.");
685
686 return gfc_match (" )");
41dbbb37
TS		 687}
688
dc7a8b4b
JN		 689static match
690gfc_match_oacc_clause_link (const char *str, gfc_omp_namelist **list)
691{
cc9e07a6
JN		 692 gfc_omp_namelist *head = NULL;
693 gfc_omp_namelist *tail, *p;
dc7a8b4b
JN		 694 locus old_loc;
695 char n[GFC_MAX_SYMBOL_LEN+1];
696 gfc_symbol *sym;
697 match m;
698 gfc_symtree *st;
699
700 old_loc = gfc_current_locus;
701
702 m = gfc_match (str);
703 if (m != MATCH_YES)
704 return m;
705
706 m = gfc_match (" (");
707
708 for (;;)
709 {
710 m = gfc_match_symbol (&sym, 0);
711 switch (m)
712 {
713 case MATCH_YES:
714 if (sym->attr.in_common)
715 {
716 gfc_error_now ("Variable at %C is an element of a COMMON block");
717 goto cleanup;
718 }
719 gfc_set_sym_referenced (sym);
720 p = gfc_get_omp_namelist ();
721 if (head == NULL)
722 head = tail = p;
723 else
724 {
725 tail->next = p;
726 tail = tail->next;
727 }
728 tail->sym = sym;
729 tail->expr = NULL;
730 tail->where = gfc_current_locus;
731 goto next_item;
732 case MATCH_NO:
733 break;
734
735 case MATCH_ERROR:
736 goto cleanup;
737 }
738
739 m = gfc_match (" / %n /", n);
740 if (m == MATCH_ERROR)
741 goto cleanup;
742 if (m == MATCH_NO || n[0] == '\0')
743 goto syntax;
744
745 st = gfc_find_symtree (gfc_current_ns->common_root, n);
746 if (st == NULL)
747 {
748 gfc_error ("COMMON block /%s/ not found at %C", n);
749 goto cleanup;
750 }
751
752 for (sym = st->n.common->head; sym; sym = sym->common_next)
753 {
754 gfc_set_sym_referenced (sym);
755 p = gfc_get_omp_namelist ();
756 if (head == NULL)
757 head = tail = p;
758 else
759 {
760 tail->next = p;
761 tail = tail->next;
762 }
763 tail->sym = sym;
764 tail->where = gfc_current_locus;
765 }
766
767 next_item:
768 if (gfc_match_char (')') == MATCH_YES)
769 break;
770 if (gfc_match_char (',') != MATCH_YES)
771 goto syntax;
772 }
773
774 if (gfc_match_omp_eos () != MATCH_YES)
775 {
776 gfc_error ("Unexpected junk after !$ACC DECLARE at %C");
777 goto cleanup;
778 }
779
780 while (*list)
781 list = &(*list)->next;
782 *list = head;
783 return MATCH_YES;
784
785syntax:
786 gfc_error ("Syntax error in !$ACC DECLARE list at %C");
787
788cleanup:
789 gfc_current_locus = old_loc;
790 return MATCH_ERROR;
791}
792
d58e7173 793/* OpenMP clauses. */
b4c3a85b
JJ		 794enum omp_mask1
795{
796 OMP_CLAUSE_PRIVATE,
797 OMP_CLAUSE_FIRSTPRIVATE,
798 OMP_CLAUSE_LASTPRIVATE,
799 OMP_CLAUSE_COPYPRIVATE,
800 OMP_CLAUSE_SHARED,
801 OMP_CLAUSE_COPYIN,
802 OMP_CLAUSE_REDUCTION,
e929ef53
TB		 803 OMP_CLAUSE_IN_REDUCTION,
804 OMP_CLAUSE_TASK_REDUCTION,
b4c3a85b
JJ		 805 OMP_CLAUSE_IF,
806 OMP_CLAUSE_NUM_THREADS,
807 OMP_CLAUSE_SCHEDULE,
808 OMP_CLAUSE_DEFAULT,
d8140b9e 809 OMP_CLAUSE_ORDER,
b4c3a85b
JJ		 810 OMP_CLAUSE_ORDERED,
811 OMP_CLAUSE_COLLAPSE,
812 OMP_CLAUSE_UNTIED,
813 OMP_CLAUSE_FINAL,
814 OMP_CLAUSE_MERGEABLE,
815 OMP_CLAUSE_ALIGNED,
816 OMP_CLAUSE_DEPEND,
817 OMP_CLAUSE_INBRANCH,
818 OMP_CLAUSE_LINEAR,
819 OMP_CLAUSE_NOTINBRANCH,
820 OMP_CLAUSE_PROC_BIND,
821 OMP_CLAUSE_SAFELEN,
822 OMP_CLAUSE_SIMDLEN,
823 OMP_CLAUSE_UNIFORM,
824 OMP_CLAUSE_DEVICE,
825 OMP_CLAUSE_MAP,
826 OMP_CLAUSE_TO,
827 OMP_CLAUSE_FROM,
828 OMP_CLAUSE_NUM_TEAMS,
829 OMP_CLAUSE_THREAD_LIMIT,
830 OMP_CLAUSE_DIST_SCHEDULE,
831 OMP_CLAUSE_DEFAULTMAP,
832 OMP_CLAUSE_GRAINSIZE,
833 OMP_CLAUSE_HINT,
834 OMP_CLAUSE_IS_DEVICE_PTR,
835 OMP_CLAUSE_LINK,
836 OMP_CLAUSE_NOGROUP,
21cfe724 837 OMP_CLAUSE_NOTEMPORAL,
b4c3a85b
JJ		 838 OMP_CLAUSE_NUM_TASKS,
839 OMP_CLAUSE_PRIORITY,
840 OMP_CLAUSE_SIMD,
841 OMP_CLAUSE_THREADS,
842 OMP_CLAUSE_USE_DEVICE_PTR,
d58e7173
TB		 843 OMP_CLAUSE_USE_DEVICE_ADDR, /* OpenMP 5.0. */
844 OMP_CLAUSE_DEVICE_TYPE, /* OpenMP 5.0. */
1fc5e7ef
TB		 845 OMP_CLAUSE_ATOMIC, /* OpenMP 5.0. */
846 OMP_CLAUSE_CAPTURE, /* OpenMP 5.0. */
847 OMP_CLAUSE_MEMORDER, /* OpenMP 5.0. */
a6d22fb2 848 OMP_CLAUSE_DETACH, /* OpenMP 5.0. */
9a5de4d5 849 OMP_CLAUSE_AFFINITY, /* OpenMP 5.0. */
178191e1 850 OMP_CLAUSE_BIND, /* OpenMP 5.0. */
53d5b59c 851 OMP_CLAUSE_FILTER, /* OpenMP 5.1. */
77167196
TB		 852 OMP_CLAUSE_AT, /* OpenMP 5.1. */
853 OMP_CLAUSE_MESSAGE, /* OpenMP 5.1. */
854 OMP_CLAUSE_SEVERITY, /* OpenMP 5.1. */
b4c3a85b
JJ		 855 OMP_CLAUSE_NOWAIT,
856 /* This must come last. */
857 OMP_MASK1_LAST
858};
859
549188ea 860/* OpenACC 2.0+ specific clauses. */
b4c3a85b
JJ		 861enum omp_mask2
862{
863 OMP_CLAUSE_ASYNC,
864 OMP_CLAUSE_NUM_GANGS,
865 OMP_CLAUSE_NUM_WORKERS,
866 OMP_CLAUSE_VECTOR_LENGTH,
867 OMP_CLAUSE_COPY,
868 OMP_CLAUSE_COPYOUT,
869 OMP_CLAUSE_CREATE,
a6163563 870 OMP_CLAUSE_NO_CREATE,
b4c3a85b 871 OMP_CLAUSE_PRESENT,
b4c3a85b
JJ		 872 OMP_CLAUSE_DEVICEPTR,
873 OMP_CLAUSE_GANG,
874 OMP_CLAUSE_WORKER,
875 OMP_CLAUSE_VECTOR,
876 OMP_CLAUSE_SEQ,
877 OMP_CLAUSE_INDEPENDENT,
878 OMP_CLAUSE_USE_DEVICE,
879 OMP_CLAUSE_DEVICE_RESIDENT,
880 OMP_CLAUSE_HOST_SELF,
881 OMP_CLAUSE_WAIT,
882 OMP_CLAUSE_DELETE,
883 OMP_CLAUSE_AUTO,
884 OMP_CLAUSE_TILE,
829c6349
CLT		 885 OMP_CLAUSE_IF_PRESENT,
886 OMP_CLAUSE_FINALIZE,
549188ea 887 OMP_CLAUSE_ATTACH,
a61f6afb 888 OMP_CLAUSE_NOHOST,
b4c3a85b
JJ		 889 /* This must come last. */
890 OMP_MASK2_LAST
891};
892
893struct omp_inv_mask;
894
895/* Customized bitset for up to 128-bits.
896 The two enums above provide bit numbers to use, and which of the
897 two enums it is determines which of the two mask fields is used.
898 Supported operations are defining a mask, like:
899 #define XXX_CLAUSES \
900 (omp_mask (OMP_CLAUSE_XXX) | OMP_CLAUSE_YYY | OMP_CLAUSE_ZZZ)
901 oring such bitsets together or removing selected bits:
902 (XXX_CLAUSES | YYY_CLAUSES) & ~(omp_mask (OMP_CLAUSE_VVV))
903 and testing individual bits:
904 if (mask & OMP_CLAUSE_UUU) */
905
906struct omp_mask {
907 const uint64_t mask1;
908 const uint64_t mask2;
909 inline omp_mask ();
910 inline omp_mask (omp_mask1);
911 inline omp_mask (omp_mask2);
912 inline omp_mask (uint64_t, uint64_t);
913 inline omp_mask operator| (omp_mask1) const;
914 inline omp_mask operator| (omp_mask2) const;
915 inline omp_mask operator| (omp_mask) const;
916 inline omp_mask operator& (const omp_inv_mask &) const;
917 inline bool operator& (omp_mask1) const;
918 inline bool operator& (omp_mask2) const;
919 inline omp_inv_mask operator~ () const;
920};
921
922struct omp_inv_mask : public omp_mask {
923 inline omp_inv_mask (const omp_mask &);
924};
925
926omp_mask::omp_mask () : mask1 (0), mask2 (0)
927{
928}
929
930omp_mask::omp_mask (omp_mask1 m) : mask1 (((uint64_t) 1) << m), mask2 (0)
931{
932}
933
934omp_mask::omp_mask (omp_mask2 m) : mask1 (0), mask2 (((uint64_t) 1) << m)
935{
936}
937
938omp_mask::omp_mask (uint64_t m1, uint64_t m2) : mask1 (m1), mask2 (m2)
939{
940}
941
942omp_mask
943omp_mask::operator| (omp_mask1 m) const
944{
945 return omp_mask (mask1 | (((uint64_t) 1) << m), mask2);
946}
947
948omp_mask
949omp_mask::operator| (omp_mask2 m) const
950{
951 return omp_mask (mask1, mask2 | (((uint64_t) 1) << m));
952}
953
954omp_mask
955omp_mask::operator| (omp_mask m) const
956{
957 return omp_mask (mask1 | m.mask1, mask2 | m.mask2);
958}
959
960omp_mask
961omp_mask::operator& (const omp_inv_mask &m) const
962{
963 return omp_mask (mask1 & ~m.mask1, mask2 & ~m.mask2);
964}
965
966bool
967omp_mask::operator& (omp_mask1 m) const
968{
969 return (mask1 & (((uint64_t) 1) << m)) != 0;
970}
971
972bool
973omp_mask::operator& (omp_mask2 m) const
974{
975 return (mask2 & (((uint64_t) 1) << m)) != 0;
976}
977
978omp_inv_mask
979omp_mask::operator~ () const
980{
981 return omp_inv_mask (*this);
982}
983
984omp_inv_mask::omp_inv_mask (const omp_mask &m) : omp_mask (m)
985{
986}
41dbbb37
TS		 987
988/* Helper function for OpenACC and OpenMP clauses involving memory
989 mapping. */
990
991static bool
ec084613 992gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op,
549188ea 993 bool allow_common, bool allow_derived)
41dbbb37
TS		 994{
995 gfc_omp_namelist **head = NULL;
549188ea
JB		 996 if (gfc_match_omp_variable_list ("", list, allow_common, NULL, &head, true,
997 allow_derived)
41dbbb37
TS		 998 == MATCH_YES)
999 {
1000 gfc_omp_namelist *n;
1001 for (n = *head; n; n = n->next)
1002 n->u.map_op = map_op;
1003 return true;
1004 }
1005
1006 return false;
1007}
1008
9a5de4d5
TB		 1009static match
1010gfc_match_iterator (gfc_namespace **ns, bool permit_var)
1011{
1012 locus old_loc = gfc_current_locus;
1013
1014 if (gfc_match ("iterator ( ") != MATCH_YES)
1015 return MATCH_NO;
1016
1017 gfc_typespec ts;
1018 gfc_symbol *last = NULL;
1019 gfc_expr *begin, *end, *step;
1020 *ns = gfc_build_block_ns (gfc_current_ns);
1021 char name[GFC_MAX_SYMBOL_LEN + 1];
1022 while (true)
1023 {
1024 locus prev_loc = gfc_current_locus;
1025 if (gfc_match_type_spec (&ts) == MATCH_YES
1026 && gfc_match (" :: ") == MATCH_YES)
1027 {
1028 if (ts.type != BT_INTEGER)
1029 {
1030 gfc_error ("Expected INTEGER type at %L", &prev_loc);
1031 return MATCH_ERROR;
1032 }
1033 permit_var = false;
1034 }
1035 else
1036 {
1037 ts.type = BT_INTEGER;
1038 ts.kind = gfc_default_integer_kind;
1039 gfc_current_locus = prev_loc;
1040 }
1041 prev_loc = gfc_current_locus;
1042 if (gfc_match_name (name) != MATCH_YES)
1043 {
1044 gfc_error ("Expected identifier at %C");
1045 goto failed;
1046 }
1047 if (gfc_find_symtree ((*ns)->sym_root, name))
1048 {
1049 gfc_error ("Same identifier %qs specified again at %C", name);
1050 goto failed;
1051 }
1052
1053 gfc_symbol *sym = gfc_new_symbol (name, *ns);
1054 if (last)
1055 last->tlink = sym;
1056 else
1057 (*ns)->proc_name = sym;
1058 last = sym;
1059 sym->declared_at = prev_loc;
1060 sym->ts = ts;
1061 sym->attr.flavor = FL_VARIABLE;
1062 sym->attr.artificial = 1;
1063 sym->attr.referenced = 1;
1064 sym->refs++;
1065 gfc_symtree *st = gfc_new_symtree (&(*ns)->sym_root, name);
1066 st->n.sym = sym;
1067
1068 prev_loc = gfc_current_locus;
1069 if (gfc_match (" = ") != MATCH_YES)
1070 goto failed;
1071 permit_var = false;
1072 begin = end = step = NULL;
1073 if (gfc_match ("%e : ", &begin) != MATCH_YES
1074 || gfc_match ("%e ", &end) != MATCH_YES)
1075 {
1076 gfc_error ("Expected range-specification at %C");
1077 gfc_free_expr (begin);
1078 gfc_free_expr (end);
1079 return MATCH_ERROR;
1080 }
1081 if (':' == gfc_peek_ascii_char ())
1082 {
1083 step = gfc_get_expr ();
1084 if (gfc_match (": %e ", &step) != MATCH_YES)
1085 {
1086 gfc_free_expr (begin);
1087 gfc_free_expr (end);
1088 gfc_free_expr (step);
1089 goto failed;
1090 }
1091 }
1092
1093 gfc_expr *e = gfc_get_expr ();
1094 e->where = prev_loc;
1095 e->expr_type = EXPR_ARRAY;
1096 e->ts = ts;
1097 e->rank = 1;
1098 e->shape = gfc_get_shape (1);
1099 mpz_init_set_ui (e->shape[0], step ? 3 : 2);
1100 gfc_constructor_append_expr (&e->value.constructor, begin, &begin->where);
1101 gfc_constructor_append_expr (&e->value.constructor, end, &end->where);
1102 if (step)
1103 gfc_constructor_append_expr (&e->value.constructor, step, &step->where);
1104 sym->value = e;
1105
1106 if (gfc_match (") ") == MATCH_YES)
1107 break;
1108 if (gfc_match (", ") != MATCH_YES)
1109 goto failed;
1110 }
1111 return MATCH_YES;
1112
1113failed:
1114 gfc_namespace *prev_ns = NULL;
1115 for (gfc_namespace *it = gfc_current_ns->contained; it; it = it->sibling)
1116 {
1117 if (it == *ns)
1118 {
1119 if (prev_ns)
1120 prev_ns->sibling = it->sibling;
1121 else
1122 gfc_current_ns->contained = it->sibling;
1123 gfc_free_namespace (it);
1124 break;
1125 }
1126 prev_ns = it;
1127 }
1128 *ns = NULL;
1129 if (!permit_var)
1130 return MATCH_ERROR;
1131 gfc_current_locus = old_loc;
1132 return MATCH_NO;
1133}
1134
e929ef53
TB		 1135/* reduction ( reduction-modifier, reduction-operator : variable-list )
1136 in_reduction ( reduction-operator : variable-list )
1137 task_reduction ( reduction-operator : variable-list ) */
1138
1139static match
1140gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc,
1141 bool allow_derived)
1142{
1143 if (pc == 'r' && gfc_match ("reduction ( ") != MATCH_YES)
1144 return MATCH_NO;
1145 else if (pc == 'i' && gfc_match ("in_reduction ( ") != MATCH_YES)
1146 return MATCH_NO;
1147 else if (pc == 't' && gfc_match ("task_reduction ( ") != MATCH_YES)
1148 return MATCH_NO;
1149
1150 locus old_loc = gfc_current_locus;
1151 int list_idx = 0;
1152
1153 if (pc == 'r' && !openacc)
1154 {
1155 if (gfc_match ("inscan") == MATCH_YES)
1156 list_idx = OMP_LIST_REDUCTION_INSCAN;
1157 else if (gfc_match ("task") == MATCH_YES)
1158 list_idx = OMP_LIST_REDUCTION_TASK;
1159 else if (gfc_match ("default") == MATCH_YES)
1160 list_idx = OMP_LIST_REDUCTION;
1161 if (list_idx != 0 && gfc_match (", ") != MATCH_YES)
1162 {
1163 gfc_error ("Comma expected at %C");
1164 gfc_current_locus = old_loc;
1165 return MATCH_NO;
1166 }
1167 if (list_idx == 0)
1168 list_idx = OMP_LIST_REDUCTION;
1169 }
1170 else if (pc == 'i')
1171 list_idx = OMP_LIST_IN_REDUCTION;
1172 else if (pc == 't')
1173 list_idx = OMP_LIST_TASK_REDUCTION;
1174 else
1175 list_idx = OMP_LIST_REDUCTION;
1176
1177 gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
1178 char buffer[GFC_MAX_SYMBOL_LEN + 3];
1179 if (gfc_match_char ('+') == MATCH_YES)
1180 rop = OMP_REDUCTION_PLUS;
1181 else if (gfc_match_char ('*') == MATCH_YES)
1182 rop = OMP_REDUCTION_TIMES;
1183 else if (gfc_match_char ('-') == MATCH_YES)
1184 rop = OMP_REDUCTION_MINUS;
1185 else if (gfc_match (".and.") == MATCH_YES)
1186 rop = OMP_REDUCTION_AND;
1187 else if (gfc_match (".or.") == MATCH_YES)
1188 rop = OMP_REDUCTION_OR;
1189 else if (gfc_match (".eqv.") == MATCH_YES)
1190 rop = OMP_REDUCTION_EQV;
1191 else if (gfc_match (".neqv.") == MATCH_YES)
1192 rop = OMP_REDUCTION_NEQV;
1193 if (rop != OMP_REDUCTION_NONE)
1194 snprintf (buffer, sizeof buffer, "operator %s",
1195 gfc_op2string ((gfc_intrinsic_op) rop));
1196 else if (gfc_match_defined_op_name (buffer + 1, 1) == MATCH_YES)
1197 {
1198 buffer[0] = '.';
1199 strcat (buffer, ".");
1200 }
1201 else if (gfc_match_name (buffer) == MATCH_YES)
1202 {
1203 gfc_symbol *sym;
1204 const char *n = buffer;
1205
1206 gfc_find_symbol (buffer, NULL, 1, &sym);
1207 if (sym != NULL)
1208 {
1209 if (sym->attr.intrinsic)
1210 n = sym->name;
1211 else if ((sym->attr.flavor != FL_UNKNOWN
1212 && sym->attr.flavor != FL_PROCEDURE)
1213 || sym->attr.external
1214 || sym->attr.generic
1215 || sym->attr.entry
1216 || sym->attr.result
1217 || sym->attr.dummy
1218 || sym->attr.subroutine
1219 || sym->attr.pointer
1220 || sym->attr.target
1221 || sym->attr.cray_pointer
1222 || sym->attr.cray_pointee
1223 || (sym->attr.proc != PROC_UNKNOWN
1224 && sym->attr.proc != PROC_INTRINSIC)
1225 || sym->attr.if_source != IFSRC_UNKNOWN
1226 || sym == sym->ns->proc_name)
1227 {
1228 sym = NULL;
1229 n = NULL;
1230 }
1231 else
1232 n = sym->name;
1233 }
1234 if (n == NULL)
1235 rop = OMP_REDUCTION_NONE;
1236 else if (strcmp (n, "max") == 0)
1237 rop = OMP_REDUCTION_MAX;
1238 else if (strcmp (n, "min") == 0)
1239 rop = OMP_REDUCTION_MIN;
1240 else if (strcmp (n, "iand") == 0)
1241 rop = OMP_REDUCTION_IAND;
1242 else if (strcmp (n, "ior") == 0)
1243 rop = OMP_REDUCTION_IOR;
1244 else if (strcmp (n, "ieor") == 0)
1245 rop = OMP_REDUCTION_IEOR;
1246 if (rop != OMP_REDUCTION_NONE
1247 && sym != NULL
1248 && ! sym->attr.intrinsic
1249 && ! sym->attr.use_assoc
1250 && ((sym->attr.flavor == FL_UNKNOWN
1251 && !gfc_add_flavor (&sym->attr, FL_PROCEDURE,
1252 sym->name, NULL))
1253 || !gfc_add_intrinsic (&sym->attr, NULL)))
1254 rop = OMP_REDUCTION_NONE;
1255 }
1256 else
1257 buffer[0] = '\0';
1258 gfc_omp_udr *udr = (buffer[0] ? gfc_find_omp_udr (gfc_current_ns, buffer, NULL)
1259 : NULL);
1260 gfc_omp_namelist **head = NULL;
1261 if (rop == OMP_REDUCTION_NONE && udr)
1262 rop = OMP_REDUCTION_USER;
1263
1264 if (gfc_match_omp_variable_list (" :", &c->lists[list_idx], false, NULL,
1265 &head, openacc, allow_derived) != MATCH_YES)
1266 {
1267 gfc_current_locus = old_loc;
1268 return MATCH_NO;
1269 }
1270 gfc_omp_namelist *n;
1271 if (rop == OMP_REDUCTION_NONE)
1272 {
1273 n = *head;
1274 *head = NULL;
1275 gfc_error_now ("!$OMP DECLARE REDUCTION %s not found at %L",
1276 buffer, &old_loc);
9a5de4d5 1277 gfc_free_omp_namelist (n, false);
e929ef53
TB		 1278 }
1279 else
1280 for (n = *head; n; n = n->next)
1281 {
1282 n->u.reduction_op = rop;
1283 if (udr)
1284 {
9a5de4d5
TB		 1285 n->u2.udr = gfc_get_omp_namelist_udr ();
1286 n->u2.udr->udr = udr;
e929ef53
TB		 1287 }
1288 }
1289 return MATCH_YES;
1290}
1291
41dbbb37 1292/* Match OpenMP and OpenACC directive clauses. MASK is a bitmask of
6c7a4dfd
JJ		 1293 clauses that are allowed for a particular directive. */
1294
1295static match
b4c3a85b 1296gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
41dbbb37
TS		 1297 bool first = true, bool needs_space = true,
1298 bool openacc = false)
6c7a4dfd 1299{
77167196 1300 bool error = false;
6c7a4dfd
JJ		 1301 gfc_omp_clauses *c = gfc_get_omp_clauses ();
1302 locus old_loc;
549188ea
JB		 1303 /* Determine whether we're dealing with an OpenACC directive that permits
1304 derived type member accesses. This in particular disallows
1305 "!$acc declare" from using such accesses, because it's not clear if/how
1306 that should work. */
1307 bool allow_derived = (openacc
1308 && ((mask & OMP_CLAUSE_ATTACH)
1309 || (mask & OMP_CLAUSE_DETACH)
1310 || (mask & OMP_CLAUSE_HOST_SELF)));
6c7a4dfd 1311
b4c3a85b 1312 gcc_checking_assert (OMP_MASK1_LAST <= 64 && OMP_MASK2_LAST <= 64);
6c7a4dfd
JJ		 1313 *cp = NULL;
1314 while (1)
1315 {
1316 if ((first || gfc_match_char (',') != MATCH_YES)
1317 && (needs_space && gfc_match_space () != MATCH_YES))
1318 break;
1319 needs_space = false;
1320 first = false;
1321 gfc_gobble_whitespace ();
0f66751a
JJ		 1322 bool end_colon;
1323 gfc_omp_namelist **head;
1324 old_loc = gfc_current_locus;
1325 char pc = gfc_peek_ascii_char ();
1326 switch (pc)
41dbbb37 1327 {
0f66751a
JJ		 1328 case 'a':
1329 end_colon = false;
1330 head = NULL;
1331 if ((mask & OMP_CLAUSE_ALIGNED)
1332 && gfc_match_omp_variable_list ("aligned (",
1333 &c->lists[OMP_LIST_ALIGNED],
1334 false, &end_colon,
1335 &head) == MATCH_YES)
41dbbb37 1336 {
0f66751a 1337 gfc_expr *alignment = NULL;
41dbbb37 1338 gfc_omp_namelist *n;
0f66751a
JJ		 1339
1340 if (end_colon && gfc_match (" %e )", &alignment) != MATCH_YES)
1341 {
9a5de4d5 1342 gfc_free_omp_namelist (*head, false);
0f66751a
JJ		 1343 gfc_current_locus = old_loc;
1344 *head = NULL;
1345 break;
1346 }
41dbbb37 1347 for (n = *head; n; n = n->next)
0f66751a
JJ		 1348 if (n->next && alignment)
1349 n->expr = gfc_copy_expr (alignment);
1350 else
1351 n->expr = alignment;
41dbbb37
TS		 1352 continue;
1353 }
1fc5e7ef
TB		 1354 if ((mask & OMP_CLAUSE_MEMORDER)
1355 && c->memorder == OMP_MEMORDER_UNSET
1356 && gfc_match ("acq_rel") == MATCH_YES)
1357 {
1358 c->memorder = OMP_MEMORDER_ACQ_REL;
1359 needs_space = true;
1360 continue;
1361 }
1362 if ((mask & OMP_CLAUSE_MEMORDER)
1363 && c->memorder == OMP_MEMORDER_UNSET
1364 && gfc_match ("acquire") == MATCH_YES)
1365 {
1366 c->memorder = OMP_MEMORDER_ACQUIRE;
1367 needs_space = true;
1368 continue;
1369 }
9a5de4d5
TB		 1370 if ((mask & OMP_CLAUSE_AFFINITY)
1371 && gfc_match ("affinity ( ") == MATCH_YES)
1372 {
1373 gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
1374 match m = gfc_match_iterator (&ns_iter, true);
1375 if (m == MATCH_ERROR)
1376 break;
1377 if (m == MATCH_YES && gfc_match (" : ") != MATCH_YES)
1378 {
1379 gfc_error ("Expected %<:%> at %C");
1380 break;
1381 }
1382 if (ns_iter)
1383 gfc_current_ns = ns_iter;
1384 head = NULL;
1385 m = gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_AFFINITY],
1386 false, NULL, &head, true);
1387 gfc_current_ns = ns_curr;
1388 if (m == MATCH_ERROR)
1389 break;
1390 if (ns_iter)
1391 {
1392 for (gfc_omp_namelist *n = *head; n; n = n->next)
1393 {
1394 n->u2.ns = ns_iter;
1395 ns_iter->refs++;
1396 }
1397 }
1398 continue;
1399 }
77167196
TB		 1400 if ((mask & OMP_CLAUSE_AT)
1401 && c->at == OMP_AT_UNSET
1402 && gfc_match ("at ( ") == MATCH_YES)
1403 {
1404 if (gfc_match ("compilation )") == MATCH_YES)
1405 c->at = OMP_AT_COMPILATION;
1406 else if (gfc_match ("execution )") == MATCH_YES)
1407 c->at = OMP_AT_EXECUTION;
1408 else
1409 {
1410 gfc_error ("Expected COMPILATION or EXECUTION in AT clause "
1411 "at %C");
1412 goto error;
1413 }
1414 continue;
1415 }
0f66751a
JJ		 1416 if ((mask & OMP_CLAUSE_ASYNC)
1417 && !c->async
1418 && gfc_match ("async") == MATCH_YES)
5f23671d 1419 {
0f66751a 1420 c->async = true;
27f67461
CP		 1421 match m = gfc_match (" ( %e )", &c->async_expr);
1422 if (m == MATCH_ERROR)
1423 {
1424 gfc_current_locus = old_loc;
1425 break;
1426 }
1427 else if (m == MATCH_NO)
0f66751a
JJ		 1428 {
1429 c->async_expr
1430 = gfc_get_constant_expr (BT_INTEGER,
1431 gfc_default_integer_kind,
1432 &gfc_current_locus);
1433 mpz_set_si (c->async_expr->value.integer, GOMP_ASYNC_NOVAL);
27f67461 1434 needs_space = true;
0f66751a
JJ		 1435 }
1436 continue;
5f23671d 1437 }
0f66751a
JJ		 1438 if ((mask & OMP_CLAUSE_AUTO)
1439 && !c->par_auto
1440 && gfc_match ("auto") == MATCH_YES)
6c7a4dfd 1441 {
0f66751a
JJ		 1442 c->par_auto = true;
1443 needs_space = true;
1444 continue;
1445 }
549188ea
JB		 1446 if ((mask & OMP_CLAUSE_ATTACH)
1447 && gfc_match ("attach ( ") == MATCH_YES
1448 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1449 OMP_MAP_ATTACH, false,
1450 allow_derived))
1451 continue;
0f66751a 1452 break;
178191e1
TB		 1453 case 'b':
1454 if ((mask & OMP_CLAUSE_BIND)
1455 && c->bind == OMP_BIND_UNSET
1456 && gfc_match ("bind ( ") == MATCH_YES)
1457 {
1458 if (gfc_match ("teams )") == MATCH_YES)
1459 c->bind = OMP_BIND_TEAMS;
1460 else if (gfc_match ("parallel )") == MATCH_YES)
1461 c->bind = OMP_BIND_PARALLEL;
1462 else if (gfc_match ("thread )") == MATCH_YES)
1463 c->bind = OMP_BIND_THREAD;
1464 else
1465 {
848a3603 1466 gfc_error ("Expected TEAMS, PARALLEL or THREAD as binding in "
178191e1
TB		 1467 "BIND at %C");
1468 break;
1469 }
1470 continue;
1471 }
1472 break;
0f66751a 1473 case 'c':
1fc5e7ef
TB		 1474 if ((mask & OMP_CLAUSE_CAPTURE)
1475 && !c->capture
1476 && gfc_match ("capture") == MATCH_YES)
1477 {
1478 c->capture = true;
1479 needs_space = true;
1480 continue;
1481 }
0f66751a
JJ		 1482 if ((mask & OMP_CLAUSE_COLLAPSE)
1483 && !c->collapse)
1484 {
1485 gfc_expr *cexpr = NULL;
1486 match m = gfc_match ("collapse ( %e )", &cexpr);
6c7a4dfd 1487
0f66751a 1488 if (m == MATCH_YES)
6c7a4dfd 1489 {
0f66751a 1490 int collapse;
51f03c6b
JJ		 1491 if (gfc_extract_int (cexpr, &collapse, -1))
1492 collapse = 1;
0f66751a
JJ		 1493 else if (collapse <= 0)
1494 {
1495 gfc_error_now ("COLLAPSE clause argument not"
1496 " constant positive integer at %C");
1497 collapse = 1;
1498 }
1499 c->collapse = collapse;
1500 gfc_free_expr (cexpr);
1501 continue;
6c7a4dfd 1502 }
5f23671d 1503 }
0f66751a
JJ		 1504 if ((mask & OMP_CLAUSE_COPY)
1505 && gfc_match ("copy ( ") == MATCH_YES
1506 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
549188ea
JB		 1507 OMP_MAP_TOFROM, true,
1508 allow_derived))
0f66751a
JJ		 1509 continue;
1510 if (mask & OMP_CLAUSE_COPYIN)
5f23671d 1511 {
0f66751a 1512 if (openacc)
6c7a4dfd 1513 {
0f66751a
JJ		 1514 if (gfc_match ("copyin ( ") == MATCH_YES
1515 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
549188ea
JB		 1516 OMP_MAP_TO, true,
1517 allow_derived))
0f66751a
JJ		 1518 continue;
1519 }
1520 else if (gfc_match_omp_variable_list ("copyin (",
1521 &c->lists[OMP_LIST_COPYIN],
1522 true) == MATCH_YES)
1523 continue;
1524 }
1525 if ((mask & OMP_CLAUSE_COPYOUT)
1526 && gfc_match ("copyout ( ") == MATCH_YES
1527 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
549188ea 1528 OMP_MAP_FROM, true, allow_derived))
0f66751a
JJ		 1529 continue;
1530 if ((mask & OMP_CLAUSE_COPYPRIVATE)
1531 && gfc_match_omp_variable_list ("copyprivate (",
1532 &c->lists[OMP_LIST_COPYPRIVATE],
1533 true) == MATCH_YES)
1534 continue;
1535 if ((mask & OMP_CLAUSE_CREATE)
1536 && gfc_match ("create ( ") == MATCH_YES
1537 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
549188ea 1538 OMP_MAP_ALLOC, true, allow_derived))
0f66751a
JJ		 1539 continue;
1540 break;
1541 case 'd':
0f66751a
JJ		 1542 if ((mask & OMP_CLAUSE_DEFAULT)
1543 && c->default_sharing == OMP_DEFAULT_UNKNOWN)
1544 {
1545 if (gfc_match ("default ( none )") == MATCH_YES)
1546 c->default_sharing = OMP_DEFAULT_NONE;
1547 else if (openacc)
7fd549d2
TS		 1548 {
1549 if (gfc_match ("default ( present )") == MATCH_YES)
1550 c->default_sharing = OMP_DEFAULT_PRESENT;
1551 }
1552 else
1553 {
1554 if (gfc_match ("default ( firstprivate )") == MATCH_YES)
1555 c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE;
1556 else if (gfc_match ("default ( private )") == MATCH_YES)
1557 c->default_sharing = OMP_DEFAULT_PRIVATE;
1558 else if (gfc_match ("default ( shared )") == MATCH_YES)
1559 c->default_sharing = OMP_DEFAULT_SHARED;
1560 }
0f66751a
JJ		 1561 if (c->default_sharing != OMP_DEFAULT_UNKNOWN)
1562 continue;
1563 }
b4c3a85b 1564 if ((mask & OMP_CLAUSE_DEFAULTMAP)
1de31913
TB		 1565 && gfc_match ("defaultmap ( ") == MATCH_YES)
1566 {
1567 enum gfc_omp_defaultmap behavior;
1568 gfc_omp_defaultmap_category category
1569 = OMP_DEFAULTMAP_CAT_UNCATEGORIZED;
1570 if (gfc_match ("alloc ") == MATCH_YES)
1571 behavior = OMP_DEFAULTMAP_ALLOC;
1572 else if (gfc_match ("tofrom ") == MATCH_YES)
1573 behavior = OMP_DEFAULTMAP_TOFROM;
1574 else if (gfc_match ("to ") == MATCH_YES)
1575 behavior = OMP_DEFAULTMAP_TO;
1576 else if (gfc_match ("from ") == MATCH_YES)
1577 behavior = OMP_DEFAULTMAP_FROM;
1578 else if (gfc_match ("firstprivate ") == MATCH_YES)
1579 behavior = OMP_DEFAULTMAP_FIRSTPRIVATE;
1580 else if (gfc_match ("none ") == MATCH_YES)
1581 behavior = OMP_DEFAULTMAP_NONE;
1582 else if (gfc_match ("default ") == MATCH_YES)
1583 behavior = OMP_DEFAULTMAP_DEFAULT;
1584 else
1585 {
1586 gfc_error ("Expected ALLOC, TO, FROM, TOFROM, FIRSTPRIVATE, "
1587 "NONE or DEFAULT at %C");
1588 break;
1589 }
1590 if (')' == gfc_peek_ascii_char ())
1591 ;
1592 else if (gfc_match (": ") != MATCH_YES)
1593 break;
1594 else
1595 {
1596 if (gfc_match ("scalar ") == MATCH_YES)
1597 category = OMP_DEFAULTMAP_CAT_SCALAR;
1598 else if (gfc_match ("aggregate ") == MATCH_YES)
1599 category = OMP_DEFAULTMAP_CAT_AGGREGATE;
1600 else if (gfc_match ("allocatable ") == MATCH_YES)
1601 category = OMP_DEFAULTMAP_CAT_ALLOCATABLE;
1602 else if (gfc_match ("pointer ") == MATCH_YES)
1603 category = OMP_DEFAULTMAP_CAT_POINTER;
1604 else
1605 {
1606 gfc_error ("Expected SCALAR, AGGREGATE, ALLOCATABLE or "
1607 "POINTER at %C");
1608 break;
1609 }
1610 }
1611 for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; ++i)
1612 {
1613 if (i != category
1614 && category != OMP_DEFAULTMAP_CAT_UNCATEGORIZED)
1615 continue;
1616 if (c->defaultmap[i] != OMP_DEFAULTMAP_UNSET)
1617 {
1618 const char *pcategory = NULL;
1619 switch (i)
1620 {
1621 case OMP_DEFAULTMAP_CAT_UNCATEGORIZED: break;
1622 case OMP_DEFAULTMAP_CAT_SCALAR: pcategory = "SCALAR"; break;
1623 case OMP_DEFAULTMAP_CAT_AGGREGATE:
1624 pcategory = "AGGREGATE";
1625 break;
1626 case OMP_DEFAULTMAP_CAT_ALLOCATABLE:
1627 pcategory = "ALLOCATABLE";
1628 break;
1629 case OMP_DEFAULTMAP_CAT_POINTER:
1630 pcategory = "POINTER";
1631 break;
1632 default: gcc_unreachable ();
1633 }
1634 if (i == OMP_DEFAULTMAP_CAT_UNCATEGORIZED)
1635 gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP with "
1636 "unspecified category");
1637 else
1638 gfc_error ("DEFAULTMAP at %C but prior DEFAULTMAP for "
1639 "category %s", pcategory);
77167196 1640 goto error;
1de31913
TB		 1641 }
1642 }
1643 c->defaultmap[category] = behavior;
1644 if (gfc_match (")") != MATCH_YES)
1645 break;
b4c3a85b
JJ		 1646 continue;
1647 }
1648 if ((mask & OMP_CLAUSE_DELETE)
1649 && gfc_match ("delete ( ") == MATCH_YES
1650 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
549188ea
JB		 1651 OMP_MAP_RELEASE, true,
1652 allow_derived))
b4c3a85b 1653 continue;
0f66751a
JJ		 1654 if ((mask & OMP_CLAUSE_DEPEND)
1655 && gfc_match ("depend ( ") == MATCH_YES)
1656 {
9a5de4d5
TB		 1657 gfc_namespace *ns_iter = NULL, *ns_curr = gfc_current_ns;
1658 match m_it = gfc_match_iterator (&ns_iter, false);
1659 if (m_it == MATCH_ERROR)
1660 break;
1661 if (m_it == MATCH_YES && gfc_match (" , ") != MATCH_YES)
1662 break;
0f66751a
JJ		 1663 match m = MATCH_YES;
1664 gfc_omp_depend_op depend_op = OMP_DEPEND_OUT;
1665 if (gfc_match ("inout") == MATCH_YES)
1666 depend_op = OMP_DEPEND_INOUT;
1667 else if (gfc_match ("in") == MATCH_YES)
1668 depend_op = OMP_DEPEND_IN;
1669 else if (gfc_match ("out") == MATCH_YES)
1670 depend_op = OMP_DEPEND_OUT;
a61c4964
TB		 1671 else if (gfc_match ("mutexinoutset") == MATCH_YES)
1672 depend_op = OMP_DEPEND_MUTEXINOUTSET;
1673 else if (gfc_match ("depobj") == MATCH_YES)
1674 depend_op = OMP_DEPEND_DEPOBJ;
b4c3a85b
JJ		 1675 else if (!c->depend_source
1676 && gfc_match ("source )") == MATCH_YES)
1677 {
9a5de4d5
TB		 1678 if (m_it == MATCH_YES)
1679 {
1680 gfc_error ("ITERATOR may not be combined with SOURCE "
1681 "at %C");
1682 gfc_free_omp_clauses (c);
1683 return MATCH_ERROR;
1684 }
b4c3a85b
JJ		 1685 c->depend_source = true;
1686 continue;
1687 }
1688 else if (gfc_match ("sink : ") == MATCH_YES)
1689 {
9a5de4d5
TB		 1690 if (m_it == MATCH_YES)
1691 {
1692 gfc_error ("ITERATOR may not be combined with SINK "
1693 "at %C");
1694 break;
1695 }
b4c3a85b
JJ		 1696 if (gfc_match_omp_depend_sink (&c->lists[OMP_LIST_DEPEND])
1697 == MATCH_YES)
1698 continue;
1699 m = MATCH_NO;
1700 }
0f66751a
JJ		 1701 else
1702 m = MATCH_NO;
1703 head = NULL;
9a5de4d5
TB		 1704 if (ns_iter)
1705 gfc_current_ns = ns_iter;
1706 if (m == MATCH_YES)
1707 m = gfc_match_omp_variable_list (" : ",
1708 &c->lists[OMP_LIST_DEPEND],
1709 false, NULL, &head, true);
1710 gfc_current_ns = ns_curr;
1711 if (m == MATCH_YES)
0f66751a
JJ		 1712 {
1713 gfc_omp_namelist *n;
1714 for (n = *head; n; n = n->next)
9a5de4d5
TB		 1715 {
1716 n->u.depend_op = depend_op;
1717 n->u2.ns = ns_iter;
1718 if (ns_iter)
1719 ns_iter->refs++;
1720 }
0f66751a 1721 continue;
6c7a4dfd 1722 }
9a5de4d5 1723 break;
6c7a4dfd 1724 }
549188ea 1725 if ((mask & OMP_CLAUSE_DETACH)
a6d22fb2
KCY		 1726 && !openacc
1727 && !c->detach
1728 && gfc_match_omp_detach (&c->detach) == MATCH_YES)
1729 continue;
1730 if ((mask & OMP_CLAUSE_DETACH)
1731 && openacc
549188ea
JB		 1732 && gfc_match ("detach ( ") == MATCH_YES
1733 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
1734 OMP_MAP_DETACH, false,
1735 allow_derived))
1736 continue;
0f66751a 1737 if ((mask & OMP_CLAUSE_DEVICE)
b4c3a85b 1738 && !openacc
0f66751a
JJ		 1739 && c->device == NULL
1740 && gfc_match ("device ( %e )", &c->device) == MATCH_YES)
6c7a4dfd 1741 continue;
b4c3a85b
JJ		 1742 if ((mask & OMP_CLAUSE_DEVICE)
1743 && openacc
0f66751a
JJ		 1744 && gfc_match ("device ( ") == MATCH_YES
1745 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
549188ea
JB		 1746 OMP_MAP_FORCE_TO, true,
1747 allow_derived))
0f66751a
JJ		 1748 continue;
1749 if ((mask & OMP_CLAUSE_DEVICEPTR)
829c6349
CLT		 1750 && gfc_match ("deviceptr ( ") == MATCH_YES
1751 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
549188ea
JB		 1752 OMP_MAP_FORCE_DEVICEPTR, false,
1753 allow_derived))
829c6349 1754 continue;
d58e7173
TB		 1755 if ((mask & OMP_CLAUSE_DEVICE_TYPE)
1756 && gfc_match ("device_type ( ") == MATCH_YES)
1757 {
1758 if (gfc_match ("host") == MATCH_YES)
1759 c->device_type = OMP_DEVICE_TYPE_HOST;
1760 else if (gfc_match ("nohost") == MATCH_YES)
1761 c->device_type = OMP_DEVICE_TYPE_NOHOST;
1762 else if (gfc_match ("any") == MATCH_YES)
1763 c->device_type = OMP_DEVICE_TYPE_ANY;
1764 else
1765 {
1766 gfc_error ("Expected HOST, NOHOST or ANY at %C");
1767 break;
1768 }
1769 if (gfc_match (" )") != MATCH_YES)
1770 break;
1771 continue;
1772 }
0f66751a
JJ		 1773 if ((mask & OMP_CLAUSE_DEVICE_RESIDENT)
1774 && gfc_match_omp_variable_list
1775 ("device_resident (",
1776 &c->lists[OMP_LIST_DEVICE_RESIDENT], true) == MATCH_YES)
1777 continue;
1778 if ((mask & OMP_CLAUSE_DIST_SCHEDULE)
1779 && c->dist_sched_kind == OMP_SCHED_NONE
1780 && gfc_match ("dist_schedule ( static") == MATCH_YES)
6c7a4dfd
JJ		 1781 {
1782 match m = MATCH_NO;
0f66751a
JJ		 1783 c->dist_sched_kind = OMP_SCHED_STATIC;
1784 m = gfc_match (" , %e )", &c->dist_chunk_size);
6c7a4dfd
JJ		 1785 if (m != MATCH_YES)
1786 m = gfc_match_char (')');
1787 if (m != MATCH_YES)
0f66751a
JJ		 1788 {
1789 c->dist_sched_kind = OMP_SCHED_NONE;
1790 gfc_current_locus = old_loc;
1791 }
1792 else
1793 continue;
6c7a4dfd 1794 }
0f66751a
JJ		 1795 break;
1796 case 'f':
53d5b59c
TB		 1797 if ((mask & OMP_CLAUSE_FILTER)
1798 && c->filter == NULL
1799 && gfc_match ("filter ( %e )", &c->filter) == MATCH_YES)
1800 continue;
0f66751a
JJ		 1801 if ((mask & OMP_CLAUSE_FINAL)
1802 && c->final_expr == NULL
1803 && gfc_match ("final ( %e )", &c->final_expr) == MATCH_YES)
6c7a4dfd 1804 continue;
829c6349
CLT		 1805 if ((mask & OMP_CLAUSE_FINALIZE)
1806 && !c->finalize
1807 && gfc_match ("finalize") == MATCH_YES)
1808 {
1809 c->finalize = true;
1810 needs_space = true;
1811 continue;
1812 }
0f66751a
JJ		 1813 if ((mask & OMP_CLAUSE_FIRSTPRIVATE)
1814 && gfc_match_omp_variable_list ("firstprivate (",
1815 &c->lists[OMP_LIST_FIRSTPRIVATE],
1816 true) == MATCH_YES)
1817 continue;
1818 if ((mask & OMP_CLAUSE_FROM)
1819 && gfc_match_omp_variable_list ("from (",
1820 &c->lists[OMP_LIST_FROM], false,
1821 NULL, &head, true) == MATCH_YES)
1822 continue;
1823 break;
1824 case 'g':
1825 if ((mask & OMP_CLAUSE_GANG)
1826 && !c->gang
1827 && gfc_match ("gang") == MATCH_YES)
a68ab351 1828 {
0f66751a 1829 c->gang = true;
27f67461
CP		 1830 match m = match_oacc_clause_gwv (c, GOMP_DIM_GANG);
1831 if (m == MATCH_ERROR)
1832 {
1833 gfc_current_locus = old_loc;
1834 break;
1835 }
1836 else if (m == MATCH_NO)
0f66751a
JJ		 1837 needs_space = true;
1838 continue;
1839 }
b4c3a85b
JJ		 1840 if ((mask & OMP_CLAUSE_GRAINSIZE)
1841 && c->grainsize == NULL
d4de7e32
TB		 1842 && gfc_match ("grainsize ( ") == MATCH_YES)
1843 {
1844 if (gfc_match ("strict : ") == MATCH_YES)
1845 c->grainsize_strict = true;
1846 if (gfc_match (" %e )", &c->grainsize) != MATCH_YES)
1847 goto error;
1848 continue;
1849 }
0f66751a
JJ		 1850 break;
1851 case 'h':
b4c3a85b
JJ		 1852 if ((mask & OMP_CLAUSE_HINT)
1853 && c->hint == NULL
1854 && gfc_match ("hint ( %e )", &c->hint) == MATCH_YES)
1855 continue;
0f66751a
JJ		 1856 if ((mask & OMP_CLAUSE_HOST_SELF)
1857 && gfc_match ("host ( ") == MATCH_YES
1858 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
549188ea
JB		 1859 OMP_MAP_FORCE_FROM, true,
1860 allow_derived))
0f66751a
JJ		 1861 continue;
1862 break;
1863 case 'i':
1864 if ((mask & OMP_CLAUSE_IF)
1865 && c->if_expr == NULL
b4c3a85b
JJ		 1866 && gfc_match ("if ( ") == MATCH_YES)
1867 {
b4c3a85b
JJ		 1868 if (!openacc)
1869 {
1870 /* This should match the enum gfc_omp_if_kind order. */
1871 static const char *ifs[OMP_IF_LAST] = {
e55ba804 1872 " cancel : %e )",
b4c3a85b 1873 " parallel : %e )",
e55ba804 1874 " simd : %e )",
b4c3a85b
JJ		 1875 " task : %e )",
1876 " taskloop : %e )",
1877 " target : %e )",
1878 " target data : %e )",
1879 " target update : %e )",
1880 " target enter data : %e )",
1881 " target exit data : %e )" };
1882 int i;
1883 for (i = 0; i < OMP_IF_LAST; i++)
1884 if (c->if_exprs[i] == NULL
1885 && gfc_match (ifs[i], &c->if_exprs[i]) == MATCH_YES)
1886 break;
1887 if (i < OMP_IF_LAST)
1888 continue;
1889 }
656218ab
TB		 1890 if (gfc_match ("%e )", &c->if_expr) == MATCH_YES)
1891 continue;
b4c3a85b
JJ		 1892 gfc_current_locus = old_loc;
1893 }
829c6349
CLT		 1894 if ((mask & OMP_CLAUSE_IF_PRESENT)
1895 && !c->if_present
1896 && gfc_match ("if_present") == MATCH_YES)
1897 {
1898 c->if_present = true;
1899 needs_space = true;
1900 continue;
1901 }
e929ef53
TB		 1902 if ((mask & OMP_CLAUSE_IN_REDUCTION)
1903 && gfc_match_omp_clause_reduction (pc, c, openacc,
1904 allow_derived) == MATCH_YES)
1905 continue;
0f66751a
JJ		 1906 if ((mask & OMP_CLAUSE_INBRANCH)
1907 && !c->inbranch
1908 && !c->notinbranch
1909 && gfc_match ("inbranch") == MATCH_YES)
1910 {
1911 c->inbranch = needs_space = true;
1912 continue;
1913 }
1914 if ((mask & OMP_CLAUSE_INDEPENDENT)
1915 && !c->independent
1916 && gfc_match ("independent") == MATCH_YES)
1917 {
1918 c->independent = true;
1919 needs_space = true;
1920 continue;
1921 }
b4c3a85b
JJ		 1922 if ((mask & OMP_CLAUSE_IS_DEVICE_PTR)
1923 && gfc_match_omp_variable_list
1924 ("is_device_ptr (",
1925 &c->lists[OMP_LIST_IS_DEVICE_PTR], false) == MATCH_YES)
1926 continue;
0f66751a
JJ		 1927 break;
1928 case 'l':
1929 if ((mask & OMP_CLAUSE_LASTPRIVATE)
084dc63a
TB		 1930 && gfc_match ("lastprivate ( ") == MATCH_YES)
1931 {
1932 bool conditional = gfc_match ("conditional : ") == MATCH_YES;
1933 head = NULL;
1934 if (gfc_match_omp_variable_list ("",
1935 &c->lists[OMP_LIST_LASTPRIVATE],
1936 false, NULL, &head) == MATCH_YES)
1937 {
1938 gfc_omp_namelist *n;
1939 for (n = *head; n; n = n->next)
1940 n->u.lastprivate_conditional = conditional;
1941 continue;
1942 }
1943 gfc_current_locus = old_loc;
1944 break;
1945 }
0f66751a
JJ		 1946 end_colon = false;
1947 head = NULL;
1948 if ((mask & OMP_CLAUSE_LINEAR)
b4c3a85b 1949 && gfc_match ("linear (") == MATCH_YES)
0f66751a 1950 {
b4c3a85b 1951 gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
0f66751a
JJ		 1952 gfc_expr *step = NULL;
1953
b4c3a85b
JJ		 1954 if (gfc_match_omp_variable_list (" ref (",
1955 &c->lists[OMP_LIST_LINEAR],
1956 false, NULL, &head)
1957 == MATCH_YES)
1958 linear_op = OMP_LINEAR_REF;
1959 else if (gfc_match_omp_variable_list (" val (",
1960 &c->lists[OMP_LIST_LINEAR],
1961 false, NULL, &head)
c9243c04 1962 == MATCH_YES)
b4c3a85b
JJ		 1963 linear_op = OMP_LINEAR_VAL;
1964 else if (gfc_match_omp_variable_list (" uval (",
1965 &c->lists[OMP_LIST_LINEAR],
1966 false, NULL, &head)
c9243c04 1967 == MATCH_YES)
b4c3a85b
JJ		 1968 linear_op = OMP_LINEAR_UVAL;
1969 else if (gfc_match_omp_variable_list ("",
1970 &c->lists[OMP_LIST_LINEAR],
1971 false, &end_colon, &head)
c9243c04 1972 == MATCH_YES)
b4c3a85b
JJ		 1973 linear_op = OMP_LINEAR_DEFAULT;
1974 else
1975 {
b4c3a85b 1976 gfc_current_locus = old_loc;
b4c3a85b
JJ		 1977 break;
1978 }
1979 if (linear_op != OMP_LINEAR_DEFAULT)
1980 {
1981 if (gfc_match (" :") == MATCH_YES)
1982 end_colon = true;
1983 else if (gfc_match (" )") != MATCH_YES)
1984 {
9a5de4d5 1985 gfc_free_omp_namelist (*head, false);
b4c3a85b
JJ		 1986 gfc_current_locus = old_loc;
1987 *head = NULL;
1988 break;
1989 }
1990 }
0f66751a 1991 if (end_colon && gfc_match (" %e )", &step) != MATCH_YES)
a68ab351 1992 {
9a5de4d5 1993 gfc_free_omp_namelist (*head, false);
0f66751a
JJ		 1994 gfc_current_locus = old_loc;
1995 *head = NULL;
1996 break;
a68ab351 1997 }
0f66751a 1998 else if (!end_colon)
a68ab351 1999 {
0f66751a
JJ		 2000 step = gfc_get_constant_expr (BT_INTEGER,
2001 gfc_default_integer_kind,
2002 &old_loc);
2003 mpz_set_si (step->value.integer, 1);
a68ab351 2004 }
0f66751a 2005 (*head)->expr = step;
b4c3a85b
JJ		 2006 if (linear_op != OMP_LINEAR_DEFAULT)
2007 for (gfc_omp_namelist *n = *head; n; n = n->next)
2008 n->u.linear_op = linear_op;
a68ab351
JJ		 2009 continue;
2010 }
0f66751a 2011 if ((mask & OMP_CLAUSE_LINK)
b4c3a85b 2012 && openacc
0f66751a
JJ		 2013 && (gfc_match_oacc_clause_link ("link (",
2014 &c->lists[OMP_LIST_LINK])
2015 == MATCH_YES))
dd2fc525 2016 continue;
b4c3a85b
JJ		 2017 else if ((mask & OMP_CLAUSE_LINK)
2018 && !openacc
2019 && (gfc_match_omp_to_link ("link (",
2020 &c->lists[OMP_LIST_LINK])
2021 == MATCH_YES))
2022 continue;
0f66751a
JJ		 2023 break;
2024 case 'm':
2025 if ((mask & OMP_CLAUSE_MAP)
2026 && gfc_match ("map ( ") == MATCH_YES)
dd2fc525 2027 {
b4c3a85b 2028 locus old_loc2 = gfc_current_locus;
cdcec2f8
MV		 2029 int always_modifier = 0;
2030 int close_modifier = 0;
2031 locus second_always_locus = old_loc2;
2032 locus second_close_locus = old_loc2;
2033
2034 for (;;)
2035 {
2036 locus current_locus = gfc_current_locus;
2037 if (gfc_match ("always ") == MATCH_YES)
2038 {
2039 if (always_modifier++ == 1)
2040 second_always_locus = current_locus;
2041 }
2042 else if (gfc_match ("close ") == MATCH_YES)
2043 {
2044 if (close_modifier++ == 1)
2045 second_close_locus = current_locus;
2046 }
2047 else
2048 break;
2049 gfc_match (", ");
2050 }
2051
0f66751a
JJ		 2052 gfc_omp_map_op map_op = OMP_MAP_TOFROM;
2053 if (gfc_match ("alloc : ") == MATCH_YES)
2054 map_op = OMP_MAP_ALLOC;
2055 else if (gfc_match ("tofrom : ") == MATCH_YES)
cdcec2f8 2056 map_op = always_modifier ? OMP_MAP_ALWAYS_TOFROM : OMP_MAP_TOFROM;
0f66751a 2057 else if (gfc_match ("to : ") == MATCH_YES)
cdcec2f8 2058 map_op = always_modifier ? OMP_MAP_ALWAYS_TO : OMP_MAP_TO;
0f66751a 2059 else if (gfc_match ("from : ") == MATCH_YES)
cdcec2f8 2060 map_op = always_modifier ? OMP_MAP_ALWAYS_FROM : OMP_MAP_FROM;
b4c3a85b
JJ		 2061 else if (gfc_match ("release : ") == MATCH_YES)
2062 map_op = OMP_MAP_RELEASE;
2063 else if (gfc_match ("delete : ") == MATCH_YES)
2064 map_op = OMP_MAP_DELETE;
cdcec2f8 2065 else
b4c3a85b
JJ		 2066 {
2067 gfc_current_locus = old_loc2;
cdcec2f8
MV		 2068 always_modifier = 0;
2069 close_modifier = 0;
b4c3a85b 2070 }
cdcec2f8
MV		 2071
2072 if (always_modifier > 1)
2073 {
2074 gfc_error ("too many %<always%> modifiers at %L",
2075 &second_always_locus);
2076 break;
2077 }
2078 if (close_modifier > 1)
2079 {
2080 gfc_error ("too many %<close%> modifiers at %L",
2081 &second_close_locus);
2082 break;
2083 }
2084
0f66751a
JJ		 2085 head = NULL;
2086 if (gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_MAP],
2087 false, NULL, &head,
102502e3 2088 true, true) == MATCH_YES)
0f66751a
JJ		 2089 {
2090 gfc_omp_namelist *n;
2091 for (n = *head; n; n = n->next)
2092 n->u.map_op = map_op;
2093 continue;
2094 }
cdcec2f8
MV		 2095 gfc_current_locus = old_loc;
2096 break;
dd2fc525 2097 }
0f66751a
JJ		 2098 if ((mask & OMP_CLAUSE_MERGEABLE) && !c->mergeable
2099 && gfc_match ("mergeable") == MATCH_YES)
2100 {
2101 c->mergeable = needs_space = true;
2102 continue;
2103 }
77167196
TB		 2104 if ((mask & OMP_CLAUSE_MESSAGE)
2105 && !c->message
2106 && gfc_match ("message ( %e )", &c->message) == MATCH_YES)
2107 continue;
0f66751a
JJ		 2108 break;
2109 case 'n':
a6163563
JB		 2110 if ((mask & OMP_CLAUSE_NO_CREATE)
2111 && gfc_match ("no_create ( ") == MATCH_YES
2112 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
549188ea
JB		 2113 OMP_MAP_IF_PRESENT, true,
2114 allow_derived))
a6163563 2115 continue;
b4c3a85b
JJ		 2116 if ((mask & OMP_CLAUSE_NOGROUP)
2117 && !c->nogroup
2118 && gfc_match ("nogroup") == MATCH_YES)
2119 {
2120 c->nogroup = needs_space = true;
2121 continue;
2122 }
a61f6afb
TS		 2123 if ((mask & OMP_CLAUSE_NOHOST)
2124 && !c->nohost
2125 && gfc_match ("nohost") == MATCH_YES)
2126 {
2127 c->nohost = needs_space = true;
2128 continue;
2129 }
21cfe724
TB		 2130 if ((mask & OMP_CLAUSE_NOTEMPORAL)
2131 && gfc_match_omp_variable_list ("nontemporal (",
2132 &c->lists[OMP_LIST_NONTEMPORAL],
2133 true) == MATCH_YES)
2134 continue;
0f66751a
JJ		 2135 if ((mask & OMP_CLAUSE_NOTINBRANCH)
2136 && !c->notinbranch
2137 && !c->inbranch
2138 && gfc_match ("notinbranch") == MATCH_YES)
2139 {
2140 c->notinbranch = needs_space = true;
2141 continue;
2142 }
b4c3a85b
JJ		 2143 if ((mask & OMP_CLAUSE_NOWAIT)
2144 && !c->nowait
2145 && gfc_match ("nowait") == MATCH_YES)
2146 {
2147 c->nowait = needs_space = true;
2148 continue;
2149 }
0f66751a
JJ		 2150 if ((mask & OMP_CLAUSE_NUM_GANGS)
2151 && c->num_gangs_expr == NULL
2152 && gfc_match ("num_gangs ( %e )",
2153 &c->num_gangs_expr) == MATCH_YES)
2154 continue;
b4c3a85b
JJ		 2155 if ((mask & OMP_CLAUSE_NUM_TASKS)
2156 && c->num_tasks == NULL
d4de7e32
TB		 2157 && gfc_match ("num_tasks ( ") == MATCH_YES)
2158 {
2159 if (gfc_match ("strict : ") == MATCH_YES)
2160 c->num_tasks_strict = true;
2161 if (gfc_match (" %e )", &c->num_tasks) != MATCH_YES)
2162 goto error;
2163 continue;
2164 }
0f66751a
JJ		 2165 if ((mask & OMP_CLAUSE_NUM_TEAMS)
2166 && c->num_teams == NULL
2167 && gfc_match ("num_teams ( %e )", &c->num_teams) == MATCH_YES)
2168 continue;
2169 if ((mask & OMP_CLAUSE_NUM_THREADS)
2170 && c->num_threads == NULL
2171 && (gfc_match ("num_threads ( %e )", &c->num_threads)
2172 == MATCH_YES))
2173 continue;
2174 if ((mask & OMP_CLAUSE_NUM_WORKERS)
2175 && c->num_workers_expr == NULL
2176 && gfc_match ("num_workers ( %e )",
2177 &c->num_workers_expr) == MATCH_YES)
2178 continue;
2179 break;
2180 case 'o':
d8140b9e
TB		 2181 if ((mask & OMP_CLAUSE_ORDER)
2182 && !c->order_concurrent
2183 && gfc_match ("order ( concurrent )") == MATCH_YES)
2184 {
2185 c->order_concurrent = true;
2186 continue;
2187 }
0f66751a
JJ		 2188 if ((mask & OMP_CLAUSE_ORDERED)
2189 && !c->ordered
2190 && gfc_match ("ordered") == MATCH_YES)
2191 {
b4c3a85b
JJ		 2192 gfc_expr *cexpr = NULL;
2193 match m = gfc_match (" ( %e )", &cexpr);
2194
2195 c->ordered = true;
2196 if (m == MATCH_YES)
2197 {
2198 int ordered = 0;
51f03c6b
JJ		 2199 if (gfc_extract_int (cexpr, &ordered, -1))
2200 ordered = 0;
b4c3a85b
JJ		 2201 else if (ordered <= 0)
2202 {
2203 gfc_error_now ("ORDERED clause argument not"
2204 " constant positive integer at %C");
2205 ordered = 0;
2206 }
2207 c->orderedc = ordered;
2208 gfc_free_expr (cexpr);
2209 continue;
2210 }
2211
2212 needs_space = true;
0f66751a
JJ		 2213 continue;
2214 }
2215 break;
2216 case 'p':
829c6349 2217 if ((mask & OMP_CLAUSE_COPY)
0f66751a
JJ		 2218 && gfc_match ("pcopy ( ") == MATCH_YES
2219 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
549188ea 2220 OMP_MAP_TOFROM, true, allow_derived))
0f66751a 2221 continue;
829c6349 2222 if ((mask & OMP_CLAUSE_COPYIN)
0f66751a
JJ		 2223 && gfc_match ("pcopyin ( ") == MATCH_YES
2224 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
549188ea 2225 OMP_MAP_TO, true, allow_derived))
0f66751a 2226 continue;
829c6349 2227 if ((mask & OMP_CLAUSE_COPYOUT)
0f66751a
JJ		 2228 && gfc_match ("pcopyout ( ") == MATCH_YES
2229 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
549188ea 2230 OMP_MAP_FROM, true, allow_derived))
0f66751a 2231 continue;
829c6349 2232 if ((mask & OMP_CLAUSE_CREATE)
0f66751a
JJ		 2233 && gfc_match ("pcreate ( ") == MATCH_YES
2234 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
549188ea 2235 OMP_MAP_ALLOC, true, allow_derived))
0f66751a
JJ		 2236 continue;
2237 if ((mask & OMP_CLAUSE_PRESENT)
2238 && gfc_match ("present ( ") == MATCH_YES
2239 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
549188ea
JB		 2240 OMP_MAP_FORCE_PRESENT, false,
2241 allow_derived))
0f66751a 2242 continue;
829c6349 2243 if ((mask & OMP_CLAUSE_COPY)
0f66751a
JJ		 2244 && gfc_match ("present_or_copy ( ") == MATCH_YES
2245 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
549188ea
JB		 2246 OMP_MAP_TOFROM, true,
2247 allow_derived))
0f66751a 2248 continue;
829c6349 2249 if ((mask & OMP_CLAUSE_COPYIN)
0f66751a
JJ		 2250 && gfc_match ("present_or_copyin ( ") == MATCH_YES
2251 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
549188ea 2252 OMP_MAP_TO, true, allow_derived))
0f66751a 2253 continue;
829c6349 2254 if ((mask & OMP_CLAUSE_COPYOUT)
0f66751a
JJ		 2255 && gfc_match ("present_or_copyout ( ") == MATCH_YES
2256 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
549188ea 2257 OMP_MAP_FROM, true, allow_derived))
0f66751a 2258 continue;
829c6349 2259 if ((mask & OMP_CLAUSE_CREATE)
0f66751a
JJ		 2260 && gfc_match ("present_or_create ( ") == MATCH_YES
2261 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
549188ea 2262 OMP_MAP_ALLOC, true, allow_derived))
0f66751a 2263 continue;
b4c3a85b
JJ		 2264 if ((mask & OMP_CLAUSE_PRIORITY)
2265 && c->priority == NULL
2266 && gfc_match ("priority ( %e )", &c->priority) == MATCH_YES)
2267 continue;
0f66751a
JJ		 2268 if ((mask & OMP_CLAUSE_PRIVATE)
2269 && gfc_match_omp_variable_list ("private (",
2270 &c->lists[OMP_LIST_PRIVATE],
2271 true) == MATCH_YES)
2272 continue;
2273 if ((mask & OMP_CLAUSE_PROC_BIND)
2274 && c->proc_bind == OMP_PROC_BIND_UNKNOWN)
2275 {
432de084
TB		 2276 /* Primary is new and master is deprecated in OpenMP 5.1. */
2277 if (gfc_match ("proc_bind ( primary )") == MATCH_YES)
2278 c->proc_bind = OMP_PROC_BIND_MASTER;
2279 else if (gfc_match ("proc_bind ( master )") == MATCH_YES)
0f66751a
JJ		 2280 c->proc_bind = OMP_PROC_BIND_MASTER;
2281 else if (gfc_match ("proc_bind ( spread )") == MATCH_YES)
2282 c->proc_bind = OMP_PROC_BIND_SPREAD;
2283 else if (gfc_match ("proc_bind ( close )") == MATCH_YES)
2284 c->proc_bind = OMP_PROC_BIND_CLOSE;
2285 if (c->proc_bind != OMP_PROC_BIND_UNKNOWN)
2286 continue;
2287 }
2288 break;
2289 case 'r':
1fc5e7ef
TB		 2290 if ((mask & OMP_CLAUSE_ATOMIC)
2291 && c->atomic_op == GFC_OMP_ATOMIC_UNSET
2292 && gfc_match ("read") == MATCH_YES)
2293 {
2294 c->atomic_op = GFC_OMP_ATOMIC_READ;
2295 needs_space = true;
2296 continue;
2297 }
0f66751a 2298 if ((mask & OMP_CLAUSE_REDUCTION)
e929ef53
TB		 2299 && gfc_match_omp_clause_reduction (pc, c, openacc,
2300 allow_derived) == MATCH_YES)
2301 continue;
2302 if ((mask & OMP_CLAUSE_MEMORDER)
2303 && c->memorder == OMP_MEMORDER_UNSET
2304 && gfc_match ("relaxed") == MATCH_YES)
0f66751a 2305 {
e929ef53
TB		 2306 c->memorder = OMP_MEMORDER_RELAXED;
2307 needs_space = true;
2308 continue;
2309 }
2310 if ((mask & OMP_CLAUSE_MEMORDER)
2311 && c->memorder == OMP_MEMORDER_UNSET
2312 && gfc_match ("release") == MATCH_YES)
2313 {
2314 c->memorder = OMP_MEMORDER_RELEASE;
2315 needs_space = true;
2316 continue;
0f66751a 2317 }
1fc5e7ef
TB		 2318 if ((mask & OMP_CLAUSE_MEMORDER)
2319 && c->memorder == OMP_MEMORDER_UNSET
2320 && gfc_match ("relaxed") == MATCH_YES)
2321 {
2322 c->memorder = OMP_MEMORDER_RELAXED;
2323 needs_space = true;
2324 continue;
2325 }
2326 if ((mask & OMP_CLAUSE_MEMORDER)
2327 && c->memorder == OMP_MEMORDER_UNSET
2328 && gfc_match ("release") == MATCH_YES)
2329 {
2330 c->memorder = OMP_MEMORDER_RELEASE;
2331 needs_space = true;
2332 continue;
2333 }
0f66751a
JJ		 2334 break;
2335 case 's':
2336 if ((mask & OMP_CLAUSE_SAFELEN)
2337 && c->safelen_expr == NULL
2338 && gfc_match ("safelen ( %e )", &c->safelen_expr) == MATCH_YES)
2339 continue;
2340 if ((mask & OMP_CLAUSE_SCHEDULE)
2341 && c->sched_kind == OMP_SCHED_NONE
2342 && gfc_match ("schedule ( ") == MATCH_YES)
dd2fc525 2343 {
b4c3a85b
JJ		 2344 int nmodifiers = 0;
2345 locus old_loc2 = gfc_current_locus;
2346 do
2347 {
37bc33f7 2348 if (gfc_match ("simd") == MATCH_YES)
b4c3a85b
JJ		 2349 {
2350 c->sched_simd = true;
2351 nmodifiers++;
2352 }
37bc33f7 2353 else if (gfc_match ("monotonic") == MATCH_YES)
b4c3a85b
JJ		 2354 {
2355 c->sched_monotonic = true;
2356 nmodifiers++;
2357 }
37bc33f7 2358 else if (gfc_match ("nonmonotonic") == MATCH_YES)
b4c3a85b
JJ		 2359 {
2360 c->sched_nonmonotonic = true;
2361 nmodifiers++;
2362 }
2363 else
2364 {
2365 if (nmodifiers)
2366 gfc_current_locus = old_loc2;
2367 break;
2368 }
37bc33f7 2369 if (nmodifiers == 1
b4c3a85b
JJ		 2370 && gfc_match (" , ") == MATCH_YES)
2371 continue;
2372 else if (gfc_match (" : ") == MATCH_YES)
2373 break;
2374 gfc_current_locus = old_loc2;
2375 break;
2376 }
2377 while (1);
0f66751a
JJ		 2378 if (gfc_match ("static") == MATCH_YES)
2379 c->sched_kind = OMP_SCHED_STATIC;
2380 else if (gfc_match ("dynamic") == MATCH_YES)
2381 c->sched_kind = OMP_SCHED_DYNAMIC;
2382 else if (gfc_match ("guided") == MATCH_YES)
2383 c->sched_kind = OMP_SCHED_GUIDED;
2384 else if (gfc_match ("runtime") == MATCH_YES)
2385 c->sched_kind = OMP_SCHED_RUNTIME;
2386 else if (gfc_match ("auto") == MATCH_YES)
2387 c->sched_kind = OMP_SCHED_AUTO;
2388 if (c->sched_kind != OMP_SCHED_NONE)
2389 {
2390 match m = MATCH_NO;
2391 if (c->sched_kind != OMP_SCHED_RUNTIME
2392 && c->sched_kind != OMP_SCHED_AUTO)
2393 m = gfc_match (" , %e )", &c->chunk_size);
2394 if (m != MATCH_YES)
2395 m = gfc_match_char (')');
2396 if (m != MATCH_YES)
2397 c->sched_kind = OMP_SCHED_NONE;
2398 }
2399 if (c->sched_kind != OMP_SCHED_NONE)
2400 continue;
2401 else
2402 gfc_current_locus = old_loc;
dd2fc525 2403 }
0f66751a
JJ		 2404 if ((mask & OMP_CLAUSE_HOST_SELF)
2405 && gfc_match ("self ( ") == MATCH_YES
2406 && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
549188ea
JB		 2407 OMP_MAP_FORCE_FROM, true,
2408 allow_derived))
0f66751a
JJ		 2409 continue;
2410 if ((mask & OMP_CLAUSE_SEQ)
2411 && !c->seq
2412 && gfc_match ("seq") == MATCH_YES)
dd2fc525 2413 {
0f66751a
JJ		 2414 c->seq = true;
2415 needs_space = true;
2416 continue;
dd2fc525 2417 }
1fc5e7ef
TB		 2418 if ((mask & OMP_CLAUSE_MEMORDER)
2419 && c->memorder == OMP_MEMORDER_UNSET
2420 && gfc_match ("seq_cst") == MATCH_YES)
2421 {
2422 c->memorder = OMP_MEMORDER_SEQ_CST;
2423 needs_space = true;
2424 continue;
2425 }
0f66751a
JJ		 2426 if ((mask & OMP_CLAUSE_SHARED)
2427 && gfc_match_omp_variable_list ("shared (",
2428 &c->lists[OMP_LIST_SHARED],
2429 true) == MATCH_YES)
2430 continue;
2431 if ((mask & OMP_CLAUSE_SIMDLEN)
2432 && c->simdlen_expr == NULL
2433 && gfc_match ("simdlen ( %e )", &c->simdlen_expr) == MATCH_YES)
2434 continue;
b4c3a85b
JJ		 2435 if ((mask & OMP_CLAUSE_SIMD)
2436 && !c->simd
2437 && gfc_match ("simd") == MATCH_YES)
2438 {
2439 c->simd = needs_space = true;
2440 continue;
2441 }
77167196
TB		 2442 if ((mask & OMP_CLAUSE_SEVERITY)
2443 && c->severity == OMP_SEVERITY_UNSET
2444 && gfc_match ("severity ( ") == MATCH_YES)
2445 {
2446 if (gfc_match ("fatal )") == MATCH_YES)
2447 c->severity = OMP_SEVERITY_FATAL;
2448 else if (gfc_match ("warning )") == MATCH_YES)
2449 c->severity = OMP_SEVERITY_WARNING;
2450 else
2451 {
2452 gfc_error ("Expected FATAL or WARNING in SEVERITY clause "
2453 "at %C");
2454 goto error;
2455 }
2456 continue;
2457 }
0f66751a
JJ		 2458 break;
2459 case 't':
e929ef53
TB		 2460 if ((mask & OMP_CLAUSE_TASK_REDUCTION)
2461 && gfc_match_omp_clause_reduction (pc, c, openacc,
2462 allow_derived) == MATCH_YES)
2463 continue;
0f66751a
JJ		 2464 if ((mask & OMP_CLAUSE_THREAD_LIMIT)
2465 && c->thread_limit == NULL
2466 && gfc_match ("thread_limit ( %e )",
2467 &c->thread_limit) == MATCH_YES)
2468 continue;
b4c3a85b
JJ		 2469 if ((mask & OMP_CLAUSE_THREADS)
2470 && !c->threads
2471 && gfc_match ("threads") == MATCH_YES)
2472 {
2473 c->threads = needs_space = true;
2474 continue;
2475 }
0f66751a
JJ		 2476 if ((mask & OMP_CLAUSE_TILE)
2477 && !c->tile_list
2478 && match_oacc_expr_list ("tile (", &c->tile_list,
2479 true) == MATCH_YES)
2480 continue;
b4c3a85b
JJ		 2481 if ((mask & OMP_CLAUSE_TO) && (mask & OMP_CLAUSE_LINK))
2482 {
2483 if (gfc_match_omp_to_link ("to (", &c->lists[OMP_LIST_TO])
2484 == MATCH_YES)
2485 continue;
2486 }
2487 else if ((mask & OMP_CLAUSE_TO)
0f66751a
JJ		 2488 && gfc_match_omp_variable_list ("to (",
2489 &c->lists[OMP_LIST_TO], false,
2490 NULL, &head, true) == MATCH_YES)
2491 continue;
2492 break;
2493 case 'u':
2494 if ((mask & OMP_CLAUSE_UNIFORM)
2495 && gfc_match_omp_variable_list ("uniform (",
2496 &c->lists[OMP_LIST_UNIFORM],
2497 false) == MATCH_YES)
2498 continue;
2499 if ((mask & OMP_CLAUSE_UNTIED)
2500 && !c->untied
2501 && gfc_match ("untied") == MATCH_YES)
f014c653 2502 {
0f66751a 2503 c->untied = needs_space = true;
f014c653
JJ		 2504 continue;
2505 }
1fc5e7ef
TB		 2506 if ((mask & OMP_CLAUSE_ATOMIC)
2507 && c->atomic_op == GFC_OMP_ATOMIC_UNSET
2508 && gfc_match ("update") == MATCH_YES)
2509 {
2510 c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
2511 needs_space = true;
2512 continue;
2513 }
0f66751a
JJ		 2514 if ((mask & OMP_CLAUSE_USE_DEVICE)
2515 && gfc_match_omp_variable_list ("use_device (",
2516 &c->lists[OMP_LIST_USE_DEVICE],
2517 true) == MATCH_YES)
2518 continue;
b4c3a85b
JJ		 2519 if ((mask & OMP_CLAUSE_USE_DEVICE_PTR)
2520 && gfc_match_omp_variable_list
2521 ("use_device_ptr (",
2522 &c->lists[OMP_LIST_USE_DEVICE_PTR], false) == MATCH_YES)
2523 continue;
ef4add8e
TB		 2524 if ((mask & OMP_CLAUSE_USE_DEVICE_ADDR)
2525 && gfc_match_omp_variable_list
2526 ("use_device_addr (",
2527 &c->lists[OMP_LIST_USE_DEVICE_ADDR], false) == MATCH_YES)
2528 continue;
0f66751a
JJ		 2529 break;
2530 case 'v':
f7ba880b
CP		 2531 /* VECTOR_LENGTH must be matched before VECTOR, because the latter
2532 doesn't unconditionally match '('. */
2533 if ((mask & OMP_CLAUSE_VECTOR_LENGTH)
2534 && c->vector_length_expr == NULL
2535 && (gfc_match ("vector_length ( %e )", &c->vector_length_expr)
2536 == MATCH_YES))
2537 continue;
0f66751a
JJ		 2538 if ((mask & OMP_CLAUSE_VECTOR)
2539 && !c->vector
2540 && gfc_match ("vector") == MATCH_YES)
f014c653 2541 {
0f66751a 2542 c->vector = true;
27f67461
CP		 2543 match m = match_oacc_clause_gwv (c, GOMP_DIM_VECTOR);
2544 if (m == MATCH_ERROR)
2545 {
2546 gfc_current_locus = old_loc;
2547 break;
2548 }
2549 if (m == MATCH_NO)
0f66751a
JJ		 2550 needs_space = true;
2551 continue;
f014c653 2552 }
0f66751a
JJ		 2553 break;
2554 case 'w':
2555 if ((mask & OMP_CLAUSE_WAIT)
0f66751a 2556 && gfc_match ("wait") == MATCH_YES)
f014c653 2557 {
27f67461
CP		 2558 match m = match_oacc_expr_list (" (", &c->wait_list, false);
2559 if (m == MATCH_ERROR)
2560 {
2561 gfc_current_locus = old_loc;
2562 break;
2563 }
2564 else if (m == MATCH_NO)
19695f4d
CLT		 2565 {
2566 gfc_expr *expr
2567 = gfc_get_constant_expr (BT_INTEGER,
2568 gfc_default_integer_kind,
2569 &gfc_current_locus);
2570 mpz_set_si (expr->value.integer, GOMP_ASYNC_NOVAL);
2571 gfc_expr_list **expr_list = &c->wait_list;
2572 while (*expr_list)
2573 expr_list = &(*expr_list)->next;
2574 *expr_list = gfc_get_expr_list ();
2575 (*expr_list)->expr = expr;
2576 needs_space = true;
2577 }
f014c653
JJ		 2578 continue;
2579 }
0f66751a
JJ		 2580 if ((mask & OMP_CLAUSE_WORKER)
2581 && !c->worker
2582 && gfc_match ("worker") == MATCH_YES)
2583 {
2584 c->worker = true;
27f67461
CP		 2585 match m = match_oacc_clause_gwv (c, GOMP_DIM_WORKER);
2586 if (m == MATCH_ERROR)
2587 {
2588 gfc_current_locus = old_loc;
2589 break;
2590 }
2591 else if (m == MATCH_NO)
0f66751a
JJ		 2592 needs_space = true;
2593 continue;
2594 }
1fc5e7ef
TB		 2595 if ((mask & OMP_CLAUSE_ATOMIC)
2596 && c->atomic_op == GFC_OMP_ATOMIC_UNSET
2597 && gfc_match ("write") == MATCH_YES)
2598 {
2599 c->atomic_op = GFC_OMP_ATOMIC_WRITE;
2600 needs_space = true;
2601 continue;
2602 }
0f66751a 2603 break;
f014c653 2604 }
6c7a4dfd
JJ		 2605 break;
2606 }
2607
1de31913 2608end:
77167196 2609 if (error || gfc_match_omp_eos () != MATCH_YES)
6c7a4dfd 2610 {
ba045eb2
TB		 2611 if (!gfc_error_flag_test ())
2612 gfc_error ("Failed to match clause at %C");
6c7a4dfd
JJ		 2613 gfc_free_omp_clauses (c);
2614 return MATCH_ERROR;
2615 }
2616
2617 *cp = c;
2618 return MATCH_YES;
77167196
TB		 2619
2620error:
2621 error = true;
2622 goto end;
6c7a4dfd
JJ		 2623}
2624
41dbbb37
TS		 2625
2626#define OACC_PARALLEL_CLAUSES \
b4c3a85b 2627 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
41dbbb37 2628 | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_REDUCTION \
b4c3a85b 2629 | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
a6163563
JB		 2630 | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
2631 | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
549188ea 2632 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH)
41dbbb37 2633#define OACC_KERNELS_CLAUSES \
fd71a9a2
TS		 2634 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
2635 | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_DEVICEPTR \
b4c3a85b 2636 | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
a6163563 2637 | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
549188ea 2638 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH)
62aee289
MR		 2639#define OACC_SERIAL_CLAUSES \
2640 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_REDUCTION \
2641 | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
a6163563
JB		 2642 | OMP_CLAUSE_CREATE | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT \
2643 | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
549188ea 2644 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT | OMP_CLAUSE_ATTACH)
41dbbb37 2645#define OACC_DATA_CLAUSES \
b4c3a85b
JJ		 2646 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_COPY \
2647 | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_CREATE \
549188ea 2648 | OMP_CLAUSE_NO_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_ATTACH)
41dbbb37 2649#define OACC_LOOP_CLAUSES \
b4c3a85b
JJ		 2650 (omp_mask (OMP_CLAUSE_COLLAPSE) | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER \
2651 | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ | OMP_CLAUSE_INDEPENDENT \
2652 | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_AUTO \
41dbbb37
TS		 2653 | OMP_CLAUSE_TILE)
2654#define OACC_PARALLEL_LOOP_CLAUSES \
2655 (OACC_LOOP_CLAUSES | OACC_PARALLEL_CLAUSES)
2656#define OACC_KERNELS_LOOP_CLAUSES \
2657 (OACC_LOOP_CLAUSES | OACC_KERNELS_CLAUSES)
62aee289
MR		 2658#define OACC_SERIAL_LOOP_CLAUSES \
2659 (OACC_LOOP_CLAUSES | OACC_SERIAL_CLAUSES)
d5c23c6c
TB		 2660#define OACC_HOST_DATA_CLAUSES \
2661 (omp_mask (OMP_CLAUSE_USE_DEVICE) \
2662 | OMP_CLAUSE_IF \
2663 | OMP_CLAUSE_IF_PRESENT)
41dbbb37 2664#define OACC_DECLARE_CLAUSES \
b4c3a85b 2665 (omp_mask (OMP_CLAUSE_COPY) | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
41dbbb37 2666 | OMP_CLAUSE_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_DEVICE_RESIDENT \
829c6349
CLT		 2667 | OMP_CLAUSE_PRESENT \
2668 | OMP_CLAUSE_LINK)
41dbbb37 2669#define OACC_UPDATE_CLAUSES \
b4c3a85b 2670 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_HOST_SELF \
829c6349 2671 | OMP_CLAUSE_DEVICE | OMP_CLAUSE_WAIT | OMP_CLAUSE_IF_PRESENT)
41dbbb37 2672#define OACC_ENTER_DATA_CLAUSES \
b4c3a85b 2673 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
549188ea 2674 | OMP_CLAUSE_COPYIN | OMP_CLAUSE_CREATE | OMP_CLAUSE_ATTACH)
41dbbb37 2675#define OACC_EXIT_DATA_CLAUSES \
b4c3a85b 2676 (omp_mask (OMP_CLAUSE_IF) | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT \
549188ea
JB		 2677 | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_DELETE | OMP_CLAUSE_FINALIZE \
2678 | OMP_CLAUSE_DETACH)
41dbbb37 2679#define OACC_WAIT_CLAUSES \
b4c3a85b 2680 omp_mask (OMP_CLAUSE_ASYNC)
db941d7e 2681#define OACC_ROUTINE_CLAUSES \
b4c3a85b 2682 (omp_mask (OMP_CLAUSE_GANG) | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR \
a61f6afb
TS		 2683 | OMP_CLAUSE_SEQ \
2684 | OMP_CLAUSE_NOHOST)
41dbbb37
TS		 2685
2686
8559b90f 2687static match
b4c3a85b 2688match_acc (gfc_exec_op op, const omp_mask mask)
41dbbb37
TS		 2689{
2690 gfc_omp_clauses *c;
8559b90f 2691 if (gfc_match_omp_clauses (&c, mask, false, false, true) != MATCH_YES)
41dbbb37 2692 return MATCH_ERROR;
8559b90f 2693 new_st.op = op;
41dbbb37
TS		 2694 new_st.ext.omp_clauses = c;
2695 return MATCH_YES;
2696}
2697
8559b90f
CP		 2698match
2699gfc_match_oacc_parallel_loop (void)
2700{
2701 return match_acc (EXEC_OACC_PARALLEL_LOOP, OACC_PARALLEL_LOOP_CLAUSES);
2702}
2703
41dbbb37
TS		 2704
2705match
2706gfc_match_oacc_parallel (void)
2707{
8559b90f 2708 return match_acc (EXEC_OACC_PARALLEL, OACC_PARALLEL_CLAUSES);
41dbbb37
TS		 2709}
2710
2711
2712match
2713gfc_match_oacc_kernels_loop (void)
2714{
8559b90f 2715 return match_acc (EXEC_OACC_KERNELS_LOOP, OACC_KERNELS_LOOP_CLAUSES);
41dbbb37
TS		 2716}
2717
2718
2719match
2720gfc_match_oacc_kernels (void)
2721{
8559b90f 2722 return match_acc (EXEC_OACC_KERNELS, OACC_KERNELS_CLAUSES);
41dbbb37
TS		 2723}
2724
2725
62aee289
MR		 2726match
2727gfc_match_oacc_serial_loop (void)
2728{
2729 return match_acc (EXEC_OACC_SERIAL_LOOP, OACC_SERIAL_LOOP_CLAUSES);
2730}
2731
2732
2733match
2734gfc_match_oacc_serial (void)
2735{
2736 return match_acc (EXEC_OACC_SERIAL, OACC_SERIAL_CLAUSES);
2737}
2738
2739
41dbbb37
TS		 2740match
2741gfc_match_oacc_data (void)
2742{
8559b90f 2743 return match_acc (EXEC_OACC_DATA, OACC_DATA_CLAUSES);
41dbbb37
TS		 2744}
2745
2746
2747match
2748gfc_match_oacc_host_data (void)
2749{
8559b90f 2750 return match_acc (EXEC_OACC_HOST_DATA, OACC_HOST_DATA_CLAUSES);
41dbbb37
TS		 2751}
2752
2753
2754match
2755gfc_match_oacc_loop (void)
2756{
8559b90f 2757 return match_acc (EXEC_OACC_LOOP, OACC_LOOP_CLAUSES);
41dbbb37
TS		 2758}
2759
2760
2761match
2762gfc_match_oacc_declare (void)
2763{
2764 gfc_omp_clauses *c;
dc7a8b4b
JN		 2765 gfc_omp_namelist *n;
2766 gfc_namespace *ns = gfc_current_ns;
2767 gfc_oacc_declare *new_oc;
2768 bool module_var = false;
2769 locus where = gfc_current_locus;
2770
41dbbb37
TS		 2771 if (gfc_match_omp_clauses (&c, OACC_DECLARE_CLAUSES, false, false, true)
2772 != MATCH_YES)
2773 return MATCH_ERROR;
2774
dc7a8b4b
JN		 2775 for (n = c->lists[OMP_LIST_DEVICE_RESIDENT]; n != NULL; n = n->next)
2776 n->sym->attr.oacc_declare_device_resident = 1;
2777
2778 for (n = c->lists[OMP_LIST_LINK]; n != NULL; n = n->next)
2779 n->sym->attr.oacc_declare_link = 1;
2780
2781 for (n = c->lists[OMP_LIST_MAP]; n != NULL; n = n->next)
2782 {
2783 gfc_symbol *s = n->sym;
2784
98aeb1ef
TB		 2785 if (gfc_current_ns->proc_name
2786 && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
dc7a8b4b 2787 {
829c6349 2788 if (n->u.map_op != OMP_MAP_ALLOC && n->u.map_op != OMP_MAP_TO)
dc7a8b4b 2789 {
e711928b 2790 gfc_error ("Invalid clause in module with !$ACC DECLARE at %L",
dc7a8b4b
JN		 2791 &where);
2792 return MATCH_ERROR;
2793 }
2794
2795 module_var = true;
2796 }
2797
2798 if (s->attr.use_assoc)
2799 {
e711928b 2800 gfc_error ("Variable is USE-associated with !$ACC DECLARE at %L",
dc7a8b4b
JN		 2801 &where);
2802 return MATCH_ERROR;
2803 }
2804
98aeb1ef
TB		 2805 if ((s->result == s && s->ns->contained != gfc_current_ns)
2806 || ((s->attr.flavor == FL_UNKNOWN || s->attr.flavor == FL_VARIABLE)
2807 && s->ns != gfc_current_ns))
2808 {
2809 gfc_error ("Variable %qs shall be declared in the same scoping unit "
2810 "as !$ACC DECLARE at %L", s->name, &where);
2811 return MATCH_ERROR;
2812 }
2813
dc7a8b4b
JN		 2814 if ((s->attr.dimension || s->attr.codimension)
2815 && s->attr.dummy && s->as->type != AS_EXPLICIT)
2816 {
e711928b 2817 gfc_error ("Assumed-size dummy array with !$ACC DECLARE at %L",
dc7a8b4b
JN		 2818 &where);
2819 return MATCH_ERROR;
2820 }
2821
2822 switch (n->u.map_op)
2823 {
2824 case OMP_MAP_FORCE_ALLOC:
829c6349 2825 case OMP_MAP_ALLOC:
dc7a8b4b
JN		 2826 s->attr.oacc_declare_create = 1;
2827 break;
2828
2829 case OMP_MAP_FORCE_TO:
829c6349 2830 case OMP_MAP_TO:
dc7a8b4b
JN		 2831 s->attr.oacc_declare_copyin = 1;
2832 break;
2833
2834 case OMP_MAP_FORCE_DEVICEPTR:
2835 s->attr.oacc_declare_deviceptr = 1;
2836 break;
2837
2838 default:
2839 break;
2840 }
2841 }
2842
2843 new_oc = gfc_get_oacc_declare ();
2844 new_oc->next = ns->oacc_declare;
2845 new_oc->module_var = module_var;
2846 new_oc->clauses = c;
2847 new_oc->loc = gfc_current_locus;
2848 ns->oacc_declare = new_oc;
2849
41dbbb37
TS		 2850 return MATCH_YES;
2851}
2852
2853
2854match
2855gfc_match_oacc_update (void)
2856{
2857 gfc_omp_clauses *c;
7a5e4956
CP		 2858 locus here = gfc_current_locus;
2859
41dbbb37
TS		 2860 if (gfc_match_omp_clauses (&c, OACC_UPDATE_CLAUSES, false, false, true)
2861 != MATCH_YES)
2862 return MATCH_ERROR;
2863
7a5e4956
CP		 2864 if (!c->lists[OMP_LIST_MAP])
2865 {
2866 gfc_error ("%<acc update%> must contain at least one "
2867 "%<device%> or %<host%> or %<self%> clause at %L", &here);
2868 return MATCH_ERROR;
2869 }
2870
41dbbb37
TS		 2871 new_st.op = EXEC_OACC_UPDATE;
2872 new_st.ext.omp_clauses = c;
2873 return MATCH_YES;
2874}
2875
2876
2877match
2878gfc_match_oacc_enter_data (void)
2879{
8559b90f 2880 return match_acc (EXEC_OACC_ENTER_DATA, OACC_ENTER_DATA_CLAUSES);
41dbbb37
TS		 2881}
2882
2883
2884match
2885gfc_match_oacc_exit_data (void)
2886{
8559b90f 2887 return match_acc (EXEC_OACC_EXIT_DATA, OACC_EXIT_DATA_CLAUSES);
41dbbb37
TS		 2888}
2889
2890
2891match
2892gfc_match_oacc_wait (void)
2893{
2894 gfc_omp_clauses *c = gfc_get_omp_clauses ();
2895 gfc_expr_list *wait_list = NULL, *el;
27f67461
CP		 2896 bool space = true;
2897 match m;
41dbbb37 2898
27f67461
CP		 2899 m = match_oacc_expr_list (" (", &wait_list, true);
2900 if (m == MATCH_ERROR)
2901 return m;
2902 else if (m == MATCH_YES)
2903 space = false;
41dbbb37 2904
27f67461
CP		 2905 if (gfc_match_omp_clauses (&c, OACC_WAIT_CLAUSES, space, space, true)
2906 == MATCH_ERROR)
2907 return MATCH_ERROR;
41dbbb37
TS		 2908
2909 if (wait_list)
2910 for (el = wait_list; el; el = el->next)
2911 {
2912 if (el->expr == NULL)
2913 {
adc41ebe 2914 gfc_error ("Invalid argument to !$ACC WAIT at %C");
41dbbb37
TS		 2915 return MATCH_ERROR;
2916 }
2917
2918 if (!gfc_resolve_expr (el->expr)
a0e27dc2 2919 || el->expr->ts.type != BT_INTEGER || el->expr->rank != 0)
41dbbb37
TS		 2920 {
2921 gfc_error ("WAIT clause at %L requires a scalar INTEGER expression",
2922 &el->expr->where);
2923
2924 return MATCH_ERROR;
2925 }
2926 }
2927 c->wait_list = wait_list;
2928 new_st.op = EXEC_OACC_WAIT;
2929 new_st.ext.omp_clauses = c;
2930 return MATCH_YES;
2931}
2932
2933
2934match
2935gfc_match_oacc_cache (void)
2936{
2937 gfc_omp_clauses *c = gfc_get_omp_clauses ();
4b1ffdb1
TS		 2938 /* The OpenACC cache directive explicitly only allows "array elements or
2939 subarrays", which we're currently not checking here. Either check this
2940 after the call of gfc_match_omp_variable_list, or add something like a
2941 only_sections variant next to its allow_sections parameter. */
41dbbb37 2942 match m = gfc_match_omp_variable_list (" (",
33497fd2
TS		 2943 &c->lists[OMP_LIST_CACHE], true,
2944 NULL, NULL, true);
41dbbb37
TS		 2945 if (m != MATCH_YES)
2946 {
2947 gfc_free_omp_clauses(c);
2948 return m;
2949 }
2950
2951 if (gfc_current_state() != COMP_DO
2952 && gfc_current_state() != COMP_DO_CONCURRENT)
2953 {
2954 gfc_error ("ACC CACHE directive must be inside of loop %C");
2955 gfc_free_omp_clauses(c);
2956 return MATCH_ERROR;
2957 }
2958
2959 new_st.op = EXEC_OACC_CACHE;
2960 new_st.ext.omp_clauses = c;
2961 return MATCH_YES;
2962}
2963
68034b1b 2964/* Determine the OpenACC 'routine' directive's level of parallelism. */
db941d7e 2965
68034b1b
TS		 2966static oacc_routine_lop
2967gfc_oacc_routine_lop (gfc_omp_clauses *clauses)
db941d7e 2968{
68034b1b 2969 oacc_routine_lop ret = OACC_ROUTINE_LOP_SEQ;
db941d7e
CP		 2970
2971 if (clauses)
2972 {
68034b1b 2973 unsigned n_lop_clauses = 0;
db941d7e
CP		 2974
2975 if (clauses->gang)
68034b1b
TS		 2976 {
2977 ++n_lop_clauses;
2978 ret = OACC_ROUTINE_LOP_GANG;
2979 }
db941d7e 2980 if (clauses->worker)
68034b1b
TS		 2981 {
2982 ++n_lop_clauses;
2983 ret = OACC_ROUTINE_LOP_WORKER;
2984 }
db941d7e 2985 if (clauses->vector)
68034b1b
TS		 2986 {
2987 ++n_lop_clauses;
2988 ret = OACC_ROUTINE_LOP_VECTOR;
2989 }
db941d7e 2990 if (clauses->seq)
68034b1b
TS		 2991 {
2992 ++n_lop_clauses;
2993 ret = OACC_ROUTINE_LOP_SEQ;
2994 }
db941d7e 2995
68034b1b 2996 if (n_lop_clauses > 1)
e5fd6684 2997 ret = OACC_ROUTINE_LOP_ERROR;
db941d7e
CP		 2998 }
2999
68034b1b 3000 return ret;
db941d7e 3001}
41dbbb37
TS		 3002
3003match
3004gfc_match_oacc_routine (void)
3005{
3006 locus old_loc;
41dbbb37 3007 match m;
6f87db2d
TS		 3008 gfc_intrinsic_sym *isym = NULL;
3009 gfc_symbol *sym = NULL;
db941d7e
CP		 3010 gfc_omp_clauses *c = NULL;
3011 gfc_oacc_routine_name *n = NULL;
e5fd6684 3012 oacc_routine_lop lop = OACC_ROUTINE_LOP_NONE;
a61f6afb 3013 bool nohost;
41dbbb37
TS		 3014
3015 old_loc = gfc_current_locus;
3016
3017 m = gfc_match (" (");
3018
3019 if (gfc_current_ns->proc_name
3020 && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
3021 && m == MATCH_YES)
3022 {
3023 gfc_error ("Only the !$ACC ROUTINE form without "
3024 "list is allowed in interface block at %C");
3025 goto cleanup;
3026 }
3027
db941d7e 3028 if (m == MATCH_YES)
41dbbb37 3029 {
db941d7e 3030 char buffer[GFC_MAX_SYMBOL_LEN + 1];
41dbbb37 3031
db941d7e
CP		 3032 m = gfc_match_name (buffer);
3033 if (m == MATCH_YES)
3034 {
6f87db2d
TS		 3035 gfc_symtree *st = NULL;
3036
3037 /* First look for an intrinsic symbol. */
3038 isym = gfc_find_function (buffer);
3039 if (!isym)
3040 isym = gfc_find_subroutine (buffer);
3041 /* If no intrinsic symbol found, search the current namespace. */
3042 if (!isym)
3043 st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);
db941d7e
CP		 3044 if (st)
3045 {
3046 sym = st->n.sym;
8ced98c6
TS		 3047 /* If the name in a 'routine' directive refers to the containing
3048 subroutine or function, then make sure that we'll later handle
3049 this accordingly. */
74582a3e
CP		 3050 if (gfc_current_ns->proc_name != NULL
3051 && strcmp (sym->name, gfc_current_ns->proc_name->name) == 0)
db941d7e
CP		 3052 sym = NULL;
3053 }
41dbbb37 3054
f6bf4bc1 3055 if (isym == NULL && st == NULL)
db941d7e 3056 {
f6bf4bc1
TS		 3057 gfc_error ("Invalid NAME %qs in !$ACC ROUTINE ( NAME ) at %C",
3058 buffer);
db941d7e
CP		 3059 gfc_current_locus = old_loc;
3060 return MATCH_ERROR;
3061 }
3062 }
3063 else
3064 {
3065 gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C");
3066 gfc_current_locus = old_loc;
3067 return MATCH_ERROR;
3068 }
41dbbb37 3069
db941d7e
CP		 3070 if (gfc_match_char (')') != MATCH_YES)
3071 {
3072 gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting"
3073 " ')' after NAME");
3074 gfc_current_locus = old_loc;
3075 return MATCH_ERROR;
3076 }
41dbbb37
TS		 3077 }
3078
db941d7e
CP		 3079 if (gfc_match_omp_eos () != MATCH_YES
3080 && (gfc_match_omp_clauses (&c, OACC_ROUTINE_CLAUSES, false, false, true)
3081 != MATCH_YES))
3082 return MATCH_ERROR;
41dbbb37 3083
e5fd6684
TS		 3084 lop = gfc_oacc_routine_lop (c);
3085 if (lop == OACC_ROUTINE_LOP_ERROR)
3086 {
3087 gfc_error ("Multiple loop axes specified for routine at %C");
3088 goto cleanup;
3089 }
a61f6afb 3090 nohost = c ? c->nohost : false;
e5fd6684 3091
6f87db2d
TS		 3092 if (isym != NULL)
3093 {
3094 /* Diagnose any OpenACC 'routine' directive that doesn't match the
3095 (implicit) one with a 'seq' clause. */
3096 if (c && (c->gang || c->worker || c->vector))
3097 {
3098 gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )"
3099 " at %C marked with incompatible GANG, WORKER, or VECTOR"
3100 " clause");
3101 goto cleanup;
3102 }
a61f6afb
TS		 3103 /* ..., and no 'nohost' clause. */
3104 if (nohost)
3105 {
3106 gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME )"
3107 " at %C marked with incompatible NOHOST clause");
3108 goto cleanup;
3109 }
6f87db2d
TS		 3110 }
3111 else if (sym != NULL)
41dbbb37 3112 {
80d6ca01
TS		 3113 bool add = true;
3114
3115 /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
3116 match the first one. */
3117 for (gfc_oacc_routine_name *n_p = gfc_current_ns->oacc_routine_names;
3118 n_p;
3119 n_p = n_p->next)
3120 if (n_p->sym == sym)
3121 {
3122 add = false;
a61f6afb
TS		 3123 bool nohost_p = n_p->clauses ? n_p->clauses->nohost : false;
3124 if (lop != gfc_oacc_routine_lop (n_p->clauses)
3125 || nohost != nohost_p)
80d6ca01
TS		 3126 {
3127 gfc_error ("!$ACC ROUTINE already applied at %C");
3128 goto cleanup;
3129 }
3130 }
3131
3132 if (add)
3133 {
2e4182ae 3134 sym->attr.oacc_routine_lop = lop;
a61f6afb 3135 sym->attr.oacc_routine_nohost = nohost;
2e4182ae 3136
80d6ca01
TS		 3137 n = gfc_get_oacc_routine_name ();
3138 n->sym = sym;
3139 n->clauses = c;
3140 n->next = gfc_current_ns->oacc_routine_names;
f6bf4bc1 3141 n->loc = old_loc;
80d6ca01
TS		 3142 gfc_current_ns->oacc_routine_names = n;
3143 }
41dbbb37 3144 }
db941d7e 3145 else if (gfc_current_ns->proc_name)
41dbbb37 3146 {
80d6ca01
TS		 3147 /* For a repeated OpenACC 'routine' directive, diagnose if it doesn't
3148 match the first one. */
3149 oacc_routine_lop lop_p = gfc_current_ns->proc_name->attr.oacc_routine_lop;
a61f6afb 3150 bool nohost_p = gfc_current_ns->proc_name->attr.oacc_routine_nohost;
80d6ca01 3151 if (lop_p != OACC_ROUTINE_LOP_NONE
a61f6afb
TS		 3152 && (lop != lop_p
3153 || nohost != nohost_p))
80d6ca01
TS		 3154 {
3155 gfc_error ("!$ACC ROUTINE already applied at %C");
3156 goto cleanup;
3157 }
3158
db941d7e
CP		 3159 if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
3160 gfc_current_ns->proc_name->name,
3161 &old_loc))
3162 goto cleanup;
e5fd6684 3163 gfc_current_ns->proc_name->attr.oacc_routine_lop = lop;
a61f6afb 3164 gfc_current_ns->proc_name->attr.oacc_routine_nohost = nohost;
41dbbb37 3165 }
6f87db2d
TS		 3166 else
3167 /* Something has gone wrong, possibly a syntax error. */
3168 goto cleanup;
db941d7e 3169
12df77ab
TB		 3170 if (gfc_pure (NULL) && c && (c->gang || c->worker || c->vector))
3171 {
3172 gfc_error ("!$ACC ROUTINE with GANG, WORKER, or VECTOR clause is not "
3173 "permitted in PURE procedure at %C");
3174 goto cleanup;
3175 }
3176
3177
db941d7e
CP		 3178 if (n)
3179 n->clauses = c;
3180 else if (gfc_current_ns->oacc_routine)
3181 gfc_current_ns->oacc_routine_clauses = c;
3182
3183 new_st.op = EXEC_OACC_ROUTINE;
3184 new_st.ext.omp_clauses = c;
3185 return MATCH_YES;
41dbbb37
TS		 3186
3187cleanup:
3188 gfc_current_locus = old_loc;
3189 return MATCH_ERROR;
3190}
3191
3192
6c7a4dfd 3193#define OMP_PARALLEL_CLAUSES \
b4c3a85b
JJ		 3194 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
3195 | OMP_CLAUSE_SHARED | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION \
3196 | OMP_CLAUSE_IF | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT \
3197 | OMP_CLAUSE_PROC_BIND)
dd2fc525 3198#define OMP_DECLARE_SIMD_CLAUSES \
b4c3a85b
JJ		 3199 (omp_mask (OMP_CLAUSE_SIMDLEN) | OMP_CLAUSE_LINEAR \
3200 | OMP_CLAUSE_UNIFORM | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_INBRANCH \
3201 | OMP_CLAUSE_NOTINBRANCH)
6c7a4dfd 3202#define OMP_DO_CLAUSES \
b4c3a85b 3203 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
6c7a4dfd 3204 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
b4c3a85b 3205 | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE \
d8140b9e 3206 | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ORDER)
178191e1
TB		 3207#define OMP_LOOP_CLAUSES \
3208 (omp_mask (OMP_CLAUSE_BIND) | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_ORDER \
3209 | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
f8d535f3
TB		 3210#define OMP_SCOPE_CLAUSES \
3211 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_REDUCTION)
6c7a4dfd 3212#define OMP_SECTIONS_CLAUSES \
b4c3a85b 3213 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
6c7a4dfd 3214 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
dd2fc525 3215#define OMP_SIMD_CLAUSES \
b4c3a85b
JJ		 3216 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_LASTPRIVATE \
3217 | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_SAFELEN \
e55ba804 3218 | OMP_CLAUSE_LINEAR | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_SIMDLEN \
21cfe724 3219 | OMP_CLAUSE_IF | OMP_CLAUSE_ORDER | OMP_CLAUSE_NOTEMPORAL)
a68ab351 3220#define OMP_TASK_CLAUSES \
b4c3a85b
JJ		 3221 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
3222 | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT \
3223 | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE \
a6d22fb2 3224 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_IN_REDUCTION \
9a5de4d5 3225 | OMP_CLAUSE_DETACH | OMP_CLAUSE_AFFINITY)
b4c3a85b
JJ		 3226#define OMP_TASKLOOP_CLAUSES \
3227 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
3228 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_SHARED | OMP_CLAUSE_IF \
a6163563 3229 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED | OMP_CLAUSE_FINAL \
b4c3a85b 3230 | OMP_CLAUSE_MERGEABLE | OMP_CLAUSE_PRIORITY | OMP_CLAUSE_GRAINSIZE \
e929ef53
TB		 3231 | OMP_CLAUSE_NUM_TASKS | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_NOGROUP \
3232 | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IN_REDUCTION)
f014c653 3233#define OMP_TARGET_CLAUSES \
b4c3a85b
JJ		 3234 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
3235 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT | OMP_CLAUSE_PRIVATE \
3236 | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULTMAP \
e929ef53 3237 | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_IN_REDUCTION)
f014c653 3238#define OMP_TARGET_DATA_CLAUSES \
b4c3a85b 3239 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
ef4add8e 3240 | OMP_CLAUSE_USE_DEVICE_PTR | OMP_CLAUSE_USE_DEVICE_ADDR)
b4c3a85b
JJ		 3241#define OMP_TARGET_ENTER_DATA_CLAUSES \
3242 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
3243 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
3244#define OMP_TARGET_EXIT_DATA_CLAUSES \
3245 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \
3246 | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
f014c653 3247#define OMP_TARGET_UPDATE_CLAUSES \
b4c3a85b
JJ		 3248 (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_IF | OMP_CLAUSE_TO \
3249 | OMP_CLAUSE_FROM | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOWAIT)
f014c653 3250#define OMP_TEAMS_CLAUSES \
b4c3a85b 3251 (omp_mask (OMP_CLAUSE_NUM_TEAMS) | OMP_CLAUSE_THREAD_LIMIT \
a6163563 3252 | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
b4c3a85b 3253 | OMP_CLAUSE_SHARED | OMP_CLAUSE_REDUCTION)
f014c653 3254#define OMP_DISTRIBUTE_CLAUSES \
b4c3a85b 3255 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE \
f884bef2 3256 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_DIST_SCHEDULE)
b4c3a85b
JJ		 3257#define OMP_SINGLE_CLAUSES \
3258 (omp_mask (OMP_CLAUSE_PRIVATE) | OMP_CLAUSE_FIRSTPRIVATE)
3259#define OMP_ORDERED_CLAUSES \
3260 (omp_mask (OMP_CLAUSE_THREADS) | OMP_CLAUSE_SIMD)
3261#define OMP_DECLARE_TARGET_CLAUSES \
d58e7173 3262 (omp_mask (OMP_CLAUSE_TO) | OMP_CLAUSE_LINK | OMP_CLAUSE_DEVICE_TYPE)
1fc5e7ef
TB		 3263#define OMP_ATOMIC_CLAUSES \
3264 (omp_mask (OMP_CLAUSE_ATOMIC) | OMP_CLAUSE_CAPTURE | OMP_CLAUSE_HINT \
3265 | OMP_CLAUSE_MEMORDER)
53d5b59c
TB		 3266#define OMP_MASKED_CLAUSES \
3267 (omp_mask (OMP_CLAUSE_FILTER))
77167196
TB		 3268#define OMP_ERROR_CLAUSES \
3269 (omp_mask (OMP_CLAUSE_AT) | OMP_CLAUSE_MESSAGE | OMP_CLAUSE_SEVERITY)
3270
6c7a4dfd 3271
edf1eac2 3272
f014c653 3273static match
b4c3a85b 3274match_omp (gfc_exec_op op, const omp_mask mask)
a68ab351
JJ		 3275{
3276 gfc_omp_clauses *c;
f014c653 3277 if (gfc_match_omp_clauses (&c, mask) != MATCH_YES)
a68ab351 3278 return MATCH_ERROR;
f014c653 3279 new_st.op = op;
a68ab351
JJ		 3280 new_st.ext.omp_clauses = c;
3281 return MATCH_YES;
3282}
3283
3284
3285match
f014c653 3286gfc_match_omp_critical (void)
b4c3a85b
JJ		 3287{
3288 char n[GFC_MAX_SYMBOL_LEN+1];
3289 gfc_omp_clauses *c = NULL;
3290
3291 if (gfc_match (" ( %n )", n) != MATCH_YES)
c7c24828
TB		 3292 n[0] = '\0';
3293
3294 if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_HINT),
3295 /* first = */ n[0] == '\0') != MATCH_YES)
b4c3a85b
JJ		 3296 return MATCH_ERROR;
3297
3298 new_st.op = EXEC_OMP_CRITICAL;
3299 new_st.ext.omp_clauses = c;
3300 if (n[0])
3301 c->critical_name = xstrdup (n);
3302 return MATCH_YES;
3303}
3304
3305
3306match
3307gfc_match_omp_end_critical (void)
a68ab351 3308{
f014c653
JJ		 3309 char n[GFC_MAX_SYMBOL_LEN+1];
3310
3311 if (gfc_match (" ( %n )", n) != MATCH_YES)
3312 n[0] = '\0';
a68ab351 3313 if (gfc_match_omp_eos () != MATCH_YES)
edf86ec1 3314 {
f014c653 3315 gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
edf86ec1
DF		 3316 return MATCH_ERROR;
3317 }
b4c3a85b
JJ		 3318
3319 new_st.op = EXEC_OMP_END_CRITICAL;
f014c653 3320 new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
a68ab351
JJ		 3321 return MATCH_YES;
3322}
3323
a61c4964
TB		 3324/* depobj(depobj) depend(dep-type:loc)|destroy|update(dep-type)
3325 dep-type = in/out/inout/mutexinoutset/depobj/source/sink
3326 depend: !source, !sink
3327 update: !source, !sink, !depobj
3328 locator = exactly one list item .*/
3329match
3330gfc_match_omp_depobj (void)
3331{
3332 gfc_omp_clauses *c = NULL;
3333 gfc_expr *depobj;
3334
3335 if (gfc_match (" ( %v ) ", &depobj) != MATCH_YES)
3336 {
3337 gfc_error ("Expected %<( depobj )%> at %C");
3338 return MATCH_ERROR;
3339 }
3340 if (gfc_match ("update ( ") == MATCH_YES)
3341 {
3342 c = gfc_get_omp_clauses ();
3343 if (gfc_match ("inout )") == MATCH_YES)
3344 c->depobj_update = OMP_DEPEND_INOUT;
3345 else if (gfc_match ("in )") == MATCH_YES)
3346 c->depobj_update = OMP_DEPEND_IN;
3347 else if (gfc_match ("out )") == MATCH_YES)
3348 c->depobj_update = OMP_DEPEND_OUT;
3349 else if (gfc_match ("mutexinoutset )") == MATCH_YES)
3350 c->depobj_update = OMP_DEPEND_MUTEXINOUTSET;
3351 else
3352 {
3353 gfc_error ("Expected IN, OUT, INOUT, MUTEXINOUTSET followed by "
3354 "%<)%> at %C");
3355 goto error;
3356 }
3357 }
3358 else if (gfc_match ("destroy") == MATCH_YES)
3359 {
3360 c = gfc_get_omp_clauses ();
3361 c->destroy = true;
3362 }
3363 else if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_DEPEND), true, false)
3364 != MATCH_YES)
3365 goto error;
3366
3367 if (c->depobj_update == OMP_DEPEND_UNSET && !c->destroy)
3368 {
3369 if (!c->depend_source && !c->lists[OMP_LIST_DEPEND])
3370 {
3371 gfc_error ("Expected DEPEND, UPDATE, or DESTROY clause at %C");
3372 goto error;
3373 }
3374 if (c->depend_source
3375 || c->lists[OMP_LIST_DEPEND]->u.depend_op == OMP_DEPEND_SINK_FIRST
3376 || c->lists[OMP_LIST_DEPEND]->u.depend_op == OMP_DEPEND_SINK
3377 || c->lists[OMP_LIST_DEPEND]->u.depend_op == OMP_DEPEND_DEPOBJ)
3378 {
3379 gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall not "
3380 "have dependence-type SOURCE, SINK or DEPOBJ",
3381 c->lists[OMP_LIST_DEPEND]
3382 ? &c->lists[OMP_LIST_DEPEND]->where : &gfc_current_locus);
3383 goto error;
3384 }
3385 if (c->lists[OMP_LIST_DEPEND]->next)
3386 {
3387 gfc_error ("DEPEND clause at %L of OMP DEPOBJ construct shall have "
3388 "only a single locator",
3389 &c->lists[OMP_LIST_DEPEND]->next->where);
3390 goto error;
3391 }
3392 }
3393
3394 c->depobj = depobj;
3395 new_st.op = EXEC_OMP_DEPOBJ;
3396 new_st.ext.omp_clauses = c;
3397 return MATCH_YES;
3398
3399error:
3400 gfc_free_expr (depobj);
3401 gfc_free_omp_clauses (c);
3402 return MATCH_ERROR;
3403}
a68ab351 3404
20906c66 3405match
f014c653 3406gfc_match_omp_distribute (void)
20906c66 3407{
f014c653 3408 return match_omp (EXEC_OMP_DISTRIBUTE, OMP_DISTRIBUTE_CLAUSES);
20906c66
JJ		 3409}
3410
3411
6c7a4dfd 3412match
f014c653 3413gfc_match_omp_distribute_parallel_do (void)
6c7a4dfd 3414{
f014c653 3415 return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO,
b4c3a85b
JJ		 3416 (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
3417 | OMP_DO_CLAUSES)
3418 & ~(omp_mask (OMP_CLAUSE_ORDERED))
3419 & ~(omp_mask (OMP_CLAUSE_LINEAR)));
f014c653 3420}
6c7a4dfd 3421
f014c653
JJ		 3422
3423match
3424gfc_match_omp_distribute_parallel_do_simd (void)
3425{
3426 return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD,
3427 (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
3428 | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
b4c3a85b 3429 & ~(omp_mask (OMP_CLAUSE_ORDERED)));
f014c653
JJ		 3430}
3431
3432
3433match
3434gfc_match_omp_distribute_simd (void)
3435{
3436 return match_omp (EXEC_OMP_DISTRIBUTE_SIMD,
3437 OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
6c7a4dfd
JJ		 3438}
3439
edf1eac2 3440
6c7a4dfd
JJ		 3441match
3442gfc_match_omp_do (void)
3443{
f014c653 3444 return match_omp (EXEC_OMP_DO, OMP_DO_CLAUSES);
6c7a4dfd
JJ		 3445}
3446
edf1eac2 3447
dd2fc525
JJ		 3448match
3449gfc_match_omp_do_simd (void)
3450{
b4c3a85b 3451 return match_omp (EXEC_OMP_DO_SIMD, OMP_DO_CLAUSES | OMP_SIMD_CLAUSES);
dd2fc525
JJ		 3452}
3453
3454
178191e1
TB		 3455match
3456gfc_match_omp_loop (void)
3457{
3458 return match_omp (EXEC_OMP_LOOP, OMP_LOOP_CLAUSES);
3459}
3460
3461
3462match
3463gfc_match_omp_teams_loop (void)
3464{
3465 return match_omp (EXEC_OMP_TEAMS_LOOP, OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES);
3466}
3467
3468
3469match
3470gfc_match_omp_target_teams_loop (void)
3471{
3472 return match_omp (EXEC_OMP_TARGET_TEAMS_LOOP,
3473 OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES | OMP_LOOP_CLAUSES);
3474}
3475
3476
3477match
3478gfc_match_omp_parallel_loop (void)
3479{
3480 return match_omp (EXEC_OMP_PARALLEL_LOOP,
3481 OMP_PARALLEL_CLAUSES | OMP_LOOP_CLAUSES);
3482}
3483
3484
3485match
3486gfc_match_omp_target_parallel_loop (void)
3487{
3488 return match_omp (EXEC_OMP_TARGET_PARALLEL_LOOP,
3489 (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES
3490 | OMP_LOOP_CLAUSES));
3491}
3492
3493
77167196
TB		 3494match
3495gfc_match_omp_error (void)
3496{
3497 locus loc = gfc_current_locus;
3498 match m = match_omp (EXEC_OMP_ERROR, OMP_ERROR_CLAUSES);
3499 if (m != MATCH_YES)
3500 return m;
3501
3502 gfc_omp_clauses *c = new_st.ext.omp_clauses;
3503 if (c->severity == OMP_SEVERITY_UNSET)
3504 c->severity = OMP_SEVERITY_FATAL;
3505 if (new_st.ext.omp_clauses->at == OMP_AT_EXECUTION)
3506 return MATCH_YES;
3507 if (c->message
3508 && (!gfc_resolve_expr (c->message)
3509 || c->message->ts.type != BT_CHARACTER
3510 || c->message->ts.kind != gfc_default_character_kind
3511 || c->message->rank != 0))
3512 {
3513 gfc_error ("MESSAGE clause at %L requires a scalar default-kind "
3514 "CHARACTER expression",
3515 &new_st.ext.omp_clauses->message->where);
3516 return MATCH_ERROR;
3517 }
3518 if (c->message && !gfc_is_constant_expr (c->message))
3519 {
3520 gfc_error ("Constant character expression required in MESSAGE clause "
3521 "at %L", &new_st.ext.omp_clauses->message->where);
3522 return MATCH_ERROR;
3523 }
3524 if (c->message)
3525 {
3526 const char *msg = G_("$OMP ERROR encountered at %L: %s");
3527 gcc_assert (c->message->expr_type == EXPR_CONSTANT);
3528 gfc_charlen_t slen = c->message->value.character.length;
3529 int i = gfc_validate_kind (BT_CHARACTER, gfc_default_character_kind,
3530 false);
3531 size_t size = slen * gfc_character_kinds[i].bit_size / 8;
3532 unsigned char *s = XCNEWVAR (unsigned char, size + 1);
3533 gfc_encode_character (gfc_default_character_kind, slen,
3534 c->message->value.character.string,
3535 (unsigned char *) s, size);
3536 s[size] = '\0';
3537 if (c->severity == OMP_SEVERITY_WARNING)
3538 gfc_warning_now (0, msg, &loc, s);
3539 else
3540 gfc_error_now (msg, &loc, s);
3541 free (s);
3542 }
3543 else
3544 {
3545 const char *msg = G_("$OMP ERROR encountered at %L");
3546 if (c->severity == OMP_SEVERITY_WARNING)
3547 gfc_warning_now (0, msg, &loc);
3548 else
3549 gfc_error_now (msg, &loc);
3550 }
3551 return MATCH_YES;
3552}
3553
6c7a4dfd
JJ		 3554match
3555gfc_match_omp_flush (void)
3556{
dd2fc525 3557 gfc_omp_namelist *list = NULL;
c26d7df1
TB		 3558 gfc_omp_clauses *c = NULL;
3559 gfc_gobble_whitespace ();
1fc5e7ef 3560 enum gfc_omp_memorder mo = OMP_MEMORDER_UNSET;
c26d7df1
TB		 3561 if (gfc_match_omp_eos () == MATCH_NO && gfc_peek_ascii_char () != '(')
3562 {
3563 if (gfc_match ("acq_rel") == MATCH_YES)
3564 mo = OMP_MEMORDER_ACQ_REL;
3565 else if (gfc_match ("release") == MATCH_YES)
3566 mo = OMP_MEMORDER_RELEASE;
3567 else if (gfc_match ("acquire") == MATCH_YES)
3568 mo = OMP_MEMORDER_ACQUIRE;
3569 else
3570 {
3571 gfc_error ("Expected AQC_REL, RELEASE, or ACQUIRE at %C");
3572 return MATCH_ERROR;
3573 }
3574 c = gfc_get_omp_clauses ();
3575 c->memorder = mo;
3576 }
6c7a4dfd 3577 gfc_match_omp_variable_list (" (", &list, true);
1fc5e7ef 3578 if (list && mo != OMP_MEMORDER_UNSET)
c26d7df1
TB		 3579 {
3580 gfc_error ("List specified together with memory order clause in FLUSH "
3581 "directive at %C");
9a5de4d5 3582 gfc_free_omp_namelist (list, false);
c26d7df1
TB		 3583 gfc_free_omp_clauses (c);
3584 return MATCH_ERROR;
3585 }
6c7a4dfd
JJ		 3586 if (gfc_match_omp_eos () != MATCH_YES)
3587 {
edf86ec1 3588 gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
9a5de4d5 3589 gfc_free_omp_namelist (list, false);
c26d7df1 3590 gfc_free_omp_clauses (c);
6c7a4dfd
JJ		 3591 return MATCH_ERROR;
3592 }
3593 new_st.op = EXEC_OMP_FLUSH;
3594 new_st.ext.omp_namelist = list;
c26d7df1 3595 new_st.ext.omp_clauses = c;
6c7a4dfd
JJ		 3596 return MATCH_YES;
3597}
3598
edf1eac2 3599
dd2fc525
JJ		 3600match
3601gfc_match_omp_declare_simd (void)
3602{
3603 locus where = gfc_current_locus;
3604 gfc_symbol *proc_name;
3605 gfc_omp_clauses *c;
3606 gfc_omp_declare_simd *ods;
b4c3a85b 3607 bool needs_space = false;
dd2fc525 3608
b4c3a85b
JJ		 3609 switch (gfc_match (" ( %s ) ", &proc_name))
3610 {
3611 case MATCH_YES: break;
3612 case MATCH_NO: proc_name = NULL; needs_space = true; break;
3613 case MATCH_ERROR: return MATCH_ERROR;
3614 }
dd2fc525
JJ		 3615
3616 if (gfc_match_omp_clauses (&c, OMP_DECLARE_SIMD_CLAUSES, true,
b4c3a85b 3617 needs_space) != MATCH_YES)
dd2fc525
JJ		 3618 return MATCH_ERROR;
3619
77524e0d
JJ		 3620 if (gfc_current_ns->is_block_data)
3621 {
3622 gfc_free_omp_clauses (c);
3623 return MATCH_YES;
3624 }
3625
dd2fc525
JJ		 3626 ods = gfc_get_omp_declare_simd ();
3627 ods->where = where;
3628 ods->proc_name = proc_name;
3629 ods->clauses = c;
3630 ods->next = gfc_current_ns->omp_declare_simd;
3631 gfc_current_ns->omp_declare_simd = ods;
3632 return MATCH_YES;
3633}
3634
3635
5f23671d
JJ		 3636static bool
3637match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2)
3638{
3639 match m;
3640 locus old_loc = gfc_current_locus;
3641 char sname[GFC_MAX_SYMBOL_LEN + 1];
3642 gfc_symbol *sym;
3643 gfc_namespace *ns = gfc_current_ns;
3644 gfc_expr *lvalue = NULL, *rvalue = NULL;
3645 gfc_symtree *st;
3646 gfc_actual_arglist *arglist;
3647
3648 m = gfc_match (" %v =", &lvalue);
3649 if (m != MATCH_YES)
3650 gfc_current_locus = old_loc;
3651 else
3652 {
3653 m = gfc_match (" %e )", &rvalue);
3654 if (m == MATCH_YES)
3655 {
3656 ns->code = gfc_get_code (EXEC_ASSIGN);
3657 ns->code->expr1 = lvalue;
3658 ns->code->expr2 = rvalue;
3659 ns->code->loc = old_loc;
3660 return true;
3661 }
3662
3663 gfc_current_locus = old_loc;
3664 gfc_free_expr (lvalue);
3665 }
3666
3667 m = gfc_match (" %n", sname);
3668 if (m != MATCH_YES)
3669 return false;
3670
3671 if (strcmp (sname, omp_sym1->name) == 0
3672 || strcmp (sname, omp_sym2->name) == 0)
3673 return false;
3674
3675 gfc_current_ns = ns->parent;
3676 if (gfc_get_ha_sym_tree (sname, &st))
3677 return false;
3678
3679 sym = st->n.sym;
3680 if (sym->attr.flavor != FL_PROCEDURE
3681 && sym->attr.flavor != FL_UNKNOWN)
3682 return false;
3683
3684 if (!sym->attr.generic
3685 && !sym->attr.subroutine
3686 && !sym->attr.function)
3687 {
3688 if (!(sym->attr.external && !sym->attr.referenced))
3689 {
3690 /* ...create a symbol in this scope... */
3691 if (sym->ns != gfc_current_ns
3692 && gfc_get_sym_tree (sname, NULL, &st, false) == 1)
3693 return false;
3694
3695 if (sym != st->n.sym)
3696 sym = st->n.sym;
3697 }
3698
3699 /* ...and then to try to make the symbol into a subroutine. */
3700 if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
3701 return false;
3702 }
3703
3704 gfc_set_sym_referenced (sym);
3705 gfc_gobble_whitespace ();
3706 if (gfc_peek_ascii_char () != '(')
3707 return false;
3708
3709 gfc_current_ns = ns;
3710 m = gfc_match_actual_arglist (1, &arglist);
3711 if (m != MATCH_YES)
3712 return false;
3713
3714 if (gfc_match_char (')') != MATCH_YES)
3715 return false;
3716
3717 ns->code = gfc_get_code (EXEC_CALL);
3718 ns->code->symtree = st;
3719 ns->code->ext.actual = arglist;
3720 ns->code->loc = old_loc;
3721 return true;
3722}
3723
3724static bool
3725gfc_omp_udr_predef (gfc_omp_reduction_op rop, const char *name,
3726 gfc_typespec *ts, const char **n)
3727{
3728 if (!gfc_numeric_ts (ts) && ts->type != BT_LOGICAL)
3729 return false;
3730
3731 switch (rop)
3732 {
3733 case OMP_REDUCTION_PLUS:
3734 case OMP_REDUCTION_MINUS:
3735 case OMP_REDUCTION_TIMES:
3736 return ts->type != BT_LOGICAL;
3737 case OMP_REDUCTION_AND:
3738 case OMP_REDUCTION_OR:
3739 case OMP_REDUCTION_EQV:
3740 case OMP_REDUCTION_NEQV:
3741 return ts->type == BT_LOGICAL;
3742 case OMP_REDUCTION_USER:
3743 if (name[0] != '.' && (ts->type == BT_INTEGER || ts->type == BT_REAL))
3744 {
3745 gfc_symbol *sym;
3746
3747 gfc_find_symbol (name, NULL, 1, &sym);
3748 if (sym != NULL)
3749 {
3750 if (sym->attr.intrinsic)
3751 *n = sym->name;
3752 else if ((sym->attr.flavor != FL_UNKNOWN
3753 && sym->attr.flavor != FL_PROCEDURE)
3754 || sym->attr.external
3755 || sym->attr.generic
3756 || sym->attr.entry
3757 || sym->attr.result
3758 || sym->attr.dummy
3759 || sym->attr.subroutine
3760 || sym->attr.pointer
3761 || sym->attr.target
3762 || sym->attr.cray_pointer
3763 || sym->attr.cray_pointee
3764 || (sym->attr.proc != PROC_UNKNOWN
3765 && sym->attr.proc != PROC_INTRINSIC)
3766 || sym->attr.if_source != IFSRC_UNKNOWN
3767 || sym == sym->ns->proc_name)
3768 *n = NULL;
3769 else
3770 *n = sym->name;
3771 }
3772 else
3773 *n = name;
3774 if (*n
3775 && (strcmp (*n, "max") == 0 || strcmp (*n, "min") == 0))
3776 return true;
3777 else if (*n
3778 && ts->type == BT_INTEGER
3779 && (strcmp (*n, "iand") == 0
3780 || strcmp (*n, "ior") == 0
3781 || strcmp (*n, "ieor") == 0))
3782 return true;
3783 }
3784 break;
3785 default:
3786 break;
3787 }
3788 return false;
3789}
3790
3791gfc_omp_udr *
3792gfc_omp_udr_find (gfc_symtree *st, gfc_typespec *ts)
3793{
3794 gfc_omp_udr *omp_udr;
3795
3796 if (st == NULL)
3797 return NULL;
3798
3799 for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
3800 if (omp_udr->ts.type == ts->type
3801 || ((omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
6eef39f1 3802 && (ts->type == BT_DERIVED || ts->type == BT_CLASS)))
5f23671d
JJ		 3803 {
3804 if (omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
3805 {
3806 if (strcmp (omp_udr->ts.u.derived->name, ts->u.derived->name) == 0)
3807 return omp_udr;
3808 }
3809 else if (omp_udr->ts.kind == ts->kind)
3810 {
3811 if (omp_udr->ts.type == BT_CHARACTER)
3812 {
3813 if (omp_udr->ts.u.cl->length == NULL
3814 || ts->u.cl->length == NULL)
3815 return omp_udr;
3816 if (omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
3817 return omp_udr;
3818 if (ts->u.cl->length->expr_type != EXPR_CONSTANT)
3819 return omp_udr;
3820 if (omp_udr->ts.u.cl->length->ts.type != BT_INTEGER)
3821 return omp_udr;
3822 if (ts->u.cl->length->ts.type != BT_INTEGER)
3823 return omp_udr;
3824 if (gfc_compare_expr (omp_udr->ts.u.cl->length,
3825 ts->u.cl->length, INTRINSIC_EQ) != 0)
3826 continue;
3827 }
3828 return omp_udr;
3829 }
3830 }
3831 return NULL;
3832}
3833
3834match
3835gfc_match_omp_declare_reduction (void)
3836{
3837 match m;
3838 gfc_intrinsic_op op;
3839 char name[GFC_MAX_SYMBOL_LEN + 3];
3840 auto_vec<gfc_typespec, 5> tss;
3841 gfc_typespec ts;
3842 unsigned int i;
3843 gfc_symtree *st;
3844 locus where = gfc_current_locus;
3845 locus end_loc = gfc_current_locus;
3846 bool end_loc_set = false;
3847 gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
3848
3849 if (gfc_match_char ('(') != MATCH_YES)
3850 return MATCH_ERROR;
3851
3852 m = gfc_match (" %o : ", &op);
3853 if (m == MATCH_ERROR)
3854 return MATCH_ERROR;
3855 if (m == MATCH_YES)
3856 {
3857 snprintf (name, sizeof name, "operator %s", gfc_op2string (op));
3858 rop = (gfc_omp_reduction_op) op;
3859 }
3860 else
3861 {
3862 m = gfc_match_defined_op_name (name + 1, 1);
3863 if (m == MATCH_ERROR)
3864 return MATCH_ERROR;
3865 if (m == MATCH_YES)
3866 {
3867 name[0] = '.';
3868 strcat (name, ".");
3869 if (gfc_match (" : ") != MATCH_YES)
3870 return MATCH_ERROR;
3871 }
3872 else
3873 {
3874 if (gfc_match (" %n : ", name) != MATCH_YES)
3875 return MATCH_ERROR;
3876 }
3877 rop = OMP_REDUCTION_USER;
3878 }
3879
3880 m = gfc_match_type_spec (&ts);
3881 if (m != MATCH_YES)
3882 return MATCH_ERROR;
b46ebd6c
JJ		 3883 /* Treat len=: the same as len=*. */
3884 if (ts.type == BT_CHARACTER)
3885 ts.deferred = false;
5f23671d
JJ		 3886 tss.safe_push (ts);
3887
3888 while (gfc_match_char (',') == MATCH_YES)
3889 {
3890 m = gfc_match_type_spec (&ts);
3891 if (m != MATCH_YES)
3892 return MATCH_ERROR;
3893 tss.safe_push (ts);
3894 }
3895 if (gfc_match_char (':') != MATCH_YES)
3896 return MATCH_ERROR;
3897
3898 st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
3899 for (i = 0; i < tss.length (); i++)
3900 {
3901 gfc_symtree *omp_out, *omp_in;
3902 gfc_symtree *omp_priv = NULL, *omp_orig = NULL;
3903 gfc_namespace *combiner_ns, *initializer_ns = NULL;
3904 gfc_omp_udr *prev_udr, *omp_udr;
3905 const char *predef_name = NULL;
3906
3907 omp_udr = gfc_get_omp_udr ();
51f03c6b 3908 omp_udr->name = gfc_get_string ("%s", name);
5f23671d
JJ		 3909 omp_udr->rop = rop;
3910 omp_udr->ts = tss[i];
3911 omp_udr->where = where;
3912
3913 gfc_current_ns = combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
3914 combiner_ns->proc_name = combiner_ns->parent->proc_name;
3915
3916 gfc_get_sym_tree ("omp_out", combiner_ns, &omp_out, false);
3917 gfc_get_sym_tree ("omp_in", combiner_ns, &omp_in, false);
3918 combiner_ns->omp_udr_ns = 1;
3919 omp_out->n.sym->ts = tss[i];
3920 omp_in->n.sym->ts = tss[i];
3921 omp_out->n.sym->attr.omp_udr_artificial_var = 1;
3922 omp_in->n.sym->attr.omp_udr_artificial_var = 1;
b46ebd6c
JJ		 3923 omp_out->n.sym->attr.flavor = FL_VARIABLE;
3924 omp_in->n.sym->attr.flavor = FL_VARIABLE;
5f23671d
JJ		 3925 gfc_commit_symbols ();
3926 omp_udr->combiner_ns = combiner_ns;
3927 omp_udr->omp_out = omp_out->n.sym;
3928 omp_udr->omp_in = omp_in->n.sym;
3929
3930 locus old_loc = gfc_current_locus;
3931
3932 if (!match_udr_expr (omp_out, omp_in))
3933 {
3934 syntax:
3935 gfc_current_locus = old_loc;
3936 gfc_current_ns = combiner_ns->parent;
4875c29c 3937 gfc_undo_symbols ();
5f23671d
JJ		 3938 gfc_free_omp_udr (omp_udr);
3939 return MATCH_ERROR;
3940 }
3941
3942 if (gfc_match (" initializer ( ") == MATCH_YES)
3943 {
3944 gfc_current_ns = combiner_ns->parent;
3945 initializer_ns = gfc_get_namespace (gfc_current_ns, 1);
3946 gfc_current_ns = initializer_ns;
3947 initializer_ns->proc_name = initializer_ns->parent->proc_name;
3948
3949 gfc_get_sym_tree ("omp_priv", initializer_ns, &omp_priv, false);
3950 gfc_get_sym_tree ("omp_orig", initializer_ns, &omp_orig, false);
3951 initializer_ns->omp_udr_ns = 1;
3952 omp_priv->n.sym->ts = tss[i];
3953 omp_orig->n.sym->ts = tss[i];
3954 omp_priv->n.sym->attr.omp_udr_artificial_var = 1;
3955 omp_orig->n.sym->attr.omp_udr_artificial_var = 1;
b46ebd6c
JJ		 3956 omp_priv->n.sym->attr.flavor = FL_VARIABLE;
3957 omp_orig->n.sym->attr.flavor = FL_VARIABLE;
5f23671d
JJ		 3958 gfc_commit_symbols ();
3959 omp_udr->initializer_ns = initializer_ns;
3960 omp_udr->omp_priv = omp_priv->n.sym;
3961 omp_udr->omp_orig = omp_orig->n.sym;
3962
3963 if (!match_udr_expr (omp_priv, omp_orig))
3964 goto syntax;
3965 }
3966
3967 gfc_current_ns = combiner_ns->parent;
3968 if (!end_loc_set)
3969 {
3970 end_loc_set = true;
3971 end_loc = gfc_current_locus;
3972 }
3973 gfc_current_locus = old_loc;
3974
3975 prev_udr = gfc_omp_udr_find (st, &tss[i]);
3976 if (gfc_omp_udr_predef (rop, name, &tss[i], &predef_name)
3977 /* Don't error on !$omp declare reduction (min : integer : ...)
3978 just yet, there could be integer :: min afterwards,
3979 making it valid. When the UDR is resolved, we'll get
3980 to it again. */
3981 && (rop != OMP_REDUCTION_USER || name[0] == '.'))
3982 {
3983 if (predef_name)
3984 gfc_error_now ("Redefinition of predefined %s "
3985 "!$OMP DECLARE REDUCTION at %L",
3986 predef_name, &where);
3987 else
3988 gfc_error_now ("Redefinition of predefined "
3989 "!$OMP DECLARE REDUCTION at %L", &where);
3990 }
3991 else if (prev_udr)
3992 {
3993 gfc_error_now ("Redefinition of !$OMP DECLARE REDUCTION at %L",
3994 &where);
3995 gfc_error_now ("Previous !$OMP DECLARE REDUCTION at %L",
3996 &prev_udr->where);
3997 }
3998 else if (st)
3999 {
4000 omp_udr->next = st->n.omp_udr;
4001 st->n.omp_udr = omp_udr;
4002 }
4003 else
4004 {
4005 st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name);
4006 st->n.omp_udr = omp_udr;
4007 }
4008 }
4009
4010 if (end_loc_set)
4011 {
4012 gfc_current_locus = end_loc;
f014c653
JJ		 4013 if (gfc_match_omp_eos () != MATCH_YES)
4014 {
4015 gfc_error ("Unexpected junk after !$OMP DECLARE REDUCTION at %C");
4016 gfc_current_locus = where;
4017 return MATCH_ERROR;
4018 }
4019
5f23671d
JJ		 4020 return MATCH_YES;
4021 }
4022 gfc_clear_error ();
4023 return MATCH_ERROR;
4024}
4025
4026
f014c653
JJ		 4027match
4028gfc_match_omp_declare_target (void)
4029{
4030 locus old_loc;
f014c653 4031 match m;
b4c3a85b
JJ		 4032 gfc_omp_clauses *c = NULL;
4033 int list;
4034 gfc_omp_namelist *n;
4035 gfc_symbol *s;
f014c653
JJ		 4036
4037 old_loc = gfc_current_locus;
4038
f014c653 4039 if (gfc_current_ns->proc_name
f014c653
JJ		 4040 && gfc_match_omp_eos () == MATCH_YES)
4041 {
4042 if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
4043 gfc_current_ns->proc_name->name,
4044 &old_loc))
4045 goto cleanup;
4046 return MATCH_YES;
4047 }
4048
b4c3a85b
JJ		 4049 if (gfc_current_ns->proc_name
4050 && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY)
4051 {
4052 gfc_error ("Only the !$OMP DECLARE TARGET form without "
4053 "clauses is allowed in interface block at %C");
4054 goto cleanup;
4055 }
f014c653 4056
b4c3a85b
JJ		 4057 m = gfc_match (" (");
4058 if (m == MATCH_YES)
f014c653 4059 {
b4c3a85b
JJ		 4060 c = gfc_get_omp_clauses ();
4061 gfc_current_locus = old_loc;
4062 m = gfc_match_omp_to_link (" (", &c->lists[OMP_LIST_TO]);
4063 if (m != MATCH_YES)
4064 goto syntax;
4065 if (gfc_match_omp_eos () != MATCH_YES)
f014c653 4066 {
b4c3a85b 4067 gfc_error ("Unexpected junk after !$OMP DECLARE TARGET at %C");
f014c653
JJ		 4068 goto cleanup;
4069 }
b4c3a85b
JJ		 4070 }
4071 else if (gfc_match_omp_clauses (&c, OMP_DECLARE_TARGET_CLAUSES) != MATCH_YES)
4072 return MATCH_ERROR;
f014c653 4073
b4c3a85b 4074 gfc_buffer_error (false);
f014c653 4075
b4c3a85b
JJ		 4076 for (list = OMP_LIST_TO; list != OMP_LIST_NUM;
4077 list = (list == OMP_LIST_TO ? OMP_LIST_LINK : OMP_LIST_NUM))
4078 for (n = c->lists[list]; n; n = n->next)
4079 if (n->sym)
4080 n->sym->mark = 0;
4081 else if (n->u.common->head)
4082 n->u.common->head->mark = 0;
4083
4084 for (list = OMP_LIST_TO; list != OMP_LIST_NUM;
4085 list = (list == OMP_LIST_TO ? OMP_LIST_LINK : OMP_LIST_NUM))
4086 for (n = c->lists[list]; n; n = n->next)
4087 if (n->sym)
f014c653 4088 {
b4c3a85b
JJ		 4089 if (n->sym->attr.in_common)
4090 gfc_error_now ("OMP DECLARE TARGET variable at %L is an "
4091 "element of a COMMON block", &n->where);
4092 else if (n->sym->attr.omp_declare_target
4093 && n->sym->attr.omp_declare_target_link
4094 && list != OMP_LIST_LINK)
4095 gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
4096 "mentioned in LINK clause and later in TO clause",
4097 &n->where);
4098 else if (n->sym->attr.omp_declare_target
4099 && !n->sym->attr.omp_declare_target_link
4100 && list == OMP_LIST_LINK)
4101 gfc_error_now ("OMP DECLARE TARGET variable at %L previously "
4102 "mentioned in TO clause and later in LINK clause",
4103 &n->where);
4104 else if (n->sym->mark)
4105 gfc_error_now ("Variable at %L mentioned multiple times in "
4106 "clauses of the same OMP DECLARE TARGET directive",
4107 &n->where);
4108 else if (gfc_add_omp_declare_target (&n->sym->attr, n->sym->name,
4109 &n->sym->declared_at))
4110 {
4111 if (list == OMP_LIST_LINK)
4112 gfc_add_omp_declare_target_link (&n->sym->attr, n->sym->name,
4113 &n->sym->declared_at);
4114 }
d58e7173
TB		 4115 if (c->device_type != OMP_DEVICE_TYPE_UNSET)
4116 {
4117 if (n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
4118 && n->sym->attr.omp_device_type != c->device_type)
4119 gfc_error_now ("List item %qs at %L set in previous OMP DECLARE "
4120 "TARGET directive to a different DEVICE_TYPE",
4121 n->sym->name, &n->where);
4122 n->sym->attr.omp_device_type = c->device_type;
4123 }
b4c3a85b
JJ		 4124 n->sym->mark = 1;
4125 }
4126 else if (n->u.common->omp_declare_target
4127 && n->u.common->omp_declare_target_link
4128 && list != OMP_LIST_LINK)
4129 gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously "
4130 "mentioned in LINK clause and later in TO clause",
4131 &n->where);
4132 else if (n->u.common->omp_declare_target
4133 && !n->u.common->omp_declare_target_link
4134 && list == OMP_LIST_LINK)
4135 gfc_error_now ("OMP DECLARE TARGET COMMON at %L previously "
4136 "mentioned in TO clause and later in LINK clause",
4137 &n->where);
4138 else if (n->u.common->head && n->u.common->head->mark)
4139 gfc_error_now ("COMMON at %L mentioned multiple times in "
4140 "clauses of the same OMP DECLARE TARGET directive",
4141 &n->where);
4142 else
4143 {
4144 n->u.common->omp_declare_target = 1;
4145 n->u.common->omp_declare_target_link = (list == OMP_LIST_LINK);
d58e7173
TB		 4146 if (n->u.common->omp_device_type != OMP_DEVICE_TYPE_UNSET
4147 && n->u.common->omp_device_type != c->device_type)
4148 gfc_error_now ("COMMON at %L set in previous OMP DECLARE "
4149 "TARGET directive to a different DEVICE_TYPE",
4150 &n->where);
4151 n->u.common->omp_device_type = c->device_type;
4152
b4c3a85b
JJ		 4153 for (s = n->u.common->head; s; s = s->common_next)
4154 {
4155 s->mark = 1;
4156 if (gfc_add_omp_declare_target (&s->attr, s->name,
4157 &s->declared_at))
4158 {
4159 if (list == OMP_LIST_LINK)
4160 gfc_add_omp_declare_target_link (&s->attr, s->name,
4161 &s->declared_at);
4162 }
d58e7173
TB		 4163 if (s->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
4164 && s->attr.omp_device_type != c->device_type)
4165 gfc_error_now ("List item %qs at %L set in previous OMP DECLARE"
4166 " TARGET directive to a different DEVICE_TYPE",
4167 s->name, &n->where);
4168 s->attr.omp_device_type = c->device_type;
b4c3a85b 4169 }
f014c653 4170 }
d58e7173
TB		 4171 if (c->device_type && !c->lists[OMP_LIST_TO] && !c->lists[OMP_LIST_LINK])
4172 gfc_warning_now (0, "OMP DECLARE TARGET directive at %L with only "
4173 "DEVICE_TYPE clause is ignored", &old_loc);
f014c653 4174
b4c3a85b 4175 gfc_buffer_error (true);
f014c653 4176
b4c3a85b
JJ		 4177 if (c)
4178 gfc_free_omp_clauses (c);
f014c653
JJ		 4179 return MATCH_YES;
4180
4181syntax:
4182 gfc_error ("Syntax error in !$OMP DECLARE TARGET list at %C");
4183
4184cleanup:
4185 gfc_current_locus = old_loc;
b4c3a85b
JJ		 4186 if (c)
4187 gfc_free_omp_clauses (c);
f014c653
JJ		 4188 return MATCH_ERROR;
4189}
4190
4191
6c7a4dfd
JJ		 4192match
4193gfc_match_omp_threadprivate (void)
4194{
4195 locus old_loc;
4196 char n[GFC_MAX_SYMBOL_LEN+1];
4197 gfc_symbol *sym;
4198 match m;
4199 gfc_symtree *st;
4200
4201 old_loc = gfc_current_locus;
4202
4203 m = gfc_match (" (");
4204 if (m != MATCH_YES)
4205 return m;
4206
6c7a4dfd
JJ		 4207 for (;;)
4208 {
4209 m = gfc_match_symbol (&sym, 0);
4210 switch (m)
4211 {
4212 case MATCH_YES:
4213 if (sym->attr.in_common)
edf1eac2
SK		 4214 gfc_error_now ("Threadprivate variable at %C is an element of "
4215 "a COMMON block");
524af0d6 4216 else if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at))
6c7a4dfd
JJ		 4217 goto cleanup;
4218 goto next_item;
4219 case MATCH_NO:
4220 break;
4221 case MATCH_ERROR:
4222 goto cleanup;
4223 }
4224
4225 m = gfc_match (" / %n /", n);
4226 if (m == MATCH_ERROR)
4227 goto cleanup;
4228 if (m == MATCH_NO || n[0] == '\0')
4229 goto syntax;
4230
4231 st = gfc_find_symtree (gfc_current_ns->common_root, n);
4232 if (st == NULL)
4233 {
4234 gfc_error ("COMMON block /%s/ not found at %C", n);
4235 goto cleanup;
4236 }
4237 st->n.common->threadprivate = 1;
4238 for (sym = st->n.common->head; sym; sym = sym->common_next)
524af0d6 4239 if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at))
6c7a4dfd
JJ		 4240 goto cleanup;
4241
4242 next_item:
4243 if (gfc_match_char (')') == MATCH_YES)
4244 break;
4245 if (gfc_match_char (',') != MATCH_YES)
4246 goto syntax;
4247 }
4248
f014c653
JJ		 4249 if (gfc_match_omp_eos () != MATCH_YES)
4250 {
4251 gfc_error ("Unexpected junk after OMP THREADPRIVATE at %C");
4252 goto cleanup;
4253 }
4254
6c7a4dfd
JJ		 4255 return MATCH_YES;
4256
4257syntax:
4258 gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C");
4259
4260cleanup:
4261 gfc_current_locus = old_loc;
4262 return MATCH_ERROR;
4263}
4264
edf1eac2 4265
f014c653
JJ		 4266match
4267gfc_match_omp_parallel (void)
4268{
4269 return match_omp (EXEC_OMP_PARALLEL, OMP_PARALLEL_CLAUSES);
4270}
4271
4272
6c7a4dfd
JJ		 4273match
4274gfc_match_omp_parallel_do (void)
4275{
f014c653
JJ		 4276 return match_omp (EXEC_OMP_PARALLEL_DO,
4277 OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES);
6c7a4dfd
JJ		 4278}
4279
edf1eac2 4280
dd2fc525
JJ		 4281match
4282gfc_match_omp_parallel_do_simd (void)
4283{
f014c653 4284 return match_omp (EXEC_OMP_PARALLEL_DO_SIMD,
b4c3a85b 4285 OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES);
dd2fc525
JJ		 4286}
4287
4288
53d5b59c
TB		 4289match
4290gfc_match_omp_parallel_masked (void)
4291{
4292 return match_omp (EXEC_OMP_PARALLEL_MASKED,
4293 OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES);
4294}
4295
4296match
4297gfc_match_omp_parallel_masked_taskloop (void)
4298{
4299 return match_omp (EXEC_OMP_PARALLEL_MASKED_TASKLOOP,
4300 (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES
4301 | OMP_TASKLOOP_CLAUSES)
4302 & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
4303}
4304
4305match
4306gfc_match_omp_parallel_masked_taskloop_simd (void)
4307{
4308 return match_omp (EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD,
4309 (OMP_PARALLEL_CLAUSES | OMP_MASKED_CLAUSES
4310 | OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES)
4311 & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
4312}
4313
0e3702f8
TB		 4314match
4315gfc_match_omp_parallel_master (void)
4316{
4317 return match_omp (EXEC_OMP_PARALLEL_MASTER, OMP_PARALLEL_CLAUSES);
4318}
4319
f6bf436d
TB		 4320match
4321gfc_match_omp_parallel_master_taskloop (void)
4322{
4323 return match_omp (EXEC_OMP_PARALLEL_MASTER_TASKLOOP,
4324 (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES)
4325 & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
4326}
4327
4328match
4329gfc_match_omp_parallel_master_taskloop_simd (void)
4330{
4331 return match_omp (EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD,
4332 (OMP_PARALLEL_CLAUSES | OMP_TASKLOOP_CLAUSES
4333 | OMP_SIMD_CLAUSES)
4334 & ~(omp_mask (OMP_CLAUSE_IN_REDUCTION)));
4335}
0e3702f8 4336
6c7a4dfd
JJ		 4337match
4338gfc_match_omp_parallel_sections (void)
4339{
f014c653
JJ		 4340 return match_omp (EXEC_OMP_PARALLEL_SECTIONS,
4341 OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES);
6c7a4dfd
JJ		 4342}
4343
edf1eac2 4344
6c7a4dfd
JJ		 4345match
4346gfc_match_omp_parallel_workshare (void)
4347{
f014c653 4348 return match_omp (EXEC_OMP_PARALLEL_WORKSHARE, OMP_PARALLEL_CLAUSES);
6c7a4dfd
JJ		 4349}
4350
269322ec
TB		 4351void
4352gfc_check_omp_requires (gfc_namespace *ns, int ref_omp_requires)
4353{
4354 if (ns->omp_target_seen
4355 && (ns->omp_requires & OMP_REQ_TARGET_MASK)
4356 != (ref_omp_requires & OMP_REQ_TARGET_MASK))
4357 {
4358 gcc_assert (ns->proc_name);
4359 if ((ref_omp_requires & OMP_REQ_REVERSE_OFFLOAD)
4360 && !(ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD))
4361 gfc_error ("Program unit at %L has OpenMP device constructs/routines "
4362 "but does not set !$OMP REQUIRES REVERSE_OFFSET but other "
4363 "program units do", &ns->proc_name->declared_at);
4364 if ((ref_omp_requires & OMP_REQ_UNIFIED_ADDRESS)
4365 && !(ns->omp_requires & OMP_REQ_UNIFIED_ADDRESS))
4366 gfc_error ("Program unit at %L has OpenMP device constructs/routines "
4367 "but does not set !$OMP REQUIRES UNIFIED_ADDRESS but other "
4368 "program units do", &ns->proc_name->declared_at);
4369 if ((ref_omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY)
4370 && !(ns->omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY))
4371 gfc_error ("Program unit at %L has OpenMP device constructs/routines "
4372 "but does not set !$OMP REQUIRES UNIFIED_SHARED_MEMORY but "
4373 "other program units do", &ns->proc_name->declared_at);
4374 }
4375}
4376
4377bool
4378gfc_omp_requires_add_clause (gfc_omp_requires_kind clause,
4379 const char *clause_name, locus *loc,
4380 const char *module_name)
4381{
4382 gfc_namespace *prog_unit = gfc_current_ns;
4383 while (prog_unit->parent)
4384 {
4385 if (gfc_state_stack->previous
4386 && gfc_state_stack->previous->state == COMP_INTERFACE)
4387 break;
4388 prog_unit = prog_unit->parent;
4389 }
4390
4391 /* Requires added after use. */
4392 if (prog_unit->omp_target_seen
4393 && (clause & OMP_REQ_TARGET_MASK)
4394 && !(prog_unit->omp_requires & clause))
4395 {
4396 if (module_name)
4397 gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use "
4398 "at %L comes after using a device construct/routine",
4399 clause_name, module_name, loc);
4400 else
4401 gfc_error ("!$OMP REQUIRES clause %qs specified at %L comes after "
4402 "using a device construct/routine", clause_name, loc);
4403 return false;
4404 }
4405
4406 /* Overriding atomic_default_mem_order clause value. */
4407 if ((clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
4408 && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
4409 && (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
4410 != (int) clause)
4411 {
4412 const char *other;
4413 if (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST)
4414 other = "seq_cst";
4415 else if (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL)
4416 other = "acq_rel";
4417 else if (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_RELAXED)
4418 other = "relaxed";
4419 else
4420 gcc_unreachable ();
4421
4422 if (module_name)
4423 gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
4424 "specified via module %qs use at %L overrides a previous "
4425 "%<atomic_default_mem_order(%s)%> (which might be through "
4426 "using a module)", clause_name, module_name, loc, other);
4427 else
4428 gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
4429 "specified at %L overrides a previous "
4430 "%<atomic_default_mem_order(%s)%> (which might be through "
4431 "using a module)", clause_name, loc, other);
4432 return false;
4433 }
4434
4435 /* Requires via module not at program-unit level and not repeating clause. */
4436 if (prog_unit != gfc_current_ns && !(prog_unit->omp_requires & clause))
4437 {
4438 if (clause & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
4439 gfc_error ("!$OMP REQUIRES clause %<atomic_default_mem_order(%s)%> "
4440 "specified via module %qs use at %L but same clause is "
48ca2185
JJ		 4441 "not specified for the program unit", clause_name,
4442 module_name, loc);
269322ec
TB		 4443 else
4444 gfc_error ("!$OMP REQUIRES clause %qs specified via module %qs use at "
48ca2185 4445 "%L but same clause is not specified for the program unit",
269322ec
TB		 4446 clause_name, module_name, loc);
4447 return false;
4448 }
4449
4450 if (!gfc_state_stack->previous
4451 || gfc_state_stack->previous->state != COMP_INTERFACE)
4452 prog_unit->omp_requires |= clause;
4453 return true;
4454}
4455
4456match
4457gfc_match_omp_requires (void)
4458{
4459 static const char *clauses[] = {"reverse_offload",
4460 "unified_address",
4461 "unified_shared_memory",
4462 "dynamic_allocators",
4463 "atomic_default"};
4464 const char *clause = NULL;
4465 int requires_clauses = 0;
4466 bool first = true;
4467 locus old_loc;
4468
4469 if (gfc_current_ns->parent
4470 && (!gfc_state_stack->previous
4471 || gfc_state_stack->previous->state != COMP_INTERFACE))
4472 {
4473 gfc_error ("!$OMP REQUIRES at %C must appear in the specification part "
4474 "of a program unit");
4475 return MATCH_ERROR;
4476 }
4477
4478 while (true)
4479 {
4480 old_loc = gfc_current_locus;
4481 gfc_omp_requires_kind requires_clause;
4482 if ((first || gfc_match_char (',') != MATCH_YES)
4483 && (first && gfc_match_space () != MATCH_YES))
4484 goto error;
4485 first = false;
4486 gfc_gobble_whitespace ();
4487 old_loc = gfc_current_locus;
4488
4489 if (gfc_match_omp_eos () != MATCH_NO)
4490 break;
4491 if (gfc_match (clauses[0]) == MATCH_YES)
4492 {
4493 clause = clauses[0];
4494 requires_clause = OMP_REQ_REVERSE_OFFLOAD;
4495 if (requires_clauses & OMP_REQ_REVERSE_OFFLOAD)
4496 goto duplicate_clause;
4497 }
4498 else if (gfc_match (clauses[1]) == MATCH_YES)
4499 {
4500 clause = clauses[1];
4501 requires_clause = OMP_REQ_UNIFIED_ADDRESS;
4502 if (requires_clauses & OMP_REQ_UNIFIED_ADDRESS)
4503 goto duplicate_clause;
4504 }
4505 else if (gfc_match (clauses[2]) == MATCH_YES)
4506 {
4507 clause = clauses[2];
4508 requires_clause = OMP_REQ_UNIFIED_SHARED_MEMORY;
4509 if (requires_clauses & OMP_REQ_UNIFIED_SHARED_MEMORY)
4510 goto duplicate_clause;
4511 }
4512 else if (gfc_match (clauses[3]) == MATCH_YES)
4513 {
4514 clause = clauses[3];
4515 requires_clause = OMP_REQ_DYNAMIC_ALLOCATORS;
4516 if (requires_clauses & OMP_REQ_DYNAMIC_ALLOCATORS)
4517 goto duplicate_clause;
4518 }
4519 else if (gfc_match ("atomic_default_mem_order (") == MATCH_YES)
4520 {
4521 clause = clauses[4];
4522 if (requires_clauses & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
4523 goto duplicate_clause;
4524 if (gfc_match (" seq_cst )") == MATCH_YES)
4525 {
4526 clause = "seq_cst";
4527 requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST;
4528 }
4529 else if (gfc_match (" acq_rel )") == MATCH_YES)
4530 {
4531 clause = "acq_rel";
4532 requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL;
4533 }
4534 else if (gfc_match (" relaxed )") == MATCH_YES)
4535 {
4536 clause = "relaxed";
4537 requires_clause = OMP_REQ_ATOMIC_MEM_ORDER_RELAXED;
4538 }
4539 else
4540 {
4541 gfc_error ("Expected SEQ_CST, ACQ_REL or RELAXED for "
4542 "ATOMIC_DEFAULT_MEM_ORDER clause at %C");
4543 goto error;
4544 }
4545 }
4546 else
4547 goto error;
4548
4549 if (requires_clause & ~OMP_REQ_ATOMIC_MEM_ORDER_MASK)
4550 gfc_error_now ("Sorry, %qs clause at %L on REQUIRES directive is not "
4551 "yet supported", clause, &old_loc);
4552 if (!gfc_omp_requires_add_clause (requires_clause, clause, &old_loc, NULL))
4553 goto error;
4554 requires_clauses |= requires_clause;
4555 }
4556
4557 if (requires_clauses == 0)
4558 {
4559 if (!gfc_error_flag_test ())
4560 gfc_error ("Clause expected at %C");
4561 goto error;
4562 }
4563 return MATCH_YES;
4564
4565duplicate_clause:
4566 gfc_error ("%qs clause at %L specified more than once", clause, &old_loc);
4567error:
4568 if (!gfc_error_flag_test ())
4569 gfc_error ("Expected UNIFIED_ADDRESS, UNIFIED_SHARED_MEMORY, "
4570 "DYNAMIC_ALLOCATORS, REVERSE_OFFLOAD, or "
4571 "ATOMIC_DEFAULT_MEM_ORDER clause at %L", &old_loc);
4572 return MATCH_ERROR;
4573}
4574
edf1eac2 4575
005cff4e
TB		 4576match
4577gfc_match_omp_scan (void)
4578{
4579 bool incl;
4580 gfc_omp_clauses *c = gfc_get_omp_clauses ();
4581 gfc_gobble_whitespace ();
4582 if ((incl = (gfc_match ("inclusive") == MATCH_YES))
4583 || gfc_match ("exclusive") == MATCH_YES)
4584 {
4585 if (gfc_match_omp_variable_list (" (", &c->lists[incl ? OMP_LIST_SCAN_IN
4586 : OMP_LIST_SCAN_EX],
4587 false) != MATCH_YES)
4588 {
4589 gfc_free_omp_clauses (c);
4590 return MATCH_ERROR;
4591 }
4592 }
4593 else
4594 {
4595 gfc_error ("Expected INCLUSIVE or EXCLUSIVE clause at %C");
4596 gfc_free_omp_clauses (c);
4597 return MATCH_ERROR;
4598 }
4599 if (gfc_match_omp_eos () != MATCH_YES)
4600 {
4601 gfc_error ("Unexpected junk after !$OMP SCAN at %C");
4602 gfc_free_omp_clauses (c);
4603 return MATCH_ERROR;
4604 }
4605
4606 new_st.op = EXEC_OMP_SCAN;
4607 new_st.ext.omp_clauses = c;
4608 return MATCH_YES;
4609}
4610
4611
f8d535f3
TB		 4612match
4613gfc_match_omp_scope (void)
4614{
4615 return match_omp (EXEC_OMP_SCOPE, OMP_SCOPE_CLAUSES);
4616}
4617
4618
6c7a4dfd
JJ		 4619match
4620gfc_match_omp_sections (void)
4621{
f014c653
JJ		 4622 return match_omp (EXEC_OMP_SECTIONS, OMP_SECTIONS_CLAUSES);
4623}
4624
4625
4626match
4627gfc_match_omp_simd (void)
4628{
4629 return match_omp (EXEC_OMP_SIMD, OMP_SIMD_CLAUSES);
6c7a4dfd
JJ		 4630}
4631
edf1eac2 4632
6c7a4dfd
JJ		 4633match
4634gfc_match_omp_single (void)
4635{
b4c3a85b 4636 return match_omp (EXEC_OMP_SINGLE, OMP_SINGLE_CLAUSES);
f014c653
JJ		 4637}
4638
4639
4640match
b4c3a85b 4641gfc_match_omp_target (void)
f014c653 4642{
b4c3a85b 4643 return match_omp (EXEC_OMP_TARGET, OMP_TARGET_CLAUSES);
f014c653
JJ		 4644}
4645
4646
4647match
b4c3a85b 4648gfc_match_omp_target_data (void)
f014c653 4649{
b4c3a85b 4650 return match_omp (EXEC_OMP_TARGET_DATA, OMP_TARGET_DATA_CLAUSES);
6c7a4dfd
JJ		 4651}
4652
edf1eac2 4653
f014c653 4654match
b4c3a85b 4655gfc_match_omp_target_enter_data (void)
f014c653 4656{
b4c3a85b 4657 return match_omp (EXEC_OMP_TARGET_ENTER_DATA, OMP_TARGET_ENTER_DATA_CLAUSES);
f014c653
JJ		 4658}
4659
4660
4661match
b4c3a85b 4662gfc_match_omp_target_exit_data (void)
f014c653 4663{
b4c3a85b 4664 return match_omp (EXEC_OMP_TARGET_EXIT_DATA, OMP_TARGET_EXIT_DATA_CLAUSES);
f014c653
JJ		 4665}
4666
4667
4668match
b4c3a85b 4669gfc_match_omp_target_parallel (void)
f014c653 4670{
b4c3a85b
JJ		 4671 return match_omp (EXEC_OMP_TARGET_PARALLEL,
4672 (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES)
4673 & ~(omp_mask (OMP_CLAUSE_COPYIN)));
4674}
4675
4676
4677match
4678gfc_match_omp_target_parallel_do (void)
4679{
4680 return match_omp (EXEC_OMP_TARGET_PARALLEL_DO,
4681 (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES
4682 | OMP_DO_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN)));
4683}
4684
4685
4686match
4687gfc_match_omp_target_parallel_do_simd (void)
4688{
4689 return match_omp (EXEC_OMP_TARGET_PARALLEL_DO_SIMD,
4690 (OMP_TARGET_CLAUSES | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
4691 | OMP_SIMD_CLAUSES) & ~(omp_mask (OMP_CLAUSE_COPYIN)));
4692}
4693
4694
4695match
4696gfc_match_omp_target_simd (void)
4697{
4698 return match_omp (EXEC_OMP_TARGET_SIMD,
4699 OMP_TARGET_CLAUSES | OMP_SIMD_CLAUSES);
f014c653
JJ		 4700}
4701
4702
4703match
4704gfc_match_omp_target_teams (void)
4705{
4706 return match_omp (EXEC_OMP_TARGET_TEAMS,
4707 OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES);
4708}
4709
4710
4711match
4712gfc_match_omp_target_teams_distribute (void)
4713{
4714 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE,
4715 OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
4716 | OMP_DISTRIBUTE_CLAUSES);
4717}
4718
4719
4720match
4721gfc_match_omp_target_teams_distribute_parallel_do (void)
4722{
4723 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO,
b4c3a85b
JJ		 4724 (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
4725 | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
4726 | OMP_DO_CLAUSES)
4727 & ~(omp_mask (OMP_CLAUSE_ORDERED))
4728 & ~(omp_mask (OMP_CLAUSE_LINEAR)));
f014c653
JJ		 4729}
4730
4731
4732match
4733gfc_match_omp_target_teams_distribute_parallel_do_simd (void)
4734{
4735 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
4736 (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
4737 | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
4738 | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
b4c3a85b 4739 & ~(omp_mask (OMP_CLAUSE_ORDERED)));
f014c653
JJ		 4740}
4741
4742
4743match
4744gfc_match_omp_target_teams_distribute_simd (void)
4745{
4746 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD,
4747 OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
4748 | OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
4749}
4750
4751
4752match
4753gfc_match_omp_target_update (void)
4754{
4755 return match_omp (EXEC_OMP_TARGET_UPDATE, OMP_TARGET_UPDATE_CLAUSES);
4756}
4757
4758
b4c3a85b
JJ		 4759match
4760gfc_match_omp_task (void)
4761{
4762 return match_omp (EXEC_OMP_TASK, OMP_TASK_CLAUSES);
4763}
4764
4765
4766match
4767gfc_match_omp_taskloop (void)
4768{
4769 return match_omp (EXEC_OMP_TASKLOOP, OMP_TASKLOOP_CLAUSES);
4770}
4771
4772
4773match
4774gfc_match_omp_taskloop_simd (void)
4775{
4776 return match_omp (EXEC_OMP_TASKLOOP_SIMD,
f6bf436d 4777 OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES);
b4c3a85b
JJ		 4778}
4779
4780
4781match
4782gfc_match_omp_taskwait (void)
4783{
9a5de4d5 4784 if (gfc_match_omp_eos () == MATCH_YES)
b4c3a85b 4785 {
9a5de4d5
TB		 4786 new_st.op = EXEC_OMP_TASKWAIT;
4787 new_st.ext.omp_clauses = NULL;
4788 return MATCH_YES;
b4c3a85b 4789 }
9a5de4d5 4790 return match_omp (EXEC_OMP_TASKWAIT, omp_mask (OMP_CLAUSE_DEPEND));
b4c3a85b
JJ		 4791}
4792
4793
4794match
4795gfc_match_omp_taskyield (void)
4796{
4797 if (gfc_match_omp_eos () != MATCH_YES)
4798 {
4799 gfc_error ("Unexpected junk after TASKYIELD clause at %C");
4800 return MATCH_ERROR;
4801 }
4802 new_st.op = EXEC_OMP_TASKYIELD;
4803 new_st.ext.omp_clauses = NULL;
4804 return MATCH_YES;
4805}
4806
4807
f014c653
JJ		 4808match
4809gfc_match_omp_teams (void)
4810{
4811 return match_omp (EXEC_OMP_TEAMS, OMP_TEAMS_CLAUSES);
4812}
4813
4814
4815match
4816gfc_match_omp_teams_distribute (void)
4817{
4818 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE,
4819 OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES);
4820}
4821
4822
4823match
4824gfc_match_omp_teams_distribute_parallel_do (void)
4825{
4826 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO,
b4c3a85b
JJ		 4827 (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
4828 | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
4829 & ~(omp_mask (OMP_CLAUSE_ORDERED))
4830 & ~(omp_mask (OMP_CLAUSE_LINEAR)));
f014c653
JJ		 4831}
4832
4833
4834match
4835gfc_match_omp_teams_distribute_parallel_do_simd (void)
4836{
4837 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
4838 (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
4839 | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
b4c3a85b 4840 | OMP_SIMD_CLAUSES) & ~(omp_mask (OMP_CLAUSE_ORDERED)));
f014c653
JJ		 4841}
4842
4843
4844match
4845gfc_match_omp_teams_distribute_simd (void)
4846{
4847 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_SIMD,
4848 OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
4849 | OMP_SIMD_CLAUSES);
4850}
4851
4852
6c7a4dfd
JJ		 4853match
4854gfc_match_omp_workshare (void)
4855{
4856 if (gfc_match_omp_eos () != MATCH_YES)
edf86ec1
DF		 4857 {
4858 gfc_error ("Unexpected junk after $OMP WORKSHARE statement at %C");
4859 return MATCH_ERROR;
4860 }
6c7a4dfd
JJ		 4861 new_st.op = EXEC_OMP_WORKSHARE;
4862 new_st.ext.omp_clauses = gfc_get_omp_clauses ();
4863 return MATCH_YES;
4864}
4865
edf1eac2 4866
53d5b59c
TB		 4867match
4868gfc_match_omp_masked (void)
4869{
4870 return match_omp (EXEC_OMP_MASKED, OMP_MASKED_CLAUSES);
4871}
4872
4873match
4874gfc_match_omp_masked_taskloop (void)
4875{
4876 return match_omp (EXEC_OMP_MASKED_TASKLOOP,
4877 OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES);
4878}
4879
4880match
4881gfc_match_omp_masked_taskloop_simd (void)
4882{
4883 return match_omp (EXEC_OMP_MASKED_TASKLOOP_SIMD,
4884 (OMP_MASKED_CLAUSES | OMP_TASKLOOP_CLAUSES
4885 | OMP_SIMD_CLAUSES));
4886}
4887
6c7a4dfd
JJ		 4888match
4889gfc_match_omp_master (void)
4890{
4891 if (gfc_match_omp_eos () != MATCH_YES)
edf86ec1
DF		 4892 {
4893 gfc_error ("Unexpected junk after $OMP MASTER statement at %C");
4894 return MATCH_ERROR;
4895 }
6c7a4dfd
JJ		 4896 new_st.op = EXEC_OMP_MASTER;
4897 new_st.ext.omp_clauses = NULL;
4898 return MATCH_YES;
4899}
4900
f6bf436d
TB		 4901match
4902gfc_match_omp_master_taskloop (void)
4903{
4904 return match_omp (EXEC_OMP_MASTER_TASKLOOP, OMP_TASKLOOP_CLAUSES);
4905}
4906
4907match
4908gfc_match_omp_master_taskloop_simd (void)
4909{
4910 return match_omp (EXEC_OMP_MASTER_TASKLOOP_SIMD,
4911 OMP_TASKLOOP_CLAUSES | OMP_SIMD_CLAUSES);
4912}
edf1eac2 4913
6c7a4dfd
JJ		 4914match
4915gfc_match_omp_ordered (void)
4916{
b4c3a85b
JJ		 4917 return match_omp (EXEC_OMP_ORDERED, OMP_ORDERED_CLAUSES);
4918}
4919
f74433e7
TB		 4920match
4921gfc_match_omp_nothing (void)
4922{
4923 if (gfc_match_omp_eos () != MATCH_YES)
4924 {
4925 gfc_error ("Unexpected junk after $OMP NOTHING statement at %C");
4926 return MATCH_ERROR;
4927 }
4928 /* Will use ST_NONE; therefore, no EXEC_OMP_ is needed. */
4929 return MATCH_YES;
4930}
b4c3a85b
JJ		 4931
4932match
4933gfc_match_omp_ordered_depend (void)
4934{
4935 return match_omp (EXEC_OMP_ORDERED, omp_mask (OMP_CLAUSE_DEPEND));
6c7a4dfd
JJ		 4936}
4937
edf1eac2 4938
1fc5e7ef
TB		 4939/* omp atomic [clause-list]
4940 - atomic-clause: read | write | update
4941 - capture
4942 - memory-order-clause: seq_cst | acq_rel | release | acquire | relaxed
4943 - hint(hint-expr)
4944*/
4945
4946match
4947gfc_match_omp_atomic (void)
6c7a4dfd 4948{
1fc5e7ef
TB		 4949 gfc_omp_clauses *c;
4950 locus loc = gfc_current_locus;
4951
4952 if (gfc_match_omp_clauses (&c, OMP_ATOMIC_CLAUSES, true, true) != MATCH_YES)
4953 return MATCH_ERROR;
b2a31e2c
TB		 4954
4955 if (c->capture && c->atomic_op != GFC_OMP_ATOMIC_UNSET)
4956 gfc_error ("OMP ATOMIC at %L with multiple atomic clauses", &loc);
4957
1fc5e7ef
TB		 4958 if (c->atomic_op == GFC_OMP_ATOMIC_UNSET)
4959 c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
4960
1fc5e7ef 4961 if (c->memorder == OMP_MEMORDER_UNSET)
269322ec
TB		 4962 {
4963 gfc_namespace *prog_unit = gfc_current_ns;
4964 while (prog_unit->parent)
4965 prog_unit = prog_unit->parent;
4966 switch (prog_unit->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
4967 {
4968 case 0:
4969 case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED:
1fc5e7ef 4970 c->memorder = OMP_MEMORDER_RELAXED;
269322ec
TB		 4971 break;
4972 case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST:
1fc5e7ef 4973 c->memorder = OMP_MEMORDER_SEQ_CST;
269322ec
TB		 4974 break;
4975 case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL:
b2a31e2c
TB		 4976 if (c->capture)
4977 c->memorder = OMP_MEMORDER_ACQ_REL;
1fc5e7ef 4978 else if (c->atomic_op == GFC_OMP_ATOMIC_READ)
b2a31e2c 4979 c->memorder = OMP_MEMORDER_ACQUIRE;
1fc5e7ef 4980 else
b2a31e2c 4981 c->memorder = OMP_MEMORDER_RELEASE;
269322ec
TB		 4982 break;
4983 default:
4984 gcc_unreachable ();
4985 }
4986 }
1fc5e7ef
TB		 4987 else
4988 switch (c->atomic_op)
4989 {
4990 case GFC_OMP_ATOMIC_READ:
4991 if (c->memorder == OMP_MEMORDER_ACQ_REL
4992 || c->memorder == OMP_MEMORDER_RELEASE)
4993 {
4994 gfc_error ("!$OMP ATOMIC READ at %L incompatible with "
4995 "ACQ_REL or RELEASE clauses", &loc);
4996 c->memorder = OMP_MEMORDER_SEQ_CST;
4997 }
4998 break;
4999 case GFC_OMP_ATOMIC_WRITE:
5000 if (c->memorder == OMP_MEMORDER_ACQ_REL
5001 || c->memorder == OMP_MEMORDER_ACQUIRE)
5002 {
5003 gfc_error ("!$OMP ATOMIC WRITE at %L incompatible with "
5004 "ACQ_REL or ACQUIRE clauses", &loc);
5005 c->memorder = OMP_MEMORDER_SEQ_CST;
5006 }
5007 break;
5008 case GFC_OMP_ATOMIC_UPDATE:
b2a31e2c
TB		 5009 if ((c->memorder == OMP_MEMORDER_ACQ_REL
5010 || c->memorder == OMP_MEMORDER_ACQUIRE)
5011 && !c->capture)
1fc5e7ef
TB		 5012 {
5013 gfc_error ("!$OMP ATOMIC UPDATE at %L incompatible with "
5014 "ACQ_REL or ACQUIRE clauses", &loc);
5015 c->memorder = OMP_MEMORDER_SEQ_CST;
5016 }
5017 break;
5018 default:
5019 break;
5020 }
5021 gfc_error_check ();
5022 new_st.ext.omp_clauses = c;
5023 new_st.op = EXEC_OMP_ATOMIC;
6c7a4dfd
JJ		 5024 return MATCH_YES;
5025}
5026
1fc5e7ef 5027
c2e9f586 5028/* acc atomic [ read | write | update | capture] */
1fc5e7ef 5029
4bf9e5a8
TS		 5030match
5031gfc_match_oacc_atomic (void)
5032{
1fc5e7ef
TB		 5033 gfc_omp_clauses *c = gfc_get_omp_clauses ();
5034 c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
5035 c->memorder = OMP_MEMORDER_RELAXED;
5036 gfc_gobble_whitespace ();
c2e9f586 5037 if (gfc_match ("update") == MATCH_YES)
1fc5e7ef
TB		 5038 ;
5039 else if (gfc_match ("read") == MATCH_YES)
5040 c->atomic_op = GFC_OMP_ATOMIC_READ;
5041 else if (gfc_match ("write") == MATCH_YES)
5042 c->atomic_op = GFC_OMP_ATOMIC_WRITE;
5043 else if (gfc_match ("capture") == MATCH_YES)
5044 c->capture = true;
5045 gfc_gobble_whitespace ();
5046 if (gfc_match_omp_eos () != MATCH_YES)
5047 {
5048 gfc_error ("Unexpected junk after !$ACC ATOMIC statement at %C");
5049 gfc_free_omp_clauses (c);
5050 return MATCH_ERROR;
5051 }
5052 new_st.ext.omp_clauses = c;
5053 new_st.op = EXEC_OACC_ATOMIC;
5054 return MATCH_YES;
4bf9e5a8
TS		 5055}
5056
edf1eac2 5057
6c7a4dfd
JJ		 5058match
5059gfc_match_omp_barrier (void)
5060{
5061 if (gfc_match_omp_eos () != MATCH_YES)
edf86ec1
DF		 5062 {
5063 gfc_error ("Unexpected junk after $OMP BARRIER statement at %C");
5064 return MATCH_ERROR;
5065 }
6c7a4dfd
JJ		 5066 new_st.op = EXEC_OMP_BARRIER;
5067 new_st.ext.omp_clauses = NULL;
5068 return MATCH_YES;
5069}
5070
edf1eac2 5071
dd2fc525
JJ		 5072match
5073gfc_match_omp_taskgroup (void)
5074{
005cff4e 5075 return match_omp (EXEC_OMP_TASKGROUP, OMP_CLAUSE_TASK_REDUCTION);
dd2fc525
JJ		 5076}
5077
5078
5079static enum gfc_omp_cancel_kind
5080gfc_match_omp_cancel_kind (void)
5081{
5082 if (gfc_match_space () != MATCH_YES)
5083 return OMP_CANCEL_UNKNOWN;
5084 if (gfc_match ("parallel") == MATCH_YES)
5085 return OMP_CANCEL_PARALLEL;
5086 if (gfc_match ("sections") == MATCH_YES)
5087 return OMP_CANCEL_SECTIONS;
5088 if (gfc_match ("do") == MATCH_YES)
5089 return OMP_CANCEL_DO;
5090 if (gfc_match ("taskgroup") == MATCH_YES)
5091 return OMP_CANCEL_TASKGROUP;
5092 return OMP_CANCEL_UNKNOWN;
5093}
5094
5095
5096match
5097gfc_match_omp_cancel (void)
5098{
5099 gfc_omp_clauses *c;
5100 enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
5101 if (kind == OMP_CANCEL_UNKNOWN)
5102 return MATCH_ERROR;
b4c3a85b 5103 if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_IF), false) != MATCH_YES)
dd2fc525
JJ		 5104 return MATCH_ERROR;
5105 c->cancel = kind;
5106 new_st.op = EXEC_OMP_CANCEL;
5107 new_st.ext.omp_clauses = c;
5108 return MATCH_YES;
5109}
5110
5111
5112match
5113gfc_match_omp_cancellation_point (void)
5114{
5115 gfc_omp_clauses *c;
5116 enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
5117 if (kind == OMP_CANCEL_UNKNOWN)
f8d535f3
TB		 5118 {
5119 gfc_error ("Expected construct-type PARALLEL, SECTIONS, DO or TASKGROUP "
5120 "in $OMP CANCELLATION POINT statement at %C");
5121 return MATCH_ERROR;
5122 }
dd2fc525
JJ		 5123 if (gfc_match_omp_eos () != MATCH_YES)
5124 {
5125 gfc_error ("Unexpected junk after $OMP CANCELLATION POINT statement "
5126 "at %C");
5127 return MATCH_ERROR;
5128 }
5129 c = gfc_get_omp_clauses ();
5130 c->cancel = kind;
5131 new_st.op = EXEC_OMP_CANCELLATION_POINT;
5132 new_st.ext.omp_clauses = c;
5133 return MATCH_YES;
5134}
5135
5136
6c7a4dfd
JJ		 5137match
5138gfc_match_omp_end_nowait (void)
5139{
5140 bool nowait = false;
5141 if (gfc_match ("% nowait") == MATCH_YES)
5142 nowait = true;
5143 if (gfc_match_omp_eos () != MATCH_YES)
edf86ec1 5144 {
f8d535f3
TB		 5145 if (nowait)
5146 gfc_error ("Unexpected junk after NOWAIT clause at %C");
5147 else
5148 gfc_error ("Unexpected junk at %C");
edf86ec1
DF		 5149 return MATCH_ERROR;
5150 }
6c7a4dfd
JJ		 5151 new_st.op = EXEC_OMP_END_NOWAIT;
5152 new_st.ext.omp_bool = nowait;
5153 return MATCH_YES;
5154}
5155
edf1eac2 5156
41dbbb37
TS		 5157match
5158gfc_match_omp_end_single (void)
5159{
5160 gfc_omp_clauses *c;
5161 if (gfc_match ("% nowait") == MATCH_YES)
5162 {
5163 new_st.op = EXEC_OMP_END_NOWAIT;
5164 new_st.ext.omp_bool = true;
5165 return MATCH_YES;
5166 }
b4c3a85b
JJ		 5167 if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_COPYPRIVATE))
5168 != MATCH_YES)
41dbbb37
TS		 5169 return MATCH_ERROR;
5170 new_st.op = EXEC_OMP_END_SINGLE;
5171 new_st.ext.omp_clauses = c;
5172 return MATCH_YES;
5173}
5174
5175
5176static bool
5177oacc_is_loop (gfc_code *code)
5178{
5179 return code->op == EXEC_OACC_PARALLEL_LOOP
5180 || code->op == EXEC_OACC_KERNELS_LOOP
62aee289 5181 || code->op == EXEC_OACC_SERIAL_LOOP
41dbbb37
TS		 5182 || code->op == EXEC_OACC_LOOP;
5183}
5184
5185static void
b4c3a85b 5186resolve_scalar_int_expr (gfc_expr *expr, const char *clause)
41dbbb37
TS		 5187{
5188 if (!gfc_resolve_expr (expr)
b4c3a85b
JJ		 5189 || expr->ts.type != BT_INTEGER
5190 || expr->rank != 0)
41dbbb37 5191 gfc_error ("%s clause at %L requires a scalar INTEGER expression",
b4c3a85b 5192 clause, &expr->where);
41dbbb37
TS		 5193}
5194
41dbbb37 5195static void
b4c3a85b 5196resolve_positive_int_expr (gfc_expr *expr, const char *clause)
41dbbb37 5197{
b4c3a85b
JJ		 5198 resolve_scalar_int_expr (expr, clause);
5199 if (expr->expr_type == EXPR_CONSTANT
5200 && expr->ts.type == BT_INTEGER
5201 && mpz_sgn (expr->value.integer) <= 0)
db30e21c 5202 gfc_warning (0, "INTEGER expression of %s clause at %L must be positive",
b4c3a85b
JJ		 5203 clause, &expr->where);
5204}
5205
5206static void
5207resolve_nonnegative_int_expr (gfc_expr *expr, const char *clause)
5208{
5209 resolve_scalar_int_expr (expr, clause);
5210 if (expr->expr_type == EXPR_CONSTANT
5211 && expr->ts.type == BT_INTEGER
5212 && mpz_sgn (expr->value.integer) < 0)
5213 gfc_warning (0, "INTEGER expression of %s clause at %L must be "
5214 "non-negative", clause, &expr->where);
41dbbb37
TS		 5215}
5216
5217/* Emits error when symbol is pointer, cray pointer or cray pointee
5218 of derived of polymorphic type. */
5219
5220static void
5221check_symbol_not_pointer (gfc_symbol *sym, locus loc, const char *name)
5222{
41dbbb37 5223 if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointer)
ea6c757a 5224 gfc_error ("Cray pointer object %qs of derived type in %s clause at %L",
41dbbb37
TS		 5225 sym->name, name, &loc);
5226 if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointee)
2da189b6 5227 gfc_error ("Cray pointee object %qs of derived type in %s clause at %L",
41dbbb37
TS		 5228 sym->name, name, &loc);
5229
5230 if ((sym->ts.type == BT_ASSUMED && sym->attr.pointer)
5231 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
5232 && CLASS_DATA (sym)->attr.pointer))
9f584046 5233 gfc_error ("POINTER object %qs of polymorphic type in %s clause at %L",
41dbbb37
TS		 5234 sym->name, name, &loc);
5235 if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointer)
5236 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
5237 && CLASS_DATA (sym)->attr.cray_pointer))
2da189b6 5238 gfc_error ("Cray pointer object %qs of polymorphic type in %s clause at %L",
41dbbb37
TS		 5239 sym->name, name, &loc);
5240 if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointee)
5241 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
5242 && CLASS_DATA (sym)->attr.cray_pointee))
2da189b6 5243 gfc_error ("Cray pointee object %qs of polymorphic type in %s clause at %L",
41dbbb37
TS		 5244 sym->name, name, &loc);
5245}
5246
5247/* Emits error when symbol represents assumed size/rank array. */
5248
5249static void
5250check_array_not_assumed (gfc_symbol *sym, locus loc, const char *name)
5251{
5252 if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
9f584046 5253 gfc_error ("Assumed size array %qs in %s clause at %L",
41dbbb37
TS		 5254 sym->name, name, &loc);
5255 if (sym->as && sym->as->type == AS_ASSUMED_RANK)
9f584046 5256 gfc_error ("Assumed rank array %qs in %s clause at %L",
41dbbb37 5257 sym->name, name, &loc);
41dbbb37
TS		 5258}
5259
5260static void
5261resolve_oacc_data_clauses (gfc_symbol *sym, locus loc, const char *name)
5262{
41dbbb37
TS		 5263 check_array_not_assumed (sym, loc, name);
5264}
5265
5266static void
5267resolve_oacc_deviceptr_clause (gfc_symbol *sym, locus loc, const char *name)
6c7a4dfd 5268{
41dbbb37
TS		 5269 if (sym->attr.pointer
5270 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
5271 && CLASS_DATA (sym)->attr.class_pointer))
9f584046 5272 gfc_error ("POINTER object %qs in %s clause at %L",
41dbbb37
TS		 5273 sym->name, name, &loc);
5274 if (sym->attr.cray_pointer
5275 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
5276 && CLASS_DATA (sym)->attr.cray_pointer))
9f584046 5277 gfc_error ("Cray pointer object %qs in %s clause at %L",
41dbbb37
TS		 5278 sym->name, name, &loc);
5279 if (sym->attr.cray_pointee
5280 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
5281 && CLASS_DATA (sym)->attr.cray_pointee))
9f584046 5282 gfc_error ("Cray pointee object %qs in %s clause at %L",
41dbbb37
TS		 5283 sym->name, name, &loc);
5284 if (sym->attr.allocatable
5285 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
5286 && CLASS_DATA (sym)->attr.allocatable))
9f584046 5287 gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
41dbbb37
TS		 5288 sym->name, name, &loc);
5289 if (sym->attr.value)
9f584046 5290 gfc_error ("VALUE object %qs in %s clause at %L",
41dbbb37
TS		 5291 sym->name, name, &loc);
5292 check_array_not_assumed (sym, loc, name);
6c7a4dfd
JJ		 5293}
5294
edf1eac2 5295
b46ebd6c
JJ		 5296struct resolve_omp_udr_callback_data
5297{
5298 gfc_symbol *sym1, *sym2;
5299};
5300
5301
5302static int
5303resolve_omp_udr_callback (gfc_expr **e, int *, void *data)
5304{
5305 struct resolve_omp_udr_callback_data *rcd
5306 = (struct resolve_omp_udr_callback_data *) data;
5307 if ((*e)->expr_type == EXPR_VARIABLE
5308 && ((*e)->symtree->n.sym == rcd->sym1
5309 || (*e)->symtree->n.sym == rcd->sym2))
5310 {
5311 gfc_ref *ref = gfc_get_ref ();
5312 ref->type = REF_ARRAY;
5313 ref->u.ar.where = (*e)->where;
5314 ref->u.ar.as = (*e)->symtree->n.sym->as;
5315 ref->u.ar.type = AR_FULL;
5316 ref->u.ar.dimen = 0;
5317 ref->next = (*e)->ref;
5318 (*e)->ref = ref;
5319 }
5320 return 0;
5321}
5322
5323
5324static int
5325resolve_omp_udr_callback2 (gfc_expr **e, int *, void *)
5326{
5327 if ((*e)->expr_type == EXPR_FUNCTION
5328 && (*e)->value.function.isym == NULL)
5329 {
5330 gfc_symbol *sym = (*e)->symtree->n.sym;
5331 if (!sym->attr.intrinsic
5332 && sym->attr.if_source == IFSRC_UNKNOWN)
5333 gfc_error ("Implicitly declared function %s used in "
2f029c08 5334 "!$OMP DECLARE REDUCTION at %L", sym->name, &(*e)->where);
b46ebd6c
JJ		 5335 }
5336 return 0;
5337}
5338
5339
5340static gfc_code *
5341resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns,
5342 gfc_symbol *sym1, gfc_symbol *sym2)
5343{
5344 gfc_code *copy;
5345 gfc_symbol sym1_copy, sym2_copy;
5346
5347 if (ns->code->op == EXEC_ASSIGN)
5348 {
5349 copy = gfc_get_code (EXEC_ASSIGN);
5350 copy->expr1 = gfc_copy_expr (ns->code->expr1);
5351 copy->expr2 = gfc_copy_expr (ns->code->expr2);
5352 }
5353 else
5354 {
5355 copy = gfc_get_code (EXEC_CALL);
5356 copy->symtree = ns->code->symtree;
5357 copy->ext.actual = gfc_copy_actual_arglist (ns->code->ext.actual);
5358 }
5359 copy->loc = ns->code->loc;
5360 sym1_copy = *sym1;
5361 sym2_copy = *sym2;
5362 *sym1 = *n->sym;
5363 *sym2 = *n->sym;
5364 sym1->name = sym1_copy.name;
5365 sym2->name = sym2_copy.name;
5366 ns->proc_name = ns->parent->proc_name;
5367 if (n->sym->attr.dimension)
5368 {
5369 struct resolve_omp_udr_callback_data rcd;
5370 rcd.sym1 = sym1;
5371 rcd.sym2 = sym2;
5372 gfc_code_walker (&copy, gfc_dummy_code_callback,
5373 resolve_omp_udr_callback, &rcd);
5374 }
5375 gfc_resolve_code (copy, gfc_current_ns);
5376 if (copy->op == EXEC_CALL && copy->resolved_isym == NULL)
5377 {
5378 gfc_symbol *sym = copy->resolved_sym;
5379 if (sym
5380 && !sym->attr.intrinsic
5381 && sym->attr.if_source == IFSRC_UNKNOWN)
5382 gfc_error ("Implicitly declared subroutine %s used in "
2f029c08 5383 "!$OMP DECLARE REDUCTION at %L", sym->name,
b46ebd6c
JJ		 5384 &copy->loc);
5385 }
5386 gfc_code_walker (&copy, gfc_dummy_code_callback,
5387 resolve_omp_udr_callback2, NULL);
5388 *sym1 = sym1_copy;
5389 *sym2 = sym2_copy;
5390 return copy;
5391}
5392
6c7a4dfd
JJ		 5393/* OpenMP directive resolving routines. */
5394
5395static void
2ac33bca
CP		 5396resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
5397 gfc_namespace *ns, bool openacc = false)
6c7a4dfd 5398{
dd2fc525 5399 gfc_omp_namelist *n;
41dbbb37 5400 gfc_expr_list *el;
6c7a4dfd 5401 int list;
b4c3a85b
JJ		 5402 int ifc;
5403 bool if_without_mod = false;
5404 gfc_omp_linear_op linear_op = OMP_LINEAR_DEFAULT;
6c7a4dfd
JJ		 5405 static const char *clause_names[]
5406 = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
9a5de4d5 5407 "COPYIN", "UNIFORM", "AFFINITY", "ALIGNED", "LINEAR", "DEPEND", "MAP",
005cff4e
TB		 5408 "TO", "FROM", "INCLUSIVE", "EXCLUSIVE",
5409 "REDUCTION", "REDUCTION" /*inscan*/, "REDUCTION" /*task*/,
e929ef53
TB		 5410 "IN_REDUCTION", "TASK_REDUCTION",
5411 "DEVICE_RESIDENT", "LINK", "USE_DEVICE",
5625b2c5
ML		 5412 "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR",
5413 "NONTEMPORAL" };
929c4051 5414 STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM);
6c7a4dfd
JJ		 5415
5416 if (omp_clauses == NULL)
5417 return;
5418
b4c3a85b
JJ		 5419 if (omp_clauses->orderedc && omp_clauses->orderedc < omp_clauses->collapse)
5420 gfc_error ("ORDERED clause parameter is less than COLLAPSE at %L",
5421 &code->loc);
5422
6c7a4dfd
JJ		 5423 if (omp_clauses->if_expr)
5424 {
5425 gfc_expr *expr = omp_clauses->if_expr;
524af0d6 5426 if (!gfc_resolve_expr (expr)
6c7a4dfd
JJ		 5427 || expr->ts.type != BT_LOGICAL || expr->rank != 0)
5428 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
5429 &expr->where);
b4c3a85b 5430 if_without_mod = true;
6c7a4dfd 5431 }
b4c3a85b
JJ		 5432 for (ifc = 0; ifc < OMP_IF_LAST; ifc++)
5433 if (omp_clauses->if_exprs[ifc])
5434 {
5435 gfc_expr *expr = omp_clauses->if_exprs[ifc];
5436 bool ok = true;
5437 if (!gfc_resolve_expr (expr)
5438 || expr->ts.type != BT_LOGICAL || expr->rank != 0)
5439 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
5440 &expr->where);
5441 else if (if_without_mod)
5442 {
bd2c6270 5443 gfc_error ("IF clause without modifier at %L used together with "
b4c3a85b
JJ		 5444 "IF clauses with modifiers",
5445 &omp_clauses->if_expr->where);
5446 if_without_mod = false;
5447 }
5448 else
5449 switch (code->op)
5450 {
e55ba804
TB		 5451 case EXEC_OMP_CANCEL:
5452 ok = ifc == OMP_IF_CANCEL;
5453 break;
5454
b4c3a85b
JJ		 5455 case EXEC_OMP_PARALLEL:
5456 case EXEC_OMP_PARALLEL_DO:
53d5b59c 5457 case EXEC_OMP_PARALLEL_MASKED:
0e3702f8 5458 case EXEC_OMP_PARALLEL_MASTER:
b4c3a85b
JJ		 5459 case EXEC_OMP_PARALLEL_SECTIONS:
5460 case EXEC_OMP_PARALLEL_WORKSHARE:
b4c3a85b 5461 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
b4c3a85b 5462 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
b4c3a85b
JJ		 5463 ok = ifc == OMP_IF_PARALLEL;
5464 break;
5465
e55ba804
TB		 5466 case EXEC_OMP_PARALLEL_DO_SIMD:
5467 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
5468 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5469 ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_SIMD;
5470 break;
5471
53d5b59c 5472 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
f6bf436d
TB		 5473 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
5474 ok = ifc == OMP_IF_PARALLEL || ifc == OMP_IF_TASKLOOP;
5475 break;
5476
53d5b59c 5477 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
f6bf436d
TB		 5478 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
5479 ok = (ifc == OMP_IF_PARALLEL
5480 || ifc == OMP_IF_TASKLOOP
5481 || ifc == OMP_IF_SIMD);
5482 break;
5483
e55ba804
TB		 5484 case EXEC_OMP_SIMD:
5485 case EXEC_OMP_DO_SIMD:
5486 case EXEC_OMP_DISTRIBUTE_SIMD:
5487 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
5488 ok = ifc == OMP_IF_SIMD;
5489 break;
5490
b4c3a85b
JJ		 5491 case EXEC_OMP_TASK:
5492 ok = ifc == OMP_IF_TASK;
5493 break;
5494
5495 case EXEC_OMP_TASKLOOP:
53d5b59c 5496 case EXEC_OMP_MASKED_TASKLOOP:
f6bf436d 5497 case EXEC_OMP_MASTER_TASKLOOP:
b4c3a85b
JJ		 5498 ok = ifc == OMP_IF_TASKLOOP;
5499 break;
5500
e55ba804 5501 case EXEC_OMP_TASKLOOP_SIMD:
53d5b59c 5502 case EXEC_OMP_MASKED_TASKLOOP_SIMD:
f6bf436d 5503 case EXEC_OMP_MASTER_TASKLOOP_SIMD:
e55ba804
TB		 5504 ok = ifc == OMP_IF_TASKLOOP || ifc == OMP_IF_SIMD;
5505 break;
5506
b4c3a85b
JJ		 5507 case EXEC_OMP_TARGET:
5508 case EXEC_OMP_TARGET_TEAMS:
5509 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
e55ba804
TB		 5510 ok = ifc == OMP_IF_TARGET;
5511 break;
5512
b4c3a85b
JJ		 5513 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
5514 case EXEC_OMP_TARGET_SIMD:
e55ba804 5515 ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_SIMD;
b4c3a85b
JJ		 5516 break;
5517
5518 case EXEC_OMP_TARGET_DATA:
5519 ok = ifc == OMP_IF_TARGET_DATA;
5520 break;
5521
5522 case EXEC_OMP_TARGET_UPDATE:
5523 ok = ifc == OMP_IF_TARGET_UPDATE;
5524 break;
5525
5526 case EXEC_OMP_TARGET_ENTER_DATA:
5527 ok = ifc == OMP_IF_TARGET_ENTER_DATA;
5528 break;
5529
5530 case EXEC_OMP_TARGET_EXIT_DATA:
5531 ok = ifc == OMP_IF_TARGET_EXIT_DATA;
5532 break;
5533
5534 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
b4c3a85b
JJ		 5535 case EXEC_OMP_TARGET_PARALLEL:
5536 case EXEC_OMP_TARGET_PARALLEL_DO:
b4c3a85b
JJ		 5537 ok = ifc == OMP_IF_TARGET || ifc == OMP_IF_PARALLEL;
5538 break;
5539
e55ba804
TB		 5540 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
5541 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5542 ok = (ifc == OMP_IF_TARGET
5543 || ifc == OMP_IF_PARALLEL
5544 || ifc == OMP_IF_SIMD);
5545 break;
5546
b4c3a85b
JJ		 5547 default:
5548 ok = false;
5549 break;
5550 }
5551 if (!ok)
5552 {
5553 static const char *ifs[] = {
e55ba804 5554 "CANCEL",
b4c3a85b 5555 "PARALLEL",
e55ba804 5556 "SIMD",
b4c3a85b
JJ		 5557 "TASK",
5558 "TASKLOOP",
5559 "TARGET",
5560 "TARGET DATA",
5561 "TARGET UPDATE",
5562 "TARGET ENTER DATA",
5563 "TARGET EXIT DATA"
5564 };
5565 gfc_error ("IF clause modifier %s at %L not appropriate for "
5566 "the current OpenMP construct", ifs[ifc], &expr->where);
5567 }
5568 }
5569
20906c66
JJ		 5570 if (omp_clauses->final_expr)
5571 {
5572 gfc_expr *expr = omp_clauses->final_expr;
524af0d6 5573 if (!gfc_resolve_expr (expr)
20906c66
JJ		 5574 || expr->ts.type != BT_LOGICAL || expr->rank != 0)
5575 gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression",
5576 &expr->where);
5577 }
6c7a4dfd 5578 if (omp_clauses->num_threads)
b4c3a85b 5579 resolve_positive_int_expr (omp_clauses->num_threads, "NUM_THREADS");
6c7a4dfd
JJ		 5580 if (omp_clauses->chunk_size)
5581 {
5582 gfc_expr *expr = omp_clauses->chunk_size;
524af0d6 5583 if (!gfc_resolve_expr (expr)
6c7a4dfd 5584 || expr->ts.type != BT_INTEGER || expr->rank != 0)
edf1eac2
SK		 5585 gfc_error ("SCHEDULE clause's chunk_size at %L requires "
5586 "a scalar INTEGER expression", &expr->where);
7211a097
JJ		 5587 else if (expr->expr_type == EXPR_CONSTANT
5588 && expr->ts.type == BT_INTEGER
5589 && mpz_sgn (expr->value.integer) <= 0)
5590 gfc_warning (0, "INTEGER expression of SCHEDULE clause's chunk_size "
5591 "at %L must be positive", &expr->where);
6c7a4dfd 5592 }
37bc33f7
JJ		 5593 if (omp_clauses->sched_kind != OMP_SCHED_NONE
5594 && omp_clauses->sched_nonmonotonic)
5595 {
e929ef53 5596 if (omp_clauses->sched_monotonic)
37bc33f7
JJ		 5597 gfc_error ("Both MONOTONIC and NONMONOTONIC schedule modifiers "
5598 "specified at %L", &code->loc);
5599 else if (omp_clauses->ordered)
5600 gfc_error ("NONMONOTONIC schedule modifier specified with ORDERED "
5601 "clause at %L", &code->loc);
5602 }
6c7a4dfd 5603
a61c4964
TB		 5604 if (omp_clauses->depobj
5605 && (!gfc_resolve_expr (omp_clauses->depobj)
5606 || omp_clauses->depobj->ts.type != BT_INTEGER
5607 || omp_clauses->depobj->ts.kind != 2 * gfc_index_integer_kind
5608 || omp_clauses->depobj->rank != 0))
5609 gfc_error ("DEPOBJ in DEPOBJ construct at %L shall be a scalar integer "
5610 "of OMP_DEPEND_KIND kind", &omp_clauses->depobj->where);
5611
6c7a4dfd
JJ		 5612 /* Check that no symbol appears on multiple clauses, except that
5613 a symbol can appear on both firstprivate and lastprivate. */
5614 for (list = 0; list < OMP_LIST_NUM; list++)
5615 for (n = omp_clauses->lists[list]; n; n = n->next)
637b5a8e
JJ		 5616 {
5617 n->sym->mark = 0;
278c3214 5618 n->sym->comp_mark = 0;
dd2fc525
JJ		 5619 if (n->sym->attr.flavor == FL_VARIABLE
5620 || n->sym->attr.proc_pointer
5621 || (!code && (!n->sym->attr.dummy || n->sym->ns != ns)))
5622 {
5623 if (!code && (!n->sym->attr.dummy || n->sym->ns != ns))
a4d9b221 5624 gfc_error ("Variable %qs is not a dummy argument at %L",
d057afcd 5625 n->sym->name, &n->where);
dd2fc525
JJ		 5626 continue;
5627 }
637b5a8e
JJ		 5628 if (n->sym->attr.flavor == FL_PROCEDURE
5629 && n->sym->result == n->sym
5630 && n->sym->attr.function)
5631 {
5632 if (gfc_current_ns->proc_name == n->sym
5633 || (gfc_current_ns->parent
5634 && gfc_current_ns->parent->proc_name == n->sym))
5635 continue;
5636 if (gfc_current_ns->proc_name->attr.entry_master)
5637 {
5638 gfc_entry_list *el = gfc_current_ns->entries;
5639 for (; el; el = el->next)
5640 if (el->sym == n->sym)
5641 break;
5642 if (el)
5643 continue;
5644 }
5645 if (gfc_current_ns->parent
5646 && gfc_current_ns->parent->proc_name->attr.entry_master)
5647 {
5648 gfc_entry_list *el = gfc_current_ns->parent->entries;
5649 for (; el; el = el->next)
5650 if (el->sym == n->sym)
5651 break;
5652 if (el)
5653 continue;
5654 }
5655 }
6e158c5f
AS		 5656 if (list == OMP_LIST_MAP
5657 && n->sym->attr.flavor == FL_PARAMETER)
5658 {
5659 if (openacc)
5660 gfc_error ("Object %qs is not a variable at %L; parameters"
5661 " cannot be and need not be copied", n->sym->name,
5662 &n->where);
5663 else
5664 gfc_error ("Object %qs is not a variable at %L; parameters"
5665 " cannot be and need not be mapped", n->sym->name,
5666 &n->where);
5667 }
5668 else
5669 gfc_error ("Object %qs is not a variable at %L", n->sym->name,
5670 &n->where);
637b5a8e 5671 }
005cff4e
TB		 5672 if (omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]
5673 && code->op != EXEC_OMP_DO
5674 && code->op != EXEC_OMP_SIMD
5675 && code->op != EXEC_OMP_DO_SIMD
5676 && code->op != EXEC_OMP_PARALLEL_DO
5677 && code->op != EXEC_OMP_PARALLEL_DO_SIMD)
5678 gfc_error ("%<inscan%> REDUCTION clause on construct other than DO, SIMD, "
5679 "DO SIMD, PARALLEL DO, PARALLEL DO SIMD at %L",
5680 &omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where);
6c7a4dfd
JJ		 5681
5682 for (list = 0; list < OMP_LIST_NUM; list++)
dd2fc525
JJ		 5683 if (list != OMP_LIST_FIRSTPRIVATE
5684 && list != OMP_LIST_LASTPRIVATE
5685 && list != OMP_LIST_ALIGNED
f014c653 5686 && list != OMP_LIST_DEPEND
41dbbb37 5687 && (list != OMP_LIST_MAP || openacc)
f014c653 5688 && list != OMP_LIST_FROM
7a5e4956 5689 && list != OMP_LIST_TO
e929ef53
TB		 5690 && (list != OMP_LIST_REDUCTION || !openacc)
5691 && list != OMP_LIST_REDUCTION_INSCAN
5692 && list != OMP_LIST_REDUCTION_TASK
5693 && list != OMP_LIST_IN_REDUCTION
5694 && list != OMP_LIST_TASK_REDUCTION)
6c7a4dfd 5695 for (n = omp_clauses->lists[list]; n; n = n->next)
acaed831 5696 {
278c3214
JB		 5697 bool component_ref_p = false;
5698
5699 /* Allow multiple components of the same (e.g. derived-type)
5700 variable here. Duplicate components are detected elsewhere. */
5701 if (n->expr && n->expr->expr_type == EXPR_VARIABLE)
549188ea 5702 for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
278c3214
JB		 5703 if (ref->type == REF_COMPONENT)
5704 component_ref_p = true;
5705 if ((!component_ref_p && n->sym->comp_mark)
5706 || (component_ref_p && n->sym->mark))
5707 gfc_error ("Symbol %qs has mixed component and non-component "
5708 "accesses at %L", n->sym->name, &n->where);
5709 else if (n->sym->mark)
5710 gfc_error ("Symbol %qs present on multiple clauses at %L",
5711 n->sym->name, &n->where);
5712 else
549188ea 5713 {
278c3214
JB		 5714 if (component_ref_p)
5715 n->sym->comp_mark = 1;
549188ea
JB		 5716 else
5717 n->sym->mark = 1;
5718 }
acaed831 5719 }
6c7a4dfd
JJ		 5720
5721 gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1);
5722 for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE; list++)
5723 for (n = omp_clauses->lists[list]; n; n = n->next)
5724 if (n->sym->mark)
5725 {
a4d9b221 5726 gfc_error ("Symbol %qs present on multiple clauses at %L",
2ac33bca 5727 n->sym->name, &n->where);
6c7a4dfd
JJ		 5728 n->sym->mark = 0;
5729 }
5730
5731 for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next)
acaed831
KT		 5732 {
5733 if (n->sym->mark)
a4d9b221 5734 gfc_error ("Symbol %qs present on multiple clauses at %L",
2ac33bca 5735 n->sym->name, &n->where);
acaed831
KT		 5736 else
5737 n->sym->mark = 1;
5738 }
6c7a4dfd
JJ		 5739 for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
5740 n->sym->mark = 0;
5741
5742 for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
acaed831
KT		 5743 {
5744 if (n->sym->mark)
a4d9b221 5745 gfc_error ("Symbol %qs present on multiple clauses at %L",
2ac33bca 5746 n->sym->name, &n->where);
acaed831
KT		 5747 else
5748 n->sym->mark = 1;
5749 }
dd2fc525
JJ		 5750
5751 for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
5752 n->sym->mark = 0;
5753
5754 for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
5755 {
5756 if (n->sym->mark)
a4d9b221 5757 gfc_error ("Symbol %qs present on multiple clauses at %L",
2ac33bca 5758 n->sym->name, &n->where);
dd2fc525
JJ		 5759 else
5760 n->sym->mark = 1;
5761 }
5762
7a5e4956
CP		 5763 /* OpenACC reductions. */
5764 if (openacc)
5765 {
5766 for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next)
5767 n->sym->mark = 0;
5768
5769 for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next)
5770 {
5771 if (n->sym->mark)
5772 gfc_error ("Symbol %qs present on multiple clauses at %L",
5773 n->sym->name, &n->where);
5774 else
5775 n->sym->mark = 1;
2f9bcf53
CP		 5776
5777 /* OpenACC does not support reductions on arrays. */
5778 if (n->sym->as)
5779 gfc_error ("Array %qs is not permitted in reduction at %L",
5780 n->sym->name, &n->where);
7a5e4956
CP		 5781 }
5782 }
5783
f014c653
JJ		 5784 for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
5785 n->sym->mark = 0;
5786 for (n = omp_clauses->lists[OMP_LIST_FROM]; n; n = n->next)
5787 if (n->expr == NULL)
5788 n->sym->mark = 1;
5789 for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
5790 {
5791 if (n->expr == NULL && n->sym->mark)
a4d9b221 5792 gfc_error ("Symbol %qs present on both FROM and TO clauses at %L",
2ac33bca 5793 n->sym->name, &n->where);
f014c653
JJ		 5794 else
5795 n->sym->mark = 1;
5796 }
5797
005cff4e 5798 bool has_inscan = false, has_notinscan = false;
6c7a4dfd
JJ		 5799 for (list = 0; list < OMP_LIST_NUM; list++)
5800 if ((n = omp_clauses->lists[list]) != NULL)
5801 {
929c4051 5802 const char *name = clause_names[list];
6c7a4dfd
JJ		 5803
5804 switch (list)
5805 {
5806 case OMP_LIST_COPYIN:
5807 for (; n != NULL; n = n->next)
5808 {
5809 if (!n->sym->attr.threadprivate)
a4d9b221 5810 gfc_error ("Non-THREADPRIVATE object %qs in COPYIN clause"
2ac33bca 5811 " at %L", n->sym->name, &n->where);
6c7a4dfd
JJ		 5812 }
5813 break;
5814 case OMP_LIST_COPYPRIVATE:
5815 for (; n != NULL; n = n->next)
5816 {
5817 if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
a4d9b221 5818 gfc_error ("Assumed size array %qs in COPYPRIVATE clause "
2ac33bca 5819 "at %L", n->sym->name, &n->where);
92d28cbb 5820 if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
a4d9b221 5821 gfc_error ("INTENT(IN) POINTER %qs in COPYPRIVATE clause "
2ac33bca 5822 "at %L", n->sym->name, &n->where);
6c7a4dfd
JJ		 5823 }
5824 break;
5825 case OMP_LIST_SHARED:
5826 for (; n != NULL; n = n->next)
5827 {
5828 if (n->sym->attr.threadprivate)
a4d9b221 5829 gfc_error ("THREADPRIVATE object %qs in SHARED clause at "
2ac33bca 5830 "%L", n->sym->name, &n->where);
6c7a4dfd 5831 if (n->sym->attr.cray_pointee)
a4d9b221 5832 gfc_error ("Cray pointee %qs in SHARED clause at %L",
2ac33bca 5833 n->sym->name, &n->where);
92d28cbb 5834 if (n->sym->attr.associate_var)
a4d9b221 5835 gfc_error ("ASSOCIATE name %qs in SHARED clause at %L",
2ac33bca 5836 n->sym->name, &n->where);
a6d22fb2
KCY		 5837 if (omp_clauses->detach
5838 && n->sym == omp_clauses->detach->symtree->n.sym)
5839 gfc_error ("DETACH event handle %qs in SHARED clause at %L",
5840 n->sym->name, &n->where);
dd2fc525
JJ		 5841 }
5842 break;
5843 case OMP_LIST_ALIGNED:
5844 for (; n != NULL; n = n->next)
5845 {
5846 if (!n->sym->attr.pointer
5847 && !n->sym->attr.allocatable
5848 && !n->sym->attr.cray_pointer
5849 && (n->sym->ts.type != BT_DERIVED
5850 || (n->sym->ts.u.derived->from_intmod
5851 != INTMOD_ISO_C_BINDING)
5852 || (n->sym->ts.u.derived->intmod_sym_id
5853 != ISOCBINDING_PTR)))
a4d9b221 5854 gfc_error ("%qs in ALIGNED clause must be POINTER, "
dd2fc525 5855 "ALLOCATABLE, Cray pointer or C_PTR at %L",
2ac33bca 5856 n->sym->name, &n->where);
dd2fc525
JJ		 5857 else if (n->expr)
5858 {
5859 gfc_expr *expr = n->expr;
5860 int alignment = 0;
5861 if (!gfc_resolve_expr (expr)
5862 || expr->ts.type != BT_INTEGER
5863 || expr->rank != 0
5864 || gfc_extract_int (expr, &alignment)
5865 || alignment <= 0)
a4d9b221 5866 gfc_error ("%qs in ALIGNED clause at %L requires a scalar "
dd2fc525 5867 "positive constant integer alignment "
2ac33bca 5868 "expression", n->sym->name, &n->where);
dd2fc525 5869 }
6c7a4dfd
JJ		 5870 }
5871 break;
9a5de4d5 5872 case OMP_LIST_AFFINITY:
f014c653
JJ		 5873 case OMP_LIST_DEPEND:
5874 case OMP_LIST_MAP:
5875 case OMP_LIST_TO:
5876 case OMP_LIST_FROM:
33497fd2 5877 case OMP_LIST_CACHE:
dd2fc525 5878 for (; n != NULL; n = n->next)
41dbbb37 5879 {
9a5de4d5
TB		 5880 if ((list == OMP_LIST_DEPEND || list == OMP_LIST_AFFINITY)
5881 && n->u2.ns && !n->u2.ns->resolved)
5882 {
5883 n->u2.ns->resolved = 1;
5884 for (gfc_symbol *sym = n->u2.ns->proc_name; sym;
5885 sym = sym->tlink)
5886 {
5887 gfc_constructor *c;
5888 c = gfc_constructor_first (sym->value->value.constructor);
5889 if (!gfc_resolve_expr (c->expr)
5890 || c->expr->ts.type != BT_INTEGER
5891 || c->expr->rank != 0)
5892 gfc_error ("Scalar integer expression for range begin"
5893 " expected at %L", &c->expr->where);
5894 c = gfc_constructor_next (c);
5895 if (!gfc_resolve_expr (c->expr)
5896 || c->expr->ts.type != BT_INTEGER
5897 || c->expr->rank != 0)
5898 gfc_error ("Scalar integer expression for range end "
5899 "expected at %L", &c->expr->where);
5900 c = gfc_constructor_next (c);
5901 if (c && (!gfc_resolve_expr (c->expr)
5902 || c->expr->ts.type != BT_INTEGER
5903 || c->expr->rank != 0))
5904 gfc_error ("Scalar integer expression for range step "
5905 "expected at %L", &c->expr->where);
5906 else if (c
5907 && c->expr->expr_type == EXPR_CONSTANT
5908 && mpz_cmp_si (c->expr->value.integer, 0) == 0)
5909 gfc_error ("Nonzero range step expected at %L",
5910 &c->expr->where);
5911 }
5912 }
5913
b4c3a85b
JJ		 5914 if (list == OMP_LIST_DEPEND)
5915 {
5916 if (n->u.depend_op == OMP_DEPEND_SINK_FIRST
5917 || n->u.depend_op == OMP_DEPEND_SINK)
5918 {
5919 if (code->op != EXEC_OMP_ORDERED)
5920 gfc_error ("SINK dependence type only allowed "
5921 "on ORDERED directive at %L", &n->where);
5922 else if (omp_clauses->depend_source)
5923 {
5924 gfc_error ("DEPEND SINK used together with "
5925 "DEPEND SOURCE on the same construct "
5926 "at %L", &n->where);
5927 omp_clauses->depend_source = false;
5928 }
5929 else if (n->expr)
5930 {
5931 if (!gfc_resolve_expr (n->expr)
5932 || n->expr->ts.type != BT_INTEGER
5933 || n->expr->rank != 0)
bd2c6270 5934 gfc_error ("SINK addend not a constant integer "
b4c3a85b
JJ		 5935 "at %L", &n->where);
5936 }
5937 continue;
5938 }
5939 else if (code->op == EXEC_OMP_ORDERED)
5940 gfc_error ("Only SOURCE or SINK dependence types "
5941 "are allowed on ORDERED directive at %L",
5942 &n->where);
a61c4964
TB		 5943 else if (n->u.depend_op == OMP_DEPEND_DEPOBJ
5944 && !n->expr
5945 && (n->sym->ts.type != BT_INTEGER
5946 || n->sym->ts.kind
5947 != 2 * gfc_index_integer_kind
5948 || n->sym->attr.dimension))
5949 gfc_error ("Locator %qs at %L in DEPEND clause of depobj "
5950 "type shall be a scalar integer of "
5951 "OMP_DEPEND_KIND kind", n->sym->name,
5952 &n->where);
5953 else if (n->u.depend_op == OMP_DEPEND_DEPOBJ
5954 && n->expr
5955 && (!gfc_resolve_expr (n->expr)
5956 || n->expr->ts.type != BT_INTEGER
5957 || n->expr->ts.kind
5958 != 2 * gfc_index_integer_kind
5959 || n->expr->rank != 0))
5960 gfc_error ("Locator at %L in DEPEND clause of depobj "
5961 "type shall be a scalar integer of "
5962 "OMP_DEPEND_KIND kind", &n->expr->where);
b4c3a85b 5963 }
366cf112 5964 gfc_ref *lastref = NULL, *lastslice = NULL;
549188ea 5965 bool resolved = false;
41dbbb37
TS		 5966 if (n->expr)
5967 {
366cf112 5968 lastref = n->expr->ref;
549188ea
JB		 5969 resolved = gfc_resolve_expr (n->expr);
5970
5971 /* Look through component refs to find last array
5972 reference. */
102502e3 5973 if (resolved)
a5ed4958 5974 {
366cf112
JB		 5975 for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
5976 if (ref->type == REF_COMPONENT
5977 || ref->type == REF_SUBSTRING
5978 || ref->type == REF_INQUIRY)
5979 lastref = ref;
5980 else if (ref->type == REF_ARRAY)
5981 {
5982 for (int i = 0; i < ref->u.ar.dimen; i++)
5983 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE)
5984 lastslice = ref;
5985
5986 lastref = ref;
5987 }
5988
a5ed4958
JB		 5989 /* The "!$acc cache" directive allows rectangular
5990 subarrays to be specified, with some restrictions
5991 on the form of bounds (not implemented).
5992 Only raise an error here if we're really sure the
5993 array isn't contiguous. An expression such as
5994 arr(-n:n,-n:n) could be contiguous even if it looks
5995 like it may not be. */
366cf112
JB		 5996 if (code->op != EXEC_OACC_UPDATE
5997 && list != OMP_LIST_CACHE
102502e3 5998 && list != OMP_LIST_DEPEND
a5ed4958 5999 && !gfc_is_simply_contiguous (n->expr, false, true)
366cf112
JB		 6000 && gfc_is_not_contiguous (n->expr)
6001 && !(lastslice
6002 && (lastslice->next
6003 || lastslice->type != REF_ARRAY)))
a5ed4958
JB		 6004 gfc_error ("Array is not contiguous at %L",
6005 &n->where);
a5ed4958 6006 }
549188ea 6007 }
366cf112 6008 if (lastref
549188ea
JB		 6009 || (n->expr
6010 && (!resolved || n->expr->expr_type != EXPR_VARIABLE)))
6011 {
366cf112
JB		 6012 if (!lastslice
6013 && lastref
6014 && lastref->type == REF_SUBSTRING)
f0e618fa
TB		 6015 gfc_error ("Unexpected substring reference in %s clause "
6016 "at %L", name, &n->where);
366cf112
JB		 6017 else if (!lastslice
6018 && lastref
6019 && lastref->type == REF_INQUIRY)
799478b8 6020 {
366cf112
JB		 6021 gcc_assert (lastref->u.i == INQUIRY_RE
6022 || lastref->u.i == INQUIRY_IM);
799478b8
TB		 6023 gfc_error ("Unexpected complex-parts designator "
6024 "reference in %s clause at %L",
6025 name, &n->where);
6026 }
f0e618fa 6027 else if (!resolved
366cf112
JB		 6028 || n->expr->expr_type != EXPR_VARIABLE
6029 || (lastslice
6030 && (lastslice->next
6031 || lastslice->type != REF_ARRAY)))
41dbbb37 6032 gfc_error ("%qs in %s clause at %L is not a proper "
2ac33bca
CP		 6033 "array section", n->sym->name, name,
6034 &n->where);
366cf112 6035 else if (lastslice)
41dbbb37
TS		 6036 {
6037 int i;
366cf112 6038 gfc_array_ref *ar = &lastslice->u.ar;
41dbbb37 6039 for (i = 0; i < ar->dimen; i++)
366cf112 6040 if (ar->stride[i] && code->op != EXEC_OACC_UPDATE)
41dbbb37
TS		 6041 {
6042 gfc_error ("Stride should not be specified for "
6043 "array section in %s clause at %L",
2ac33bca 6044 name, &n->where);
41dbbb37
TS		 6045 break;
6046 }
6047 else if (ar->dimen_type[i] != DIMEN_ELEMENT
6048 && ar->dimen_type[i] != DIMEN_RANGE)
6049 {
6050 gfc_error ("%qs in %s clause at %L is not a "
6051 "proper array section",
2ac33bca 6052 n->sym->name, name, &n->where);
41dbbb37
TS		 6053 break;
6054 }
9a5de4d5
TB		 6055 else if ((list == OMP_LIST_DEPEND
6056 || list == OMP_LIST_AFFINITY)
41dbbb37
TS		 6057 && ar->start[i]
6058 && ar->start[i]->expr_type == EXPR_CONSTANT
6059 && ar->end[i]
6060 && ar->end[i]->expr_type == EXPR_CONSTANT
6061 && mpz_cmp (ar->start[i]->value.integer,
6062 ar->end[i]->value.integer) > 0)
6063 {
9a5de4d5 6064 gfc_error ("%qs in %s clause at %L is a "
41dbbb37 6065 "zero size array section",
9a5de4d5
TB		 6066 n->sym->name,
6067 list == OMP_LIST_DEPEND
6068 ? "DEPEND" : "AFFINITY", &n->where);
41dbbb37
TS		 6069 break;
6070 }
6071 }
6072 }
6073 else if (openacc)
6074 {
6075 if (list == OMP_LIST_MAP
6076 && n->u.map_op == OMP_MAP_FORCE_DEVICEPTR)
2ac33bca 6077 resolve_oacc_deviceptr_clause (n->sym, n->where, name);
41dbbb37 6078 else
2ac33bca 6079 resolve_oacc_data_clauses (n->sym, n->where, name);
41dbbb37 6080 }
aad16012 6081 else if (list != OMP_LIST_DEPEND
4e2044d6
JJ		 6082 && n->sym->as
6083 && n->sym->as->type == AS_ASSUMED_SIZE)
6084 gfc_error ("Assumed size array %qs in %s clause at %L",
6085 n->sym->name, name, &n->where);
ac70b20b
TB		 6086 if (!openacc
6087 && list == OMP_LIST_MAP
6088 && n->sym->ts.type == BT_DERIVED
6089 && n->sym->ts.u.derived->attr.alloc_comp)
6090 gfc_error ("List item %qs with allocatable components is not "
6091 "permitted in map clause at %L", n->sym->name,
6092 &n->where);
b4c3a85b
JJ		 6093 if (list == OMP_LIST_MAP && !openacc)
6094 switch (code->op)
6095 {
6096 case EXEC_OMP_TARGET:
6097 case EXEC_OMP_TARGET_DATA:
6098 switch (n->u.map_op)
6099 {
6100 case OMP_MAP_TO:
6101 case OMP_MAP_ALWAYS_TO:
6102 case OMP_MAP_FROM:
6103 case OMP_MAP_ALWAYS_FROM:
6104 case OMP_MAP_TOFROM:
6105 case OMP_MAP_ALWAYS_TOFROM:
6106 case OMP_MAP_ALLOC:
6107 break;
6108 default:
6109 gfc_error ("TARGET%s with map-type other than TO, "
6110 "FROM, TOFROM, or ALLOC on MAP clause "
6111 "at %L",
6112 code->op == EXEC_OMP_TARGET
6113 ? "" : " DATA", &n->where);
6114 break;
6115 }
6116 break;
6117 case EXEC_OMP_TARGET_ENTER_DATA:
6118 switch (n->u.map_op)
6119 {
6120 case OMP_MAP_TO:
6121 case OMP_MAP_ALWAYS_TO:
6122 case OMP_MAP_ALLOC:
6123 break;
6124 default:
6125 gfc_error ("TARGET ENTER DATA with map-type other "
6126 "than TO, or ALLOC on MAP clause at %L",
6127 &n->where);
6128 break;
6129 }
6130 break;
6131 case EXEC_OMP_TARGET_EXIT_DATA:
6132 switch (n->u.map_op)
6133 {
6134 case OMP_MAP_FROM:
6135 case OMP_MAP_ALWAYS_FROM:
6136 case OMP_MAP_RELEASE:
6137 case OMP_MAP_DELETE:
6138 break;
6139 default:
6140 gfc_error ("TARGET EXIT DATA with map-type other "
6141 "than FROM, RELEASE, or DELETE on MAP "
6142 "clause at %L", &n->where);
6143 break;
6144 }
6145 break;
6146 default:
6147 break;
6148 }
41dbbb37
TS		 6149 }
6150
f014c653
JJ		 6151 if (list != OMP_LIST_DEPEND)
6152 for (n = omp_clauses->lists[list]; n != NULL; n = n->next)
6153 {
6154 n->sym->attr.referenced = 1;
6155 if (n->sym->attr.threadprivate)
a4d9b221 6156 gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
2ac33bca 6157 n->sym->name, name, &n->where);
f014c653 6158 if (n->sym->attr.cray_pointee)
a4d9b221 6159 gfc_error ("Cray pointee %qs in %s clause at %L",
2ac33bca 6160 n->sym->name, name, &n->where);
f014c653 6161 }
dd2fc525 6162 break;
b4c3a85b 6163 case OMP_LIST_IS_DEVICE_PTR:
049bfd18
TB		 6164 for (n = omp_clauses->lists[list]; n != NULL; n = n->next)
6165 {
6166 if (!n->sym->attr.dummy)
6167 gfc_error ("Non-dummy object %qs in %s clause at %L",
6168 n->sym->name, name, &n->where);
6169 if (n->sym->attr.allocatable
6170 || (n->sym->ts.type == BT_CLASS
6171 && CLASS_DATA (n->sym)->attr.allocatable))
6172 gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
6173 n->sym->name, name, &n->where);
6174 if (n->sym->attr.pointer
6175 || (n->sym->ts.type == BT_CLASS
6176 && CLASS_DATA (n->sym)->attr.pointer))
6177 gfc_error ("POINTER object %qs in %s clause at %L",
6178 n->sym->name, name, &n->where);
6179 if (n->sym->attr.value)
6180 gfc_error ("VALUE object %qs in %s clause at %L",
6181 n->sym->name, name, &n->where);
6182 }
ef4add8e 6183 break;
b4c3a85b 6184 case OMP_LIST_USE_DEVICE_PTR:
ef4add8e
TB		 6185 case OMP_LIST_USE_DEVICE_ADDR:
6186 /* FIXME: Handle OMP_LIST_USE_DEVICE_PTR. */
b4c3a85b 6187 break;
6c7a4dfd
JJ		 6188 default:
6189 for (; n != NULL; n = n->next)
6190 {
5f23671d 6191 bool bad = false;
e929ef53
TB		 6192 bool is_reduction = (list == OMP_LIST_REDUCTION
6193 || list == OMP_LIST_REDUCTION_INSCAN
6194 || list == OMP_LIST_REDUCTION_TASK
6195 || list == OMP_LIST_IN_REDUCTION
6196 || list == OMP_LIST_TASK_REDUCTION);
005cff4e
TB		 6197 if (list == OMP_LIST_REDUCTION_INSCAN)
6198 has_inscan = true;
6199 else if (is_reduction)
6200 has_notinscan = true;
6201 if (has_inscan && has_notinscan && is_reduction)
6202 {
6203 gfc_error ("%<inscan%> and non-%<inscan%> %<reduction%> "
48ca2185 6204 "clauses on the same construct at %L",
005cff4e
TB		 6205 &n->where);
6206 break;
6207 }
6c7a4dfd 6208 if (n->sym->attr.threadprivate)
c4100eae 6209 gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
2ac33bca 6210 n->sym->name, name, &n->where);
6c7a4dfd 6211 if (n->sym->attr.cray_pointee)
c4100eae 6212 gfc_error ("Cray pointee %qs in %s clause at %L",
2ac33bca 6213 n->sym->name, name, &n->where);
92d28cbb 6214 if (n->sym->attr.associate_var)
c4100eae 6215 gfc_error ("ASSOCIATE name %qs in %s clause at %L",
2ac33bca 6216 n->sym->name, name, &n->where);
e929ef53 6217 if (list != OMP_LIST_PRIVATE && is_reduction)
6c7a4dfd 6218 {
e929ef53 6219 if (n->sym->attr.proc_pointer)
c4100eae 6220 gfc_error ("Procedure pointer %qs in %s clause at %L",
2ac33bca 6221 n->sym->name, name, &n->where);
e929ef53 6222 if (n->sym->attr.pointer)
c4100eae 6223 gfc_error ("POINTER object %qs in %s clause at %L",
2ac33bca 6224 n->sym->name, name, &n->where);
e929ef53 6225 if (n->sym->attr.cray_pointer)
c4100eae 6226 gfc_error ("Cray pointer %qs in %s clause at %L",
2ac33bca 6227 n->sym->name, name, &n->where);
6c7a4dfd 6228 }
41dbbb37 6229 if (code
62aee289
MR		 6230 && (oacc_is_loop (code)
6231 || code->op == EXEC_OACC_PARALLEL
6232 || code->op == EXEC_OACC_SERIAL))
2ac33bca 6233 check_array_not_assumed (n->sym, n->where, name);
41dbbb37 6234 else if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
c4100eae 6235 gfc_error ("Assumed size array %qs in %s clause at %L",
2ac33bca 6236 n->sym->name, name, &n->where);
e929ef53 6237 if (n->sym->attr.in_namelist && !is_reduction)
c4100eae 6238 gfc_error ("Variable %qs in %s clause is used in "
edf1eac2 6239 "NAMELIST statement at %L",
2ac33bca 6240 n->sym->name, name, &n->where);
92d28cbb
JJ		 6241 if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
6242 switch (list)
6243 {
6244 case OMP_LIST_PRIVATE:
6245 case OMP_LIST_LASTPRIVATE:
6246 case OMP_LIST_LINEAR:
6247 /* case OMP_LIST_REDUCTION: */
c4100eae 6248 gfc_error ("INTENT(IN) POINTER %qs in %s clause at %L",
2ac33bca 6249 n->sym->name, name, &n->where);
92d28cbb
JJ		 6250 break;
6251 default:
6252 break;
6253 }
a6d22fb2
KCY		 6254 if (omp_clauses->detach
6255 && (list == OMP_LIST_PRIVATE
6256 || list == OMP_LIST_FIRSTPRIVATE
6257 || list == OMP_LIST_LASTPRIVATE)
6258 && n->sym == omp_clauses->detach->symtree->n.sym)
6259 gfc_error ("DETACH event handle %qs in %s clause at %L",
6260 n->sym->name, name, &n->where);
6c7a4dfd
JJ		 6261 switch (list)
6262 {
e929ef53 6263 case OMP_LIST_REDUCTION_TASK:
f6bf436d 6264 if (code
178191e1
TB		 6265 && (code->op == EXEC_OMP_LOOP
6266 || code->op == EXEC_OMP_TASKLOOP
f6bf436d 6267 || code->op == EXEC_OMP_TASKLOOP_SIMD
53d5b59c
TB		 6268 || code->op == EXEC_OMP_MASKED_TASKLOOP
6269 || code->op == EXEC_OMP_MASKED_TASKLOOP_SIMD
f6bf436d
TB		 6270 || code->op == EXEC_OMP_MASTER_TASKLOOP
6271 || code->op == EXEC_OMP_MASTER_TASKLOOP_SIMD
178191e1 6272 || code->op == EXEC_OMP_PARALLEL_LOOP
53d5b59c
TB		 6273 || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP
6274 || code->op == EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
f6bf436d
TB		 6275 || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP
6276 || code->op == EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
178191e1
TB		 6277 || code->op == EXEC_OMP_TARGET_PARALLEL_LOOP
6278 || code->op == EXEC_OMP_TARGET_TEAMS_LOOP
f6bf436d 6279 || code->op == EXEC_OMP_TEAMS
178191e1
TB		 6280 || code->op == EXEC_OMP_TEAMS_DISTRIBUTE
6281 || code->op == EXEC_OMP_TEAMS_LOOP))
e929ef53
TB		 6282 {
6283 gfc_error ("Only DEFAULT permitted as reduction-"
6284 "modifier in REDUCTION clause at %L",
6285 &n->where);
6286 break;
6287 }
6288 gcc_fallthrough ();
5f23671d 6289 case OMP_LIST_REDUCTION:
e929ef53
TB		 6290 case OMP_LIST_IN_REDUCTION:
6291 case OMP_LIST_TASK_REDUCTION:
f6bf436d 6292 case OMP_LIST_REDUCTION_INSCAN:
f014c653 6293 switch (n->u.reduction_op)
5f23671d
JJ		 6294 {
6295 case OMP_REDUCTION_PLUS:
6296 case OMP_REDUCTION_TIMES:
6297 case OMP_REDUCTION_MINUS:
6298 if (!gfc_numeric_ts (&n->sym->ts))
6299 bad = true;
6300 break;
6301 case OMP_REDUCTION_AND:
6302 case OMP_REDUCTION_OR:
6303 case OMP_REDUCTION_EQV:
6304 case OMP_REDUCTION_NEQV:
6305 if (n->sym->ts.type != BT_LOGICAL)
6306 bad = true;
6307 break;
6308 case OMP_REDUCTION_MAX:
6309 case OMP_REDUCTION_MIN:
6310 if (n->sym->ts.type != BT_INTEGER
6311 && n->sym->ts.type != BT_REAL)
6312 bad = true;
6313 break;
6314 case OMP_REDUCTION_IAND:
6315 case OMP_REDUCTION_IOR:
6316 case OMP_REDUCTION_IEOR:
6317 if (n->sym->ts.type != BT_INTEGER)
6318 bad = true;
6319 break;
6320 case OMP_REDUCTION_USER:
6321 bad = true;
6322 break;
6323 default:
6324 break;
6325 }
6326 if (!bad)
9a5de4d5 6327 n->u2.udr = NULL;
5f23671d
JJ		 6328 else
6329 {
6330 const char *udr_name = NULL;
9a5de4d5 6331 if (n->u2.udr)
5f23671d 6332 {
9a5de4d5
TB		 6333 udr_name = n->u2.udr->udr->name;
6334 n->u2.udr->udr
b46ebd6c
JJ		 6335 = gfc_find_omp_udr (NULL, udr_name,
6336 &n->sym->ts);
9a5de4d5 6337 if (n->u2.udr->udr == NULL)
b46ebd6c 6338 {
9a5de4d5
TB		 6339 free (n->u2.udr);
6340 n->u2.udr = NULL;
b46ebd6c 6341 }
5f23671d 6342 }
9a5de4d5 6343 if (n->u2.udr == NULL)
5f23671d
JJ		 6344 {
6345 if (udr_name == NULL)
f014c653 6346 switch (n->u.reduction_op)
5f23671d
JJ		 6347 {
6348 case OMP_REDUCTION_PLUS:
6349 case OMP_REDUCTION_TIMES:
6350 case OMP_REDUCTION_MINUS:
6351 case OMP_REDUCTION_AND:
6352 case OMP_REDUCTION_OR:
6353 case OMP_REDUCTION_EQV:
6354 case OMP_REDUCTION_NEQV:
6355 udr_name = gfc_op2string ((gfc_intrinsic_op)
f014c653 6356 n->u.reduction_op);
5f23671d
JJ		 6357 break;
6358 case OMP_REDUCTION_MAX:
6359 udr_name = "max";
6360 break;
6361 case OMP_REDUCTION_MIN:
6362 udr_name = "min";
6363 break;
6364 case OMP_REDUCTION_IAND:
6365 udr_name = "iand";
6366 break;
6367 case OMP_REDUCTION_IOR:
6368 udr_name = "ior";
6369 break;
6370 case OMP_REDUCTION_IEOR:
6371 udr_name = "ieor";
6372 break;
6373 default:
6374 gcc_unreachable ();
6375 }
6376 gfc_error ("!$OMP DECLARE REDUCTION %s not found "
6377 "for type %s at %L", udr_name,
2ac33bca 6378 gfc_typename (&n->sym->ts), &n->where);
5f23671d
JJ		 6379 }
6380 else
b46ebd6c 6381 {
9a5de4d5 6382 gfc_omp_udr *udr = n->u2.udr->udr;
b46ebd6c 6383 n->u.reduction_op = OMP_REDUCTION_USER;
9a5de4d5 6384 n->u2.udr->combiner
b46ebd6c
JJ		 6385 = resolve_omp_udr_clause (n, udr->combiner_ns,
6386 udr->omp_out,
6387 udr->omp_in);
6388 if (udr->initializer_ns)
9a5de4d5 6389 n->u2.udr->initializer
b46ebd6c
JJ		 6390 = resolve_omp_udr_clause (n,
6391 udr->initializer_ns,
6392 udr->omp_priv,
6393 udr->omp_orig);
6394 }
5f23671d 6395 }
dd2fc525
JJ		 6396 break;
6397 case OMP_LIST_LINEAR:
b4c3a85b
JJ		 6398 if (code
6399 && n->u.linear_op != OMP_LINEAR_DEFAULT
6400 && n->u.linear_op != linear_op)
6401 {
6402 gfc_error ("LINEAR clause modifier used on DO or SIMD"
6403 " construct at %L", &n->where);
6404 linear_op = n->u.linear_op;
6405 }
6406 else if (omp_clauses->orderedc)
bd2c6270 6407 gfc_error ("LINEAR clause specified together with "
b4c3a85b
JJ		 6408 "ORDERED clause with argument at %L",
6409 &n->where);
6410 else if (n->u.linear_op != OMP_LINEAR_REF
6411 && n->sym->ts.type != BT_INTEGER)
c4100eae 6412 gfc_error ("LINEAR variable %qs must be INTEGER "
2ac33bca 6413 "at %L", n->sym->name, &n->where);
b4c3a85b
JJ		 6414 else if ((n->u.linear_op == OMP_LINEAR_REF
6415 || n->u.linear_op == OMP_LINEAR_UVAL)
6416 && n->sym->attr.value)
6417 gfc_error ("LINEAR dummy argument %qs with VALUE "
6418 "attribute with %s modifier at %L",
6419 n->sym->name,
6420 n->u.linear_op == OMP_LINEAR_REF
6421 ? "REF" : "UVAL", &n->where);
dd2fc525
JJ		 6422 else if (n->expr)
6423 {
6424 gfc_expr *expr = n->expr;
6425 if (!gfc_resolve_expr (expr)
6426 || expr->ts.type != BT_INTEGER
6427 || expr->rank != 0)
c4100eae 6428 gfc_error ("%qs in LINEAR clause at %L requires "
dd2fc525 6429 "a scalar integer linear-step expression",
2ac33bca 6430 n->sym->name, &n->where);
dd2fc525 6431 else if (!code && expr->expr_type != EXPR_CONSTANT)
b4c3a85b
JJ		 6432 {
6433 if (expr->expr_type == EXPR_VARIABLE
6434 && expr->symtree->n.sym->attr.dummy
6435 && expr->symtree->n.sym->ns == ns)
6436 {
6437 gfc_omp_namelist *n2;
6438 for (n2 = omp_clauses->lists[OMP_LIST_UNIFORM];
6439 n2; n2 = n2->next)
6440 if (n2->sym == expr->symtree->n.sym)
6441 break;
6442 if (n2)
6443 break;
6444 }
6445 gfc_error ("%qs in LINEAR clause at %L requires "
6446 "a constant integer linear-step "
6447 "expression or dummy argument "
6448 "specified in UNIFORM clause",
6449 n->sym->name, &n->where);
6450 }
dd2fc525 6451 }
6c7a4dfd 6452 break;
2003abbd
JJ		 6453 /* Workaround for PR middle-end/26316, nothing really needs
6454 to be done here for OMP_LIST_PRIVATE. */
6455 case OMP_LIST_PRIVATE:
dd2fc525 6456 gcc_assert (code && code->op != EXEC_NOP);
41dbbb37
TS		 6457 break;
6458 case OMP_LIST_USE_DEVICE:
6459 if (n->sym->attr.allocatable
6460 || (n->sym->ts.type == BT_CLASS && CLASS_DATA (n->sym)
6461 && CLASS_DATA (n->sym)->attr.allocatable))
9f584046 6462 gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
2ac33bca 6463 n->sym->name, name, &n->where);
7c713714
CLT		 6464 if (n->sym->ts.type == BT_CLASS
6465 && CLASS_DATA (n->sym)
6466 && CLASS_DATA (n->sym)->attr.class_pointer)
6467 gfc_error ("POINTER object %qs of polymorphic type in "
6468 "%s clause at %L", n->sym->name, name,
6469 &n->where);
41dbbb37 6470 if (n->sym->attr.cray_pointer)
9f584046 6471 gfc_error ("Cray pointer object %qs in %s clause at %L",
2ac33bca 6472 n->sym->name, name, &n->where);
7c713714 6473 else if (n->sym->attr.cray_pointee)
9f584046 6474 gfc_error ("Cray pointee object %qs in %s clause at %L",
2ac33bca 6475 n->sym->name, name, &n->where);
7c713714
CLT		 6476 else if (n->sym->attr.flavor == FL_VARIABLE
6477 && !n->sym->as
6478 && !n->sym->attr.pointer)
6479 gfc_error ("%s clause variable %qs at %L is neither "
6480 "a POINTER nor an array", name,
6481 n->sym->name, &n->where);
41dbbb37
TS		 6482 /* FALLTHRU */
6483 case OMP_LIST_DEVICE_RESIDENT:
2ac33bca
CP		 6484 check_symbol_not_pointer (n->sym, n->where, name);
6485 check_array_not_assumed (n->sym, n->where, name);
41dbbb37 6486 break;
6c7a4dfd
JJ		 6487 default:
6488 break;
6489 }
6490 }
6491 break;
6492 }
6493 }
049bfd18
TB		 6494 /* OpenMP 5.1: use_device_ptr acts like use_device_addr, except for
6495 type(c_ptr). */
6496 if (omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR])
6497 {
6498 gfc_omp_namelist *n_prev, *n_next, *n_addr;
6499 n_addr = omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR];
6500 for (; n_addr && n_addr->next; n_addr = n_addr->next)
6501 ;
6502 n_prev = NULL;
6503 n = omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR];
6504 while (n)
6505 {
6506 n_next = n->next;
6507 if (n->sym->ts.type != BT_DERIVED
6508 || n->sym->ts.u.derived->ts.f90_type != BT_VOID)
6509 {
6510 n->next = NULL;
6511 if (n_addr)
6512 n_addr->next = n;
6513 else
6514 omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] = n;
6515 n_addr = n;
6516 if (n_prev)
6517 n_prev->next = n_next;
6518 else
6519 omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] = n_next;
6520 }
6521 else
6522 n_prev = n;
6523 n = n_next;
6524 }
6525 }
dd2fc525 6526 if (omp_clauses->safelen_expr)
b4c3a85b 6527 resolve_positive_int_expr (omp_clauses->safelen_expr, "SAFELEN");
dd2fc525 6528 if (omp_clauses->simdlen_expr)
b4c3a85b 6529 resolve_positive_int_expr (omp_clauses->simdlen_expr, "SIMDLEN");
f014c653 6530 if (omp_clauses->num_teams)
b4c3a85b 6531 resolve_positive_int_expr (omp_clauses->num_teams, "NUM_TEAMS");
f014c653 6532 if (omp_clauses->device)
b4c3a85b 6533 resolve_nonnegative_int_expr (omp_clauses->device, "DEVICE");
53d5b59c
TB		 6534 if (omp_clauses->filter)
6535 resolve_nonnegative_int_expr (omp_clauses->filter, "FILTER");
b4c3a85b 6536 if (omp_clauses->hint)
c7c24828
TB		 6537 {
6538 resolve_scalar_int_expr (omp_clauses->hint, "HINT");
6539 if (omp_clauses->hint->ts.type != BT_INTEGER
6540 || omp_clauses->hint->expr_type != EXPR_CONSTANT
6541 || mpz_sgn (omp_clauses->hint->value.integer) < 0)
6542 gfc_error ("Value of HINT clause at %L shall be a valid "
6543 "constant hint expression", &omp_clauses->hint->where);
6544 }
b4c3a85b
JJ		 6545 if (omp_clauses->priority)
6546 resolve_nonnegative_int_expr (omp_clauses->priority, "PRIORITY");
f014c653
JJ		 6547 if (omp_clauses->dist_chunk_size)
6548 {
6549 gfc_expr *expr = omp_clauses->dist_chunk_size;
6550 if (!gfc_resolve_expr (expr)
6551 || expr->ts.type != BT_INTEGER || expr->rank != 0)
6552 gfc_error ("DIST_SCHEDULE clause's chunk_size at %L requires "
6553 "a scalar INTEGER expression", &expr->where);
6554 }
6555 if (omp_clauses->thread_limit)
b4c3a85b
JJ		 6556 resolve_positive_int_expr (omp_clauses->thread_limit, "THREAD_LIMIT");
6557 if (omp_clauses->grainsize)
6558 resolve_positive_int_expr (omp_clauses->grainsize, "GRAINSIZE");
6559 if (omp_clauses->num_tasks)
6560 resolve_positive_int_expr (omp_clauses->num_tasks, "NUM_TASKS");
41dbbb37
TS		 6561 if (omp_clauses->async)
6562 if (omp_clauses->async_expr)
b4c3a85b 6563 resolve_scalar_int_expr (omp_clauses->async_expr, "ASYNC");
41dbbb37 6564 if (omp_clauses->num_gangs_expr)
b4c3a85b 6565 resolve_positive_int_expr (omp_clauses->num_gangs_expr, "NUM_GANGS");
41dbbb37 6566 if (omp_clauses->num_workers_expr)
b4c3a85b 6567 resolve_positive_int_expr (omp_clauses->num_workers_expr, "NUM_WORKERS");
41dbbb37 6568 if (omp_clauses->vector_length_expr)
b4c3a85b
JJ		 6569 resolve_positive_int_expr (omp_clauses->vector_length_expr,
6570 "VECTOR_LENGTH");
2a70708e 6571 if (omp_clauses->gang_num_expr)
b4c3a85b 6572 resolve_positive_int_expr (omp_clauses->gang_num_expr, "GANG");
2a70708e 6573 if (omp_clauses->gang_static_expr)
b4c3a85b 6574 resolve_positive_int_expr (omp_clauses->gang_static_expr, "GANG");
41dbbb37 6575 if (omp_clauses->worker_expr)
b4c3a85b 6576 resolve_positive_int_expr (omp_clauses->worker_expr, "WORKER");
41dbbb37 6577 if (omp_clauses->vector_expr)
b4c3a85b 6578 resolve_positive_int_expr (omp_clauses->vector_expr, "VECTOR");
fc2a1f2f
TS		 6579 for (el = omp_clauses->wait_list; el; el = el->next)
6580 resolve_scalar_int_expr (el->expr, "WAIT");
02889d23
CLT		 6581 if (omp_clauses->collapse && omp_clauses->tile_list)
6582 gfc_error ("Incompatible use of TILE and COLLAPSE at %L", &code->loc);
b4c3a85b
JJ		 6583 if (omp_clauses->depend_source && code->op != EXEC_OMP_ORDERED)
6584 gfc_error ("SOURCE dependence type only allowed "
6585 "on ORDERED directive at %L", &code->loc);
77167196
TB		 6586 if (omp_clauses->message)
6587 {
6588 gfc_expr *expr = omp_clauses->message;
6589 if (!gfc_resolve_expr (expr)
6590 || expr->ts.kind != gfc_default_character_kind
6591 || expr->ts.type != BT_CHARACTER || expr->rank != 0)
6592 gfc_error ("MESSAGE clause at %L requires a scalar default-kind "
6593 "CHARACTER expression", &expr->where);
6594 }
d6cd139c
TB		 6595 if (!openacc
6596 && code
6597 && omp_clauses->lists[OMP_LIST_MAP] == NULL
6598 && omp_clauses->lists[OMP_LIST_USE_DEVICE_PTR] == NULL
6599 && omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] == NULL)
b4c3a85b
JJ		 6600 {
6601 const char *p = NULL;
6602 switch (code->op)
6603 {
b4c3a85b
JJ		 6604 case EXEC_OMP_TARGET_ENTER_DATA: p = "TARGET ENTER DATA"; break;
6605 case EXEC_OMP_TARGET_EXIT_DATA: p = "TARGET EXIT DATA"; break;
6606 default: break;
6607 }
d6cd139c
TB		 6608 if (code->op == EXEC_OMP_TARGET_DATA)
6609 gfc_error ("TARGET DATA must contain at least one MAP, USE_DEVICE_PTR, "
6610 "or USE_DEVICE_ADDR clause at %L", &code->loc);
6611 else if (p)
b4c3a85b
JJ		 6612 gfc_error ("%s must contain at least one MAP clause at %L",
6613 p, &code->loc);
6614 }
a6d22fb2
KCY		 6615 if (!openacc && omp_clauses->mergeable && omp_clauses->detach)
6616 gfc_error ("%<DETACH%> clause at %L must not be used together with "
6617 "%<MERGEABLE%> clause", &omp_clauses->detach->where);
6c7a4dfd
JJ		 6618}
6619
edf1eac2 6620
6c7a4dfd
JJ		 6621/* Return true if SYM is ever referenced in EXPR except in the SE node. */
6622
6623static bool
6624expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
6625{
6626 gfc_actual_arglist *arg;
6627 if (e == NULL || e == se)
6628 return false;
6629 switch (e->expr_type)
6630 {
6631 case EXPR_CONSTANT:
6632 case EXPR_NULL:
6633 case EXPR_VARIABLE:
6634 case EXPR_STRUCTURE:
6635 case EXPR_ARRAY:
6636 if (e->symtree != NULL
6637 && e->symtree->n.sym == s)
6638 return true;
6639 return false;
6640 case EXPR_SUBSTRING:
6641 if (e->ref != NULL
6642 && (expr_references_sym (e->ref->u.ss.start, s, se)
6643 || expr_references_sym (e->ref->u.ss.end, s, se)))
6644 return true;
6645 return false;
6646 case EXPR_OP:
6647 if (expr_references_sym (e->value.op.op2, s, se))
6648 return true;
6649 return expr_references_sym (e->value.op.op1, s, se);
6650 case EXPR_FUNCTION:
6651 for (arg = e->value.function.actual; arg; arg = arg->next)
6652 if (expr_references_sym (arg->expr, s, se))
6653 return true;
6654 return false;
6655 default:
6656 gcc_unreachable ();
6657 }
6658}
6659
edf1eac2 6660
6c7a4dfd
JJ		 6661/* If EXPR is a conversion function that widens the type
6662 if WIDENING is true or narrows the type if WIDENING is false,
6663 return the inner expression, otherwise return NULL. */
6664
6665static gfc_expr *
6666is_conversion (gfc_expr *expr, bool widening)
6667{
6668 gfc_typespec *ts1, *ts2;
6669
6670 if (expr->expr_type != EXPR_FUNCTION
6671 || expr->value.function.isym == NULL
6672 || expr->value.function.esym != NULL
cd5ecab6 6673 || expr->value.function.isym->id != GFC_ISYM_CONVERSION)
6c7a4dfd
JJ		 6674 return NULL;
6675
6676 if (widening)
6677 {
6678 ts1 = &expr->ts;
6679 ts2 = &expr->value.function.actual->expr->ts;
6680 }
6681 else
6682 {
6683 ts1 = &expr->value.function.actual->expr->ts;
6684 ts2 = &expr->ts;
6685 }
6686
6687 if (ts1->type > ts2->type
6688 || (ts1->type == ts2->type && ts1->kind > ts2->kind))
6689 return expr->value.function.actual->expr;
6690
6691 return NULL;
6692}
6693
edf1eac2 6694
6c7a4dfd
JJ		 6695static void
6696resolve_omp_atomic (gfc_code *code)
6697{
1fc5e7ef 6698 gfc_code *atomic_code = code->block;
6c7a4dfd 6699 gfc_symbol *var;
20906c66 6700 gfc_expr *expr2, *expr2_tmp;
dd2fc525 6701 gfc_omp_atomic_op aop
1fc5e7ef
TB		 6702 = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op
6703 & GFC_OMP_ATOMIC_MASK);
6c7a4dfd
JJ		 6704
6705 code = code->block->next;
f25f40be
JJ		 6706 /* resolve_blocks asserts this is initially EXEC_ASSIGN.
6707 If it changed to EXEC_NOP, assume an error has been emitted already. */
6708 if (code->op == EXEC_NOP)
6709 return;
6710 if (code->op != EXEC_ASSIGN)
6711 {
6712 unexpected:
6713 gfc_error ("unexpected !$OMP ATOMIC expression at %L", &code->loc);
6714 return;
6715 }
1fc5e7ef 6716 if (!atomic_code->ext.omp_clauses->capture)
f25f40be
JJ		 6717 {
6718 if (code->next != NULL)
6719 goto unexpected;
6720 }
6721 else
6722 {
6723 if (code->next == NULL)
6724 goto unexpected;
6725 if (code->next->op == EXEC_NOP)
6726 return;
6727 if (code->next->op != EXEC_ASSIGN || code->next->next)
6728 {
6729 code = code->next;
6730 goto unexpected;
6731 }
6732 }
6c7a4dfd 6733
a513927a
SK		 6734 if (code->expr1->expr_type != EXPR_VARIABLE
6735 || code->expr1->symtree == NULL
6736 || code->expr1->rank != 0
6737 || (code->expr1->ts.type != BT_INTEGER
6738 && code->expr1->ts.type != BT_REAL
6739 && code->expr1->ts.type != BT_COMPLEX
6740 && code->expr1->ts.type != BT_LOGICAL))
6c7a4dfd 6741 {
edf1eac2
SK		 6742 gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
6743 "intrinsic type at %L", &code->loc);
6c7a4dfd
JJ		 6744 return;
6745 }
6746
a513927a 6747 var = code->expr1->symtree->n.sym;
6c7a4dfd
JJ		 6748 expr2 = is_conversion (code->expr2, false);
6749 if (expr2 == NULL)
20906c66 6750 {
dd2fc525 6751 if (aop == GFC_OMP_ATOMIC_READ || aop == GFC_OMP_ATOMIC_WRITE)
20906c66
JJ		 6752 expr2 = is_conversion (code->expr2, true);
6753 if (expr2 == NULL)
6754 expr2 = code->expr2;
6755 }
6756
dd2fc525 6757 switch (aop)
20906c66
JJ		 6758 {
6759 case GFC_OMP_ATOMIC_READ:
6760 if (expr2->expr_type != EXPR_VARIABLE
6761 || expr2->symtree == NULL
6762 || expr2->rank != 0
6763 || (expr2->ts.type != BT_INTEGER
6764 && expr2->ts.type != BT_REAL
6765 && expr2->ts.type != BT_COMPLEX
6766 && expr2->ts.type != BT_LOGICAL))
6767 gfc_error ("!$OMP ATOMIC READ statement must read from a scalar "
6768 "variable of intrinsic type at %L", &expr2->where);
6769 return;
6770 case GFC_OMP_ATOMIC_WRITE:
6771 if (expr2->rank != 0 || expr_references_sym (code->expr2, var, NULL))
6772 gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr "
6773 "must be scalar and cannot reference var at %L",
6774 &expr2->where);
6775 return;
1fc5e7ef
TB		 6776 default:
6777 break;
6778 }
6779 if (atomic_code->ext.omp_clauses->capture)
6780 {
20906c66
JJ		 6781 expr2_tmp = expr2;
6782 if (expr2 == code->expr2)
6783 {
6784 expr2_tmp = is_conversion (code->expr2, true);
6785 if (expr2_tmp == NULL)
6786 expr2_tmp = expr2;
6787 }
6788 if (expr2_tmp->expr_type == EXPR_VARIABLE)
6789 {
6790 if (expr2_tmp->symtree == NULL
6791 || expr2_tmp->rank != 0
6792 || (expr2_tmp->ts.type != BT_INTEGER
6793 && expr2_tmp->ts.type != BT_REAL
6794 && expr2_tmp->ts.type != BT_COMPLEX
6795 && expr2_tmp->ts.type != BT_LOGICAL)
6796 || expr2_tmp->symtree->n.sym == var)
6797 {
6798 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read from "
6799 "a scalar variable of intrinsic type at %L",
6800 &expr2_tmp->where);
6801 return;
6802 }
6803 var = expr2_tmp->symtree->n.sym;
6804 code = code->next;
6805 if (code->expr1->expr_type != EXPR_VARIABLE
6806 || code->expr1->symtree == NULL
6807 || code->expr1->rank != 0
6808 || (code->expr1->ts.type != BT_INTEGER
6809 && code->expr1->ts.type != BT_REAL
6810 && code->expr1->ts.type != BT_COMPLEX
6811 && code->expr1->ts.type != BT_LOGICAL))
6812 {
6813 gfc_error ("!$OMP ATOMIC CAPTURE update statement must set "
6814 "a scalar variable of intrinsic type at %L",
6815 &code->expr1->where);
6816 return;
6817 }
6818 if (code->expr1->symtree->n.sym != var)
6819 {
6820 gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
6821 "different variable than update statement writes "
6822 "into at %L", &code->expr1->where);
6823 return;
6824 }
6825 expr2 = is_conversion (code->expr2, false);
6826 if (expr2 == NULL)
6827 expr2 = code->expr2;
6828 }
20906c66 6829 }
6c7a4dfd 6830
7258a257 6831 if (gfc_expr_attr (code->expr1).allocatable)
dd2fc525
JJ		 6832 {
6833 gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L",
6834 &code->loc);
6835 return;
6836 }
6837
1fc5e7ef 6838 if (atomic_code->ext.omp_clauses->capture
dd2fc525
JJ		 6839 && code->next == NULL
6840 && code->expr2->rank == 0
6841 && !expr_references_sym (code->expr2, var, NULL))
1fc5e7ef
TB		 6842 atomic_code->ext.omp_clauses->atomic_op
6843 = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op
dd2fc525
JJ		 6844 | GFC_OMP_ATOMIC_SWAP);
6845 else if (expr2->expr_type == EXPR_OP)
6c7a4dfd
JJ		 6846 {
6847 gfc_expr *v = NULL, *e, *c;
a1ee985f 6848 gfc_intrinsic_op op = expr2->value.op.op;
6c7a4dfd
JJ		 6849 gfc_intrinsic_op alt_op = INTRINSIC_NONE;
6850
6851 switch (op)
6852 {
6853 case INTRINSIC_PLUS:
6854 alt_op = INTRINSIC_MINUS;
6855 break;
6856 case INTRINSIC_TIMES:
6857 alt_op = INTRINSIC_DIVIDE;
6858 break;
6859 case INTRINSIC_MINUS:
6860 alt_op = INTRINSIC_PLUS;
6861 break;
6862 case INTRINSIC_DIVIDE:
6863 alt_op = INTRINSIC_TIMES;
6864 break;
6865 case INTRINSIC_AND:
6866 case INTRINSIC_OR:
6867 break;
6868 case INTRINSIC_EQV:
6869 alt_op = INTRINSIC_NEQV;
6870 break;
6871 case INTRINSIC_NEQV:
6872 alt_op = INTRINSIC_EQV;
6873 break;
6874 default:
97a778bd 6875 gfc_error ("!$OMP ATOMIC assignment operator must be binary "
edf1eac2 6876 "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
6c7a4dfd
JJ		 6877 &expr2->where);
6878 return;
6879 }
6880
6881 /* Check for var = var op expr resp. var = expr op var where
6882 expr doesn't reference var and var op expr is mathematically
6883 equivalent to var op (expr) resp. expr op var equivalent to
6884 (expr) op var. We rely here on the fact that the matcher
6885 for x op1 y op2 z where op1 and op2 have equal precedence
6886 returns (x op1 y) op2 z. */
6887 e = expr2->value.op.op2;
6888 if (e->expr_type == EXPR_VARIABLE
6889 && e->symtree != NULL
6890 && e->symtree->n.sym == var)
6891 v = e;
6892 else if ((c = is_conversion (e, true)) != NULL
6893 && c->expr_type == EXPR_VARIABLE
6894 && c->symtree != NULL
6895 && c->symtree->n.sym == var)
6896 v = c;
6897 else
6898 {
6899 gfc_expr **p = NULL, **q;
6900 for (q = &expr2->value.op.op1; (e = *q) != NULL; )
6901 if (e->expr_type == EXPR_VARIABLE
6902 && e->symtree != NULL
6903 && e->symtree->n.sym == var)
6904 {
6905 v = e;
6906 break;
6907 }
6908 else if ((c = is_conversion (e, true)) != NULL)
6909 q = &e->value.function.actual->expr;
6910 else if (e->expr_type != EXPR_OP
a1ee985f
KG		 6911 || (e->value.op.op != op
6912 && e->value.op.op != alt_op)
6c7a4dfd
JJ		 6913 || e->rank != 0)
6914 break;
6915 else
6916 {
6917 p = q;
6918 q = &e->value.op.op1;
6919 }
6920
6921 if (v == NULL)
6922 {
edf1eac2
SK		 6923 gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
6924 "or var = expr op var at %L", &expr2->where);
6c7a4dfd
JJ		 6925 return;
6926 }
6927
6928 if (p != NULL)
6929 {
6930 e = *p;
a1ee985f 6931 switch (e->value.op.op)
6c7a4dfd
JJ		 6932 {
6933 case INTRINSIC_MINUS:
6934 case INTRINSIC_DIVIDE:
6935 case INTRINSIC_EQV:
6936 case INTRINSIC_NEQV:
edf1eac2
SK		 6937 gfc_error ("!$OMP ATOMIC var = var op expr not "
6938 "mathematically equivalent to var = var op "
6939 "(expr) at %L", &expr2->where);
6c7a4dfd
JJ		 6940 break;
6941 default:
6942 break;
6943 }
6944
6945 /* Canonicalize into var = var op (expr). */
6946 *p = e->value.op.op2;
6947 e->value.op.op2 = expr2;
6948 e->ts = expr2->ts;
6949 if (code->expr2 == expr2)
6950 code->expr2 = expr2 = e;
6951 else
6952 code->expr2->value.function.actual->expr = expr2 = e;
6953
6954 if (!gfc_compare_types (&expr2->value.op.op1->ts, &expr2->ts))
6955 {
6956 for (p = &expr2->value.op.op1; *p != v;
6957 p = &(*p)->value.function.actual->expr)
6958 ;
6959 *p = NULL;
6960 gfc_free_expr (expr2->value.op.op1);
6961 expr2->value.op.op1 = v;
6962 gfc_convert_type (v, &expr2->ts, 2);
6963 }
6964 }
6965 }
6966
6967 if (e->rank != 0 || expr_references_sym (code->expr2, var, v))
6968 {
edf1eac2
SK		 6969 gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
6970 "must be scalar and cannot reference var at %L",
6c7a4dfd
JJ		 6971 &expr2->where);
6972 return;
6973 }
6974 }
6975 else if (expr2->expr_type == EXPR_FUNCTION
6976 && expr2->value.function.isym != NULL
6977 && expr2->value.function.esym == NULL
6978 && expr2->value.function.actual != NULL
6979 && expr2->value.function.actual->next != NULL)
6980 {
6981 gfc_actual_arglist *arg, *var_arg;
6982
cd5ecab6 6983 switch (expr2->value.function.isym->id)
6c7a4dfd
JJ		 6984 {
6985 case GFC_ISYM_MIN:
6986 case GFC_ISYM_MAX:
6987 break;
6988 case GFC_ISYM_IAND:
6989 case GFC_ISYM_IOR:
6990 case GFC_ISYM_IEOR:
6991 if (expr2->value.function.actual->next->next != NULL)
6992 {
edf1eac2 6993 gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
6c7a4dfd
JJ		 6994 "or IEOR must have two arguments at %L",
6995 &expr2->where);
6996 return;
6997 }
6998 break;
6999 default:
edf1eac2
SK		 7000 gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
7001 "MIN, MAX, IAND, IOR or IEOR at %L",
6c7a4dfd
JJ		 7002 &expr2->where);
7003 return;
7004 }
7005
7006 var_arg = NULL;
7007 for (arg = expr2->value.function.actual; arg; arg = arg->next)
7008 {
7009 if ((arg == expr2->value.function.actual
7010 || (var_arg == NULL && arg->next == NULL))
7011 && arg->expr->expr_type == EXPR_VARIABLE
7012 && arg->expr->symtree != NULL
7013 && arg->expr->symtree->n.sym == var)
7014 var_arg = arg;
7015 else if (expr_references_sym (arg->expr, var, NULL))
dd2fc525
JJ		 7016 {
7017 gfc_error ("!$OMP ATOMIC intrinsic arguments except one must "
c4100eae 7018 "not reference %qs at %L",
dd2fc525
JJ		 7019 var->name, &arg->expr->where);
7020 return;
7021 }
6c7a4dfd 7022 if (arg->expr->rank != 0)
dd2fc525
JJ		 7023 {
7024 gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
7025 "at %L", &arg->expr->where);
7026 return;
7027 }
6c7a4dfd
JJ		 7028 }
7029
7030 if (var_arg == NULL)
7031 {
edf1eac2 7032 gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
c4100eae 7033 "be %qs at %L", var->name, &expr2->where);
6c7a4dfd
JJ		 7034 return;
7035 }
7036
7037 if (var_arg != expr2->value.function.actual)
7038 {
7039 /* Canonicalize, so that var comes first. */
7040 gcc_assert (var_arg->next == NULL);
7041 for (arg = expr2->value.function.actual;
7042 arg->next != var_arg; arg = arg->next)
7043 ;
7044 var_arg->next = expr2->value.function.actual;
7045 expr2->value.function.actual = var_arg;
7046 arg->next = NULL;
7047 }
7048 }
7049 else
dd2fc525
JJ		 7050 gfc_error ("!$OMP ATOMIC assignment must have an operator or "
7051 "intrinsic on right hand side at %L", &expr2->where);
20906c66 7052
1fc5e7ef 7053 if (atomic_code->ext.omp_clauses->capture && code->next)
20906c66
JJ		 7054 {
7055 code = code->next;
7056 if (code->expr1->expr_type != EXPR_VARIABLE
7057 || code->expr1->symtree == NULL
7058 || code->expr1->rank != 0
7059 || (code->expr1->ts.type != BT_INTEGER
7060 && code->expr1->ts.type != BT_REAL
7061 && code->expr1->ts.type != BT_COMPLEX
7062 && code->expr1->ts.type != BT_LOGICAL))
7063 {
7064 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must set "
7065 "a scalar variable of intrinsic type at %L",
7066 &code->expr1->where);
7067 return;
7068 }
7069
7070 expr2 = is_conversion (code->expr2, false);
7071 if (expr2 == NULL)
7072 {
7073 expr2 = is_conversion (code->expr2, true);
7074 if (expr2 == NULL)
7075 expr2 = code->expr2;
7076 }
7077
7078 if (expr2->expr_type != EXPR_VARIABLE
7079 || expr2->symtree == NULL
7080 || expr2->rank != 0
7081 || (expr2->ts.type != BT_INTEGER
7082 && expr2->ts.type != BT_REAL
7083 && expr2->ts.type != BT_COMPLEX
7084 && expr2->ts.type != BT_LOGICAL))
7085 {
7086 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read "
7087 "from a scalar variable of intrinsic type at %L",
7088 &expr2->where);
7089 return;
7090 }
7091 if (expr2->symtree->n.sym != var)
7092 {
7093 gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
7094 "different variable than update statement writes "
7095 "into at %L", &expr2->where);
7096 return;
7097 }
7098 }
6c7a4dfd
JJ		 7099}
7100
edf1eac2 7101
cd30a0b8 7102static struct fortran_omp_context
6c7a4dfd
JJ		 7103{
7104 gfc_code *code;
6e2830c3
TS		 7105 hash_set<gfc_symbol *> *sharing_clauses;
7106 hash_set<gfc_symbol *> *private_iterators;
46842bfe 7107 struct fortran_omp_context *previous;
41dbbb37 7108 bool is_openmp;
6c7a4dfd 7109} *omp_current_ctx;
a68ab351
JJ		 7110static gfc_code *omp_current_do_code;
7111static int omp_current_do_collapse;
edf1eac2 7112
6c7a4dfd
JJ		 7113void
7114gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
7115{
7116 if (code->block->next && code->block->next->op == EXEC_DO)
a68ab351
JJ		 7117 {
7118 int i;
7119 gfc_code *c;
7120
7121 omp_current_do_code = code->block->next;
b4c3a85b
JJ		 7122 if (code->ext.omp_clauses->orderedc)
7123 omp_current_do_collapse = code->ext.omp_clauses->orderedc;
7124 else
7125 omp_current_do_collapse = code->ext.omp_clauses->collapse;
a68ab351
JJ		 7126 for (i = 1, c = omp_current_do_code; i < omp_current_do_collapse; i++)
7127 {
7128 c = c->block;
7129 if (c->op != EXEC_DO || c->next == NULL)
7130 break;
7131 c = c->next;
7132 if (c->op != EXEC_DO)
7133 break;
7134 }
7135 if (i < omp_current_do_collapse || omp_current_do_collapse <= 0)
7136 omp_current_do_collapse = 1;
005cff4e
TB		 7137 if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
7138 {
7139 locus *loc
7140 = &code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where;
7141 if (code->ext.omp_clauses->ordered)
7142 gfc_error ("ORDERED clause specified together with %<inscan%> "
7143 "REDUCTION clause at %L", loc);
7144 if (code->ext.omp_clauses->sched_kind != OMP_SCHED_NONE)
7145 gfc_error ("SCHEDULE clause specified together with %<inscan%> "
7146 "REDUCTION clause at %L", loc);
7147 if (!c->block
7148 || !c->block->next
7149 || !c->block->next->next
7150 || c->block->next->next->op != EXEC_OMP_SCAN
7151 || !c->block->next->next->next
7152 || c->block->next->next->next->next)
7153 gfc_error ("With INSCAN at %L, expected loop body with !$OMP SCAN "
7154 "between two structured-block-sequences", loc);
7155 else
7156 /* Mark as checked; flag will be unset later. */
7157 c->block->next->next->ext.omp_clauses->if_present = true;
7158 }
a68ab351 7159 }
6c7a4dfd 7160 gfc_resolve_blocks (code->block, ns);
a68ab351
JJ		 7161 omp_current_do_collapse = 0;
7162 omp_current_do_code = NULL;
6c7a4dfd
JJ		 7163}
7164
edf1eac2 7165
6c7a4dfd
JJ		 7166void
7167gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
7168{
46842bfe 7169 struct fortran_omp_context ctx;
6c7a4dfd 7170 gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
dd2fc525 7171 gfc_omp_namelist *n;
6c7a4dfd
JJ		 7172 int list;
7173
7174 ctx.code = code;
6e2830c3
TS		 7175 ctx.sharing_clauses = new hash_set<gfc_symbol *>;
7176 ctx.private_iterators = new hash_set<gfc_symbol *>;
6c7a4dfd 7177 ctx.previous = omp_current_ctx;
41dbbb37 7178 ctx.is_openmp = true;
6c7a4dfd
JJ		 7179 omp_current_ctx = &ctx;
7180
7181 for (list = 0; list < OMP_LIST_NUM; list++)
f014c653
JJ		 7182 switch (list)
7183 {
7184 case OMP_LIST_SHARED:
7185 case OMP_LIST_PRIVATE:
7186 case OMP_LIST_FIRSTPRIVATE:
7187 case OMP_LIST_LASTPRIVATE:
7188 case OMP_LIST_REDUCTION:
e929ef53
TB		 7189 case OMP_LIST_REDUCTION_INSCAN:
7190 case OMP_LIST_REDUCTION_TASK:
7191 case OMP_LIST_IN_REDUCTION:
7192 case OMP_LIST_TASK_REDUCTION:
f014c653
JJ		 7193 case OMP_LIST_LINEAR:
7194 for (n = omp_clauses->lists[list]; n; n = n->next)
6e2830c3 7195 ctx.sharing_clauses->add (n->sym);
f014c653
JJ		 7196 break;
7197 default:
7198 break;
7199 }
6c7a4dfd 7200
f014c653
JJ		 7201 switch (code->op)
7202 {
61c2d476
TB		 7203 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
7204 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
f014c653
JJ		 7205 case EXEC_OMP_PARALLEL_DO:
7206 case EXEC_OMP_PARALLEL_DO_SIMD:
53d5b59c
TB		 7207 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
7208 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
f6bf436d
TB		 7209 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
7210 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
53d5b59c
TB		 7211 case EXEC_OMP_MASKED_TASKLOOP:
7212 case EXEC_OMP_MASKED_TASKLOOP_SIMD:
f6bf436d
TB		 7213 case EXEC_OMP_MASTER_TASKLOOP:
7214 case EXEC_OMP_MASTER_TASKLOOP_SIMD:
b4c3a85b
JJ		 7215 case EXEC_OMP_TARGET_PARALLEL_DO:
7216 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
f014c653
JJ		 7217 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
7218 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
7219 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
7220 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
cd30a0b8
JJ		 7221 case EXEC_OMP_TASKLOOP:
7222 case EXEC_OMP_TASKLOOP_SIMD:
f014c653
JJ		 7223 case EXEC_OMP_TEAMS_DISTRIBUTE:
7224 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
7225 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
7226 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
7227 gfc_resolve_omp_do_blocks (code, ns);
7228 break;
7229 default:
7230 gfc_resolve_blocks (code->block, ns);
7231 }
6c7a4dfd
JJ		 7232
7233 omp_current_ctx = ctx.previous;
6e2830c3
TS		 7234 delete ctx.sharing_clauses;
7235 delete ctx.private_iterators;
6c7a4dfd
JJ		 7236}
7237
edf1eac2 7238
c7d3bb76
JJ		 7239/* Save and clear openmp.c private state. */
7240
7241void
7242gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *state)
7243{
7244 state->ptrs[0] = omp_current_ctx;
7245 state->ptrs[1] = omp_current_do_code;
7246 state->ints[0] = omp_current_do_collapse;
7247 omp_current_ctx = NULL;
7248 omp_current_do_code = NULL;
7249 omp_current_do_collapse = 0;
7250}
7251
7252
7253/* Restore openmp.c private state from the saved state. */
7254
7255void
7256gfc_omp_restore_state (struct gfc_omp_saved_state *state)
7257{
46842bfe 7258 omp_current_ctx = (struct fortran_omp_context *) state->ptrs[0];
c7d3bb76
JJ		 7259 omp_current_do_code = (gfc_code *) state->ptrs[1];
7260 omp_current_do_collapse = state->ints[0];
7261}
7262
7263
6c7a4dfd
JJ		 7264/* Note a DO iterator variable. This is special in !$omp parallel
7265 construct, where they are predetermined private. */
7266
7267void
cd30a0b8 7268gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym, bool add_clause)
6c7a4dfd 7269{
cd30a0b8
JJ		 7270 if (omp_current_ctx == NULL)
7271 return;
7272
a68ab351
JJ		 7273 int i = omp_current_do_collapse;
7274 gfc_code *c = omp_current_do_code;
6c7a4dfd
JJ		 7275
7276 if (sym->attr.threadprivate)
7277 return;
7278
7279 /* !$omp do and !$omp parallel do iteration variable is predetermined
7280 private just in the !$omp do resp. !$omp parallel do construct,
7281 with no implications for the outer parallel constructs. */
a68ab351
JJ		 7282
7283 while (i-- >= 1)
7284 {
7285 if (code == c)
7286 return;
7287
7288 c = c->block->next;
7289 }
6c7a4dfd 7290
41dbbb37
TS		 7291 /* An openacc context may represent a data clause. Abort if so. */
7292 if (!omp_current_ctx->is_openmp && !oacc_is_loop (omp_current_ctx->code))
7293 return;
7294
b39c686b 7295 if (omp_current_ctx->sharing_clauses->contains (sym))
310e4472 7296 return;
6c7a4dfd 7297
cd30a0b8 7298 if (! omp_current_ctx->private_iterators->add (sym) && add_clause)
310e4472
JJ		 7299 {
7300 gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses;
dd2fc525 7301 gfc_omp_namelist *p;
310e4472 7302
dd2fc525 7303 p = gfc_get_omp_namelist ();
310e4472
JJ		 7304 p->sym = sym;
7305 p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
7306 omp_clauses->lists[OMP_LIST_PRIVATE] = p;
6c7a4dfd
JJ		 7307 }
7308}
7309
cd30a0b8
JJ		 7310static void
7311handle_local_var (gfc_symbol *sym)
7312{
7313 if (sym->attr.flavor != FL_VARIABLE
7314 || sym->as != NULL
7315 || (sym->ts.type != BT_INTEGER && sym->ts.type != BT_REAL))
7316 return;
7317 gfc_resolve_do_iterator (sym->ns->code, sym, false);
7318}
7319
7320void
7321gfc_resolve_omp_local_vars (gfc_namespace *ns)
7322{
7323 if (omp_current_ctx)
7324 gfc_traverse_ns (ns, handle_local_var);
7325}
edf1eac2 7326
6c7a4dfd
JJ		 7327static void
7328resolve_omp_do (gfc_code *code)
7329{
a68ab351
JJ		 7330 gfc_code *do_code, *c;
7331 int list, i, collapse;
dd2fc525 7332 gfc_omp_namelist *n;
6c7a4dfd 7333 gfc_symbol *dovar;
dd2fc525
JJ		 7334 const char *name;
7335 bool is_simd = false;
7336
7337 switch (code->op)
7338 {
f014c653
JJ		 7339 case EXEC_OMP_DISTRIBUTE: name = "!$OMP DISTRIBUTE"; break;
7340 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
7341 name = "!$OMP DISTRIBUTE PARALLEL DO";
7342 break;
7343 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
7344 name = "!$OMP DISTRIBUTE PARALLEL DO SIMD";
7345 is_simd = true;
7346 break;
7347 case EXEC_OMP_DISTRIBUTE_SIMD:
7348 name = "!$OMP DISTRIBUTE SIMD";
7349 is_simd = true;
7350 break;
dd2fc525
JJ		 7351 case EXEC_OMP_DO: name = "!$OMP DO"; break;
7352 case EXEC_OMP_DO_SIMD: name = "!$OMP DO SIMD"; is_simd = true; break;
178191e1 7353 case EXEC_OMP_LOOP: name = "!$OMP LOOP"; break;
dd2fc525
JJ		 7354 case EXEC_OMP_PARALLEL_DO: name = "!$OMP PARALLEL DO"; break;
7355 case EXEC_OMP_PARALLEL_DO_SIMD:
7356 name = "!$OMP PARALLEL DO SIMD";
f014c653
JJ		 7357 is_simd = true;
7358 break;
178191e1 7359 case EXEC_OMP_PARALLEL_LOOP: name = "!$OMP PARALLEL LOOP"; break;
53d5b59c
TB		 7360 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
7361 name = "!$OMP PARALLEL MASKED TASKLOOP";
7362 break;
7363 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
7364 name = "!$OMP PARALLEL MASKED TASKLOOP SIMD";
7365 is_simd = true;
7366 break;
f6bf436d
TB		 7367 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
7368 name = "!$OMP PARALLEL MASTER TASKLOOP";
7369 break;
7370 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
7371 name = "!$OMP PARALLEL MASTER TASKLOOP SIMD";
7372 is_simd = true;
7373 break;
53d5b59c
TB		 7374 case EXEC_OMP_MASKED_TASKLOOP: name = "!$OMP MASKED TASKLOOP"; break;
7375 case EXEC_OMP_MASKED_TASKLOOP_SIMD:
7376 name = "!$OMP MASKED TASKLOOP SIMD";
7377 is_simd = true;
7378 break;
f6bf436d
TB		 7379 case EXEC_OMP_MASTER_TASKLOOP: name = "!$OMP MASTER TASKLOOP"; break;
7380 case EXEC_OMP_MASTER_TASKLOOP_SIMD:
7381 name = "!$OMP MASTER TASKLOOP SIMD";
7382 is_simd = true;
7383 break;
dd2fc525 7384 case EXEC_OMP_SIMD: name = "!$OMP SIMD"; is_simd = true; break;
b4c3a85b
JJ		 7385 case EXEC_OMP_TARGET_PARALLEL_DO: name = "!$OMP TARGET PARALLEL DO"; break;
7386 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
7387 name = "!$OMP TARGET PARALLEL DO SIMD";
7388 is_simd = true;
7389 break;
178191e1
TB		 7390 case EXEC_OMP_TARGET_PARALLEL_LOOP:
7391 name = "!$OMP TARGET PARALLEL LOOP";
7392 break;
b4c3a85b
JJ		 7393 case EXEC_OMP_TARGET_SIMD:
7394 name = "!$OMP TARGET SIMD";
7395 is_simd = true;
7396 break;
f014c653 7397 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
b4c3a85b 7398 name = "!$OMP TARGET TEAMS DISTRIBUTE";
f014c653
JJ		 7399 break;
7400 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
7401 name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
7402 break;
7403 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
7404 name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
7405 is_simd = true;
7406 break;
7407 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
7408 name = "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
7409 is_simd = true;
7410 break;
178191e1 7411 case EXEC_OMP_TARGET_TEAMS_LOOP: name = "!$OMP TARGET TEAMS LOOP"; break;
b4c3a85b
JJ		 7412 case EXEC_OMP_TASKLOOP: name = "!$OMP TASKLOOP"; break;
7413 case EXEC_OMP_TASKLOOP_SIMD:
7414 name = "!$OMP TASKLOOP SIMD";
7415 is_simd = true;
7416 break;
7417 case EXEC_OMP_TEAMS_DISTRIBUTE: name = "!$OMP TEAMS DISTRIBUTE"; break;
f014c653
JJ		 7418 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
7419 name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
7420 break;
7421 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
7422 name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
7423 is_simd = true;
7424 break;
7425 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
7426 name = "!$OMP TEAMS DISTRIBUTE SIMD";
7427 is_simd = true;
7428 break;
178191e1 7429 case EXEC_OMP_TEAMS_LOOP: name = "!$OMP TEAMS LOOP"; break;
dd2fc525
JJ		 7430 default: gcc_unreachable ();
7431 }
6c7a4dfd
JJ		 7432
7433 if (code->ext.omp_clauses)
2ac33bca 7434 resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
6c7a4dfd
JJ		 7435
7436 do_code = code->block->next;
b4c3a85b
JJ		 7437 if (code->ext.omp_clauses->orderedc)
7438 collapse = code->ext.omp_clauses->orderedc;
7439 else
7440 {
7441 collapse = code->ext.omp_clauses->collapse;
7442 if (collapse <= 0)
7443 collapse = 1;
7444 }
a68ab351 7445 for (i = 1; i <= collapse; i++)
6c7a4dfd 7446 {
a68ab351
JJ		 7447 if (do_code->op == EXEC_DO_WHILE)
7448 {
dd2fc525
JJ		 7449 gfc_error ("%s cannot be a DO WHILE or DO without loop control "
7450 "at %L", name, &do_code->loc);
a68ab351
JJ		 7451 break;
7452 }
da7316cb
TB		 7453 if (do_code->op == EXEC_DO_CONCURRENT)
7454 {
7455 gfc_error ("%s cannot be a DO CONCURRENT loop at %L", name,
7456 &do_code->loc);
7457 break;
7458 }
6c7a4dfd
JJ		 7459 gcc_assert (do_code->op == EXEC_DO);
7460 if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
dd2fc525
JJ		 7461 gfc_error ("%s iteration variable must be of type integer at %L",
7462 name, &do_code->loc);
6c7a4dfd
JJ		 7463 dovar = do_code->ext.iterator->var->symtree->n.sym;
7464 if (dovar->attr.threadprivate)
dd2fc525
JJ		 7465 gfc_error ("%s iteration variable must not be THREADPRIVATE "
7466 "at %L", name, &do_code->loc);
6c7a4dfd
JJ		 7467 if (code->ext.omp_clauses)
7468 for (list = 0; list < OMP_LIST_NUM; list++)
0ec52417 7469 if (!is_simd || code->ext.omp_clauses->collapse > 1
dd2fc525 7470 ? (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE)
0ec52417
TB		 7471 : (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE
7472 && list != OMP_LIST_LINEAR))
6c7a4dfd
JJ		 7473 for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
7474 if (dovar == n->sym)
7475 {
0ec52417 7476 if (!is_simd || code->ext.omp_clauses->collapse > 1)
dd2fc525
JJ		 7477 gfc_error ("%s iteration variable present on clause "
7478 "other than PRIVATE or LASTPRIVATE at %L",
7479 name, &do_code->loc);
dd2fc525
JJ		 7480 else
7481 gfc_error ("%s iteration variable present on clause "
0ec52417
TB		 7482 "other than PRIVATE, LASTPRIVATE or "
7483 "LINEAR at %L", name, &do_code->loc);
6c7a4dfd
JJ		 7484 break;
7485 }
a68ab351
JJ		 7486 if (i > 1)
7487 {
7488 gfc_code *do_code2 = code->block->next;
7489 int j;
7490
7491 for (j = 1; j < i; j++)
7492 {
7493 gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
7494 if (dovar == ivar
7495 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
7496 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
7497 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
7498 {
dd2fc525
JJ		 7499 gfc_error ("%s collapsed loops don't form rectangular "
7500 "iteration space at %L", name, &do_code->loc);
a68ab351
JJ		 7501 break;
7502 }
a68ab351
JJ		 7503 do_code2 = do_code2->block->next;
7504 }
7505 }
a68ab351
JJ		 7506 for (c = do_code->next; c; c = c->next)
7507 if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
7508 {
dd2fc525
JJ		 7509 gfc_error ("collapsed %s loops not perfectly nested at %L",
7510 name, &c->loc);
a68ab351
JJ		 7511 break;
7512 }
57dd9f3b 7513 if (i == collapse || c)
a68ab351
JJ		 7514 break;
7515 do_code = do_code->block;
7516 if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE)
7517 {
dd2fc525
JJ		 7518 gfc_error ("not enough DO loops for collapsed %s at %L",
7519 name, &code->loc);
a68ab351
JJ		 7520 break;
7521 }
7522 do_code = do_code->next;
9c2934f4
JJ		 7523 if (do_code == NULL
7524 || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE))
a68ab351 7525 {
dd2fc525
JJ		 7526 gfc_error ("not enough DO loops for collapsed %s at %L",
7527 name, &code->loc);
a68ab351
JJ		 7528 break;
7529 }
6c7a4dfd
JJ		 7530 }
7531}
7532
41dbbb37 7533
41dbbb37
TS		 7534static gfc_statement
7535omp_code_to_statement (gfc_code *code)
7536{
7537 switch (code->op)
7538 {
7539 case EXEC_OMP_PARALLEL:
7540 return ST_OMP_PARALLEL;
53d5b59c
TB		 7541 case EXEC_OMP_PARALLEL_MASKED:
7542 return ST_OMP_PARALLEL_MASKED;
7543 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
7544 return ST_OMP_PARALLEL_MASKED_TASKLOOP;
7545 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
7546 return ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD;
0e3702f8
TB		 7547 case EXEC_OMP_PARALLEL_MASTER:
7548 return ST_OMP_PARALLEL_MASTER;
f6bf436d
TB		 7549 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
7550 return ST_OMP_PARALLEL_MASTER_TASKLOOP;
7551 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
7552 return ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD;
41dbbb37
TS		 7553 case EXEC_OMP_PARALLEL_SECTIONS:
7554 return ST_OMP_PARALLEL_SECTIONS;
7555 case EXEC_OMP_SECTIONS:
7556 return ST_OMP_SECTIONS;
7557 case EXEC_OMP_ORDERED:
7558 return ST_OMP_ORDERED;
7559 case EXEC_OMP_CRITICAL:
7560 return ST_OMP_CRITICAL;
53d5b59c
TB		 7561 case EXEC_OMP_MASKED:
7562 return ST_OMP_MASKED;
7563 case EXEC_OMP_MASKED_TASKLOOP:
7564 return ST_OMP_MASKED_TASKLOOP;
7565 case EXEC_OMP_MASKED_TASKLOOP_SIMD:
7566 return ST_OMP_MASKED_TASKLOOP_SIMD;
41dbbb37
TS		 7567 case EXEC_OMP_MASTER:
7568 return ST_OMP_MASTER;
f6bf436d
TB		 7569 case EXEC_OMP_MASTER_TASKLOOP:
7570 return ST_OMP_MASTER_TASKLOOP;
7571 case EXEC_OMP_MASTER_TASKLOOP_SIMD:
7572 return ST_OMP_MASTER_TASKLOOP_SIMD;
41dbbb37
TS		 7573 case EXEC_OMP_SINGLE:
7574 return ST_OMP_SINGLE;
7575 case EXEC_OMP_TASK:
7576 return ST_OMP_TASK;
7577 case EXEC_OMP_WORKSHARE:
7578 return ST_OMP_WORKSHARE;
7579 case EXEC_OMP_PARALLEL_WORKSHARE:
7580 return ST_OMP_PARALLEL_WORKSHARE;
7581 case EXEC_OMP_DO:
7582 return ST_OMP_DO;
178191e1
TB		 7583 case EXEC_OMP_LOOP:
7584 return ST_OMP_LOOP;
a38979d9
JJ		 7585 case EXEC_OMP_ATOMIC:
7586 return ST_OMP_ATOMIC;
7587 case EXEC_OMP_BARRIER:
7588 return ST_OMP_BARRIER;
7589 case EXEC_OMP_CANCEL:
7590 return ST_OMP_CANCEL;
7591 case EXEC_OMP_CANCELLATION_POINT:
7592 return ST_OMP_CANCELLATION_POINT;
77167196
TB		 7593 case EXEC_OMP_ERROR:
7594 return ST_OMP_ERROR;
a38979d9
JJ		 7595 case EXEC_OMP_FLUSH:
7596 return ST_OMP_FLUSH;
7597 case EXEC_OMP_DISTRIBUTE:
7598 return ST_OMP_DISTRIBUTE;
7599 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
7600 return ST_OMP_DISTRIBUTE_PARALLEL_DO;
7601 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
7602 return ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD;
7603 case EXEC_OMP_DISTRIBUTE_SIMD:
7604 return ST_OMP_DISTRIBUTE_SIMD;
7605 case EXEC_OMP_DO_SIMD:
7606 return ST_OMP_DO_SIMD;
005cff4e
TB		 7607 case EXEC_OMP_SCAN:
7608 return ST_OMP_SCAN;
f8d535f3
TB		 7609 case EXEC_OMP_SCOPE:
7610 return ST_OMP_SCOPE;
a38979d9
JJ		 7611 case EXEC_OMP_SIMD:
7612 return ST_OMP_SIMD;
7613 case EXEC_OMP_TARGET:
7614 return ST_OMP_TARGET;
7615 case EXEC_OMP_TARGET_DATA:
7616 return ST_OMP_TARGET_DATA;
7617 case EXEC_OMP_TARGET_ENTER_DATA:
7618 return ST_OMP_TARGET_ENTER_DATA;
7619 case EXEC_OMP_TARGET_EXIT_DATA:
7620 return ST_OMP_TARGET_EXIT_DATA;
7621 case EXEC_OMP_TARGET_PARALLEL:
7622 return ST_OMP_TARGET_PARALLEL;
7623 case EXEC_OMP_TARGET_PARALLEL_DO:
7624 return ST_OMP_TARGET_PARALLEL_DO;
7625 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
7626 return ST_OMP_TARGET_PARALLEL_DO_SIMD;
178191e1
TB		 7627 case EXEC_OMP_TARGET_PARALLEL_LOOP:
7628 return ST_OMP_TARGET_PARALLEL_LOOP;
a38979d9
JJ		 7629 case EXEC_OMP_TARGET_SIMD:
7630 return ST_OMP_TARGET_SIMD;
7631 case EXEC_OMP_TARGET_TEAMS:
7632 return ST_OMP_TARGET_TEAMS;
7633 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
7634 return ST_OMP_TARGET_TEAMS_DISTRIBUTE;
7635 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
7636 return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
7637 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
7638 return ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
7639 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
7640 return ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD;
178191e1
TB		 7641 case EXEC_OMP_TARGET_TEAMS_LOOP:
7642 return ST_OMP_TARGET_TEAMS_LOOP;
a38979d9
JJ		 7643 case EXEC_OMP_TARGET_UPDATE:
7644 return ST_OMP_TARGET_UPDATE;
7645 case EXEC_OMP_TASKGROUP:
7646 return ST_OMP_TASKGROUP;
7647 case EXEC_OMP_TASKLOOP:
7648 return ST_OMP_TASKLOOP;
7649 case EXEC_OMP_TASKLOOP_SIMD:
7650 return ST_OMP_TASKLOOP_SIMD;
7651 case EXEC_OMP_TASKWAIT:
7652 return ST_OMP_TASKWAIT;
7653 case EXEC_OMP_TASKYIELD:
7654 return ST_OMP_TASKYIELD;
7655 case EXEC_OMP_TEAMS:
7656 return ST_OMP_TEAMS;
7657 case EXEC_OMP_TEAMS_DISTRIBUTE:
7658 return ST_OMP_TEAMS_DISTRIBUTE;
7659 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
7660 return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO;
7661 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
7662 return ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
7663 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
7664 return ST_OMP_TEAMS_DISTRIBUTE_SIMD;
178191e1
TB		 7665 case EXEC_OMP_TEAMS_LOOP:
7666 return ST_OMP_TEAMS_LOOP;
a38979d9
JJ		 7667 case EXEC_OMP_PARALLEL_DO:
7668 return ST_OMP_PARALLEL_DO;
7669 case EXEC_OMP_PARALLEL_DO_SIMD:
7670 return ST_OMP_PARALLEL_DO_SIMD;
178191e1
TB		 7671 case EXEC_OMP_PARALLEL_LOOP:
7672 return ST_OMP_PARALLEL_LOOP;
cc193ac8
TB		 7673 case EXEC_OMP_DEPOBJ:
7674 return ST_OMP_DEPOBJ;
41dbbb37
TS		 7675 default:
7676 gcc_unreachable ();
7677 }
7678}
7679
7680static gfc_statement
7681oacc_code_to_statement (gfc_code *code)
7682{
7683 switch (code->op)
7684 {
7685 case EXEC_OACC_PARALLEL:
7686 return ST_OACC_PARALLEL;
7687 case EXEC_OACC_KERNELS:
7688 return ST_OACC_KERNELS;
62aee289
MR		 7689 case EXEC_OACC_SERIAL:
7690 return ST_OACC_SERIAL;
41dbbb37
TS		 7691 case EXEC_OACC_DATA:
7692 return ST_OACC_DATA;
7693 case EXEC_OACC_HOST_DATA:
7694 return ST_OACC_HOST_DATA;
7695 case EXEC_OACC_PARALLEL_LOOP:
7696 return ST_OACC_PARALLEL_LOOP;
7697 case EXEC_OACC_KERNELS_LOOP:
7698 return ST_OACC_KERNELS_LOOP;
62aee289
MR		 7699 case EXEC_OACC_SERIAL_LOOP:
7700 return ST_OACC_SERIAL_LOOP;
41dbbb37
TS		 7701 case EXEC_OACC_LOOP:
7702 return ST_OACC_LOOP;
4bf9e5a8
TS		 7703 case EXEC_OACC_ATOMIC:
7704 return ST_OACC_ATOMIC;
aa1b5696
JJ		 7705 case EXEC_OACC_ROUTINE:
7706 return ST_OACC_ROUTINE;
7707 case EXEC_OACC_UPDATE:
7708 return ST_OACC_UPDATE;
7709 case EXEC_OACC_WAIT:
7710 return ST_OACC_WAIT;
7711 case EXEC_OACC_CACHE:
7712 return ST_OACC_CACHE;
7713 case EXEC_OACC_ENTER_DATA:
7714 return ST_OACC_ENTER_DATA;
7715 case EXEC_OACC_EXIT_DATA:
7716 return ST_OACC_EXIT_DATA;
7717 case EXEC_OACC_DECLARE:
7718 return ST_OACC_DECLARE;
41dbbb37
TS		 7719 default:
7720 gcc_unreachable ();
7721 }
7722}
7723
7724static void
7725resolve_oacc_directive_inside_omp_region (gfc_code *code)
7726{
7727 if (omp_current_ctx != NULL && omp_current_ctx->is_openmp)
7728 {
7729 gfc_statement st = omp_code_to_statement (omp_current_ctx->code);
7730 gfc_statement oacc_st = oacc_code_to_statement (code);
7731 gfc_error ("The %s directive cannot be specified within "
7732 "a %s region at %L", gfc_ascii_statement (oacc_st),
7733 gfc_ascii_statement (st), &code->loc);
7734 }
7735}
7736
7737static void
7738resolve_omp_directive_inside_oacc_region (gfc_code *code)
7739{
7740 if (omp_current_ctx != NULL && !omp_current_ctx->is_openmp)
7741 {
7742 gfc_statement st = oacc_code_to_statement (omp_current_ctx->code);
7743 gfc_statement omp_st = omp_code_to_statement (code);
7744 gfc_error ("The %s directive cannot be specified within "
7745 "a %s region at %L", gfc_ascii_statement (omp_st),
7746 gfc_ascii_statement (st), &code->loc);
7747 }
7748}
7749
7750
7751static void
7752resolve_oacc_nested_loops (gfc_code *code, gfc_code* do_code, int collapse,
7753 const char *clause)
7754{
7755 gfc_symbol *dovar;
7756 gfc_code *c;
7757 int i;
7758
7759 for (i = 1; i <= collapse; i++)
7760 {
7761 if (do_code->op == EXEC_DO_WHILE)
7762 {
7763 gfc_error ("!$ACC LOOP cannot be a DO WHILE or DO without loop control "
7764 "at %L", &do_code->loc);
7765 break;
7766 }
affd7d47
CP		 7767 if (do_code->op == EXEC_DO_CONCURRENT)
7768 {
7769 gfc_error ("!$ACC LOOP cannot be a DO CONCURRENT loop at %L",
7770 &do_code->loc);
7771 break;
7772 }
7773 gcc_assert (do_code->op == EXEC_DO);
41dbbb37
TS		 7774 if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
7775 gfc_error ("!$ACC LOOP iteration variable must be of type integer at %L",
7776 &do_code->loc);
7777 dovar = do_code->ext.iterator->var->symtree->n.sym;
7778 if (i > 1)
7779 {
7780 gfc_code *do_code2 = code->block->next;
7781 int j;
7782
7783 for (j = 1; j < i; j++)
7784 {
7785 gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
7786 if (dovar == ivar
7787 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
7788 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
7789 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
7790 {
24f80aa4
JJ		 7791 gfc_error ("!$ACC LOOP %s loops don't form rectangular "
7792 "iteration space at %L", clause, &do_code->loc);
41dbbb37
TS		 7793 break;
7794 }
41dbbb37
TS		 7795 do_code2 = do_code2->block->next;
7796 }
7797 }
7798 if (i == collapse)
7799 break;
7800 for (c = do_code->next; c; c = c->next)
7801 if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
7802 {
7803 gfc_error ("%s !$ACC LOOP loops not perfectly nested at %L",
7804 clause, &c->loc);
7805 break;
7806 }
7807 if (c)
7808 break;
7809 do_code = do_code->block;
7810 if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
7811 && do_code->op != EXEC_DO_CONCURRENT)
7812 {
7813 gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
7814 clause, &code->loc);
7815 break;
7816 }
7817 do_code = do_code->next;
7818 if (do_code == NULL
7819 || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
7820 && do_code->op != EXEC_DO_CONCURRENT))
7821 {
7822 gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
7823 clause, &code->loc);
7824 break;
7825 }
7826 }
7827}
7828
7829
41dbbb37
TS		 7830static void
7831resolve_oacc_loop_blocks (gfc_code *code)
7832{
41dbbb37
TS		 7833 if (!oacc_is_loop (code))
7834 return;
7835
7a5e4956
CP		 7836 if (code->ext.omp_clauses->tile_list && code->ext.omp_clauses->gang
7837 && code->ext.omp_clauses->worker && code->ext.omp_clauses->vector)
41dbbb37
TS		 7838 gfc_error ("Tiled loop cannot be parallelized across gangs, workers and "
7839 "vectors at the same time at %L", &code->loc);
7840
41dbbb37
TS		 7841 if (code->ext.omp_clauses->tile_list)
7842 {
7843 gfc_expr_list *el;
41dbbb37
TS		 7844 for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
7845 {
41dbbb37 7846 if (el->expr == NULL)
7a5e4956
CP		 7847 {
7848 /* NULL expressions are used to represent '*' arguments.
02889d23 7849 Convert those to a 0 expressions. */
7a5e4956
CP		 7850 el->expr = gfc_get_constant_expr (BT_INTEGER,
7851 gfc_default_integer_kind,
7852 &code->loc);
02889d23 7853 mpz_set_si (el->expr->value.integer, 0);
7a5e4956
CP		 7854 }
7855 else
7856 {
b4c3a85b 7857 resolve_positive_int_expr (el->expr, "TILE");
7a5e4956
CP		 7858 if (el->expr->expr_type != EXPR_CONSTANT)
7859 gfc_error ("TILE requires constant expression at %L",
7860 &code->loc);
7861 }
41dbbb37 7862 }
41dbbb37
TS		 7863 }
7864}
7865
7866
7867void
7868gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns)
7869{
7870 fortran_omp_context ctx;
b39c686b
TS		 7871 gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
7872 gfc_omp_namelist *n;
7873 int list;
41dbbb37
TS		 7874
7875 resolve_oacc_loop_blocks (code);
7876
7877 ctx.code = code;
b39c686b 7878 ctx.sharing_clauses = new hash_set<gfc_symbol *>;
41dbbb37
TS		 7879 ctx.private_iterators = new hash_set<gfc_symbol *>;
7880 ctx.previous = omp_current_ctx;
7881 ctx.is_openmp = false;
7882 omp_current_ctx = &ctx;
7883
b39c686b
TS		 7884 for (list = 0; list < OMP_LIST_NUM; list++)
7885 switch (list)
7886 {
7887 case OMP_LIST_PRIVATE:
7888 for (n = omp_clauses->lists[list]; n; n = n->next)
7889 ctx.sharing_clauses->add (n->sym);
7890 break;
7891 default:
7892 break;
7893 }
7894
41dbbb37
TS		 7895 gfc_resolve_blocks (code->block, ns);
7896
7897 omp_current_ctx = ctx.previous;
b39c686b 7898 delete ctx.sharing_clauses;
41dbbb37
TS		 7899 delete ctx.private_iterators;
7900}
7901
7902
7903static void
7904resolve_oacc_loop (gfc_code *code)
7905{
7906 gfc_code *do_code;
7907 int collapse;
7908
7909 if (code->ext.omp_clauses)
2ac33bca 7910 resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
41dbbb37
TS		 7911
7912 do_code = code->block->next;
7913 collapse = code->ext.omp_clauses->collapse;
7914
2c52b288
TB		 7915 /* Both collapsed and tiled loops are lowered the same way, but are not
7916 compatible. In gfc_trans_omp_do, the tile is prioritized. */
7917 if (code->ext.omp_clauses->tile_list)
7918 {
7919 int num = 0;
7920 gfc_expr_list *el;
7921 for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
7922 ++num;
7923 resolve_oacc_nested_loops (code, code->block->next, num, "tiled");
7924 return;
7925 }
7926
41dbbb37
TS		 7927 if (collapse <= 0)
7928 collapse = 1;
7929 resolve_oacc_nested_loops (code, do_code, collapse, "collapsed");
7930}
7931
41dbbb37
TS		 7932void
7933gfc_resolve_oacc_declare (gfc_namespace *ns)
7934{
7935 int list;
7936 gfc_omp_namelist *n;
dc7a8b4b 7937 gfc_oacc_declare *oc;
41dbbb37 7938
dc7a8b4b 7939 if (ns->oacc_declare == NULL)
41dbbb37
TS		 7940 return;
7941
dc7a8b4b
JN		 7942 for (oc = ns->oacc_declare; oc; oc = oc->next)
7943 {
cc9e07a6 7944 for (list = 0; list < OMP_LIST_NUM; list++)
dc7a8b4b
JN		 7945 for (n = oc->clauses->lists[list]; n; n = n->next)
7946 {
7947 n->sym->mark = 0;
ac4a7836
TB		 7948 if (n->sym->attr.flavor != FL_VARIABLE
7949 && (n->sym->attr.flavor != FL_PROCEDURE
7950 || n->sym->result != n->sym))
ab44754e
CP		 7951 {
7952 gfc_error ("Object %qs is not a variable at %L",
7953 n->sym->name, &oc->loc);
7954 continue;
7955 }
41dbbb37 7956
dc7a8b4b
JN		 7957 if (n->expr && n->expr->ref->type == REF_ARRAY)
7958 {
7959 gfc_error ("Array sections: %qs not allowed in"
e711928b 7960 " !$ACC DECLARE at %L", n->sym->name, &oc->loc);
dc7a8b4b
JN		 7961 continue;
7962 }
7963 }
41dbbb37 7964
dc7a8b4b
JN		 7965 for (n = oc->clauses->lists[OMP_LIST_DEVICE_RESIDENT]; n; n = n->next)
7966 check_array_not_assumed (n->sym, oc->loc, "DEVICE_RESIDENT");
7967 }
41dbbb37 7968
dc7a8b4b
JN		 7969 for (oc = ns->oacc_declare; oc; oc = oc->next)
7970 {
cc9e07a6 7971 for (list = 0; list < OMP_LIST_NUM; list++)
dc7a8b4b
JN		 7972 for (n = oc->clauses->lists[list]; n; n = n->next)
7973 {
7974 if (n->sym->mark)
7975 {
7976 gfc_error ("Symbol %qs present on multiple clauses at %L",
7977 n->sym->name, &oc->loc);
7978 continue;
7979 }
7980 else
7981 n->sym->mark = 1;
7982 }
7983 }
41dbbb37 7984
dc7a8b4b
JN		 7985 for (oc = ns->oacc_declare; oc; oc = oc->next)
7986 {
cc9e07a6 7987 for (list = 0; list < OMP_LIST_NUM; list++)
dc7a8b4b
JN		 7988 for (n = oc->clauses->lists[list]; n; n = n->next)
7989 n->sym->mark = 0;
7990 }
7991}
41dbbb37 7992
f6bf4bc1
TS		 7993
7994void
7995gfc_resolve_oacc_routines (gfc_namespace *ns)
7996{
7997 for (gfc_oacc_routine_name *orn = ns->oacc_routine_names;
7998 orn;
7999 orn = orn->next)
8000 {
8001 gfc_symbol *sym = orn->sym;
8002 if (!sym->attr.external
8003 && !sym->attr.function
8004 && !sym->attr.subroutine)
8005 {
8006 gfc_error ("NAME %qs does not refer to a subroutine or function"
8007 " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
8008 continue;
8009 }
2e4182ae
TS		 8010 if (!gfc_add_omp_declare_target (&sym->attr, sym->name, &orn->loc))
8011 {
8012 gfc_error ("NAME %qs invalid"
8013 " in !$ACC ROUTINE ( NAME ) at %L", sym->name, &orn->loc);
8014 continue;
8015 }
f6bf4bc1
TS		 8016 }
8017}
8018
8019
41dbbb37
TS		 8020void
8021gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
8022{
8023 resolve_oacc_directive_inside_omp_region (code);
8024
8025 switch (code->op)
8026 {
8027 case EXEC_OACC_PARALLEL:
8028 case EXEC_OACC_KERNELS:
62aee289 8029 case EXEC_OACC_SERIAL:
41dbbb37
TS		 8030 case EXEC_OACC_DATA:
8031 case EXEC_OACC_HOST_DATA:
8032 case EXEC_OACC_UPDATE:
8033 case EXEC_OACC_ENTER_DATA:
8034 case EXEC_OACC_EXIT_DATA:
8035 case EXEC_OACC_WAIT:
33497fd2 8036 case EXEC_OACC_CACHE:
2ac33bca 8037 resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
41dbbb37
TS		 8038 break;
8039 case EXEC_OACC_PARALLEL_LOOP:
8040 case EXEC_OACC_KERNELS_LOOP:
62aee289 8041 case EXEC_OACC_SERIAL_LOOP:
41dbbb37
TS		 8042 case EXEC_OACC_LOOP:
8043 resolve_oacc_loop (code);
8044 break;
4bf9e5a8
TS		 8045 case EXEC_OACC_ATOMIC:
8046 resolve_omp_atomic (code);
8047 break;
41dbbb37
TS		 8048 default:
8049 break;
8050 }
8051}
8052
edf1eac2 8053
6c7a4dfd
JJ		 8054/* Resolve OpenMP directive clauses and check various requirements
8055 of each directive. */
8056
8057void
005cff4e 8058gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns)
6c7a4dfd 8059{
41dbbb37
TS		 8060 resolve_omp_directive_inside_oacc_region (code);
8061
602b8523
TB		 8062 if (code->op != EXEC_OMP_ATOMIC)
8063 gfc_maybe_initialize_eh ();
8064
6c7a4dfd
JJ		 8065 switch (code->op)
8066 {
f014c653
JJ		 8067 case EXEC_OMP_DISTRIBUTE:
8068 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
8069 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
8070 case EXEC_OMP_DISTRIBUTE_SIMD:
6c7a4dfd 8071 case EXEC_OMP_DO:
dd2fc525 8072 case EXEC_OMP_DO_SIMD:
178191e1 8073 case EXEC_OMP_LOOP:
6c7a4dfd 8074 case EXEC_OMP_PARALLEL_DO:
dd2fc525 8075 case EXEC_OMP_PARALLEL_DO_SIMD:
178191e1 8076 case EXEC_OMP_PARALLEL_LOOP:
53d5b59c
TB		 8077 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
8078 case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
f6bf436d
TB		 8079 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
8080 case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
53d5b59c
TB		 8081 case EXEC_OMP_MASKED_TASKLOOP:
8082 case EXEC_OMP_MASKED_TASKLOOP_SIMD:
f6bf436d
TB		 8083 case EXEC_OMP_MASTER_TASKLOOP:
8084 case EXEC_OMP_MASTER_TASKLOOP_SIMD:
dd2fc525 8085 case EXEC_OMP_SIMD:
b4c3a85b
JJ		 8086 case EXEC_OMP_TARGET_PARALLEL_DO:
8087 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
178191e1 8088 case EXEC_OMP_TARGET_PARALLEL_LOOP:
b4c3a85b 8089 case EXEC_OMP_TARGET_SIMD:
f014c653
JJ		 8090 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
8091 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
8092 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
8093 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
178191e1 8094 case EXEC_OMP_TARGET_TEAMS_LOOP:
b4c3a85b
JJ		 8095 case EXEC_OMP_TASKLOOP:
8096 case EXEC_OMP_TASKLOOP_SIMD:
f014c653
JJ		 8097 case EXEC_OMP_TEAMS_DISTRIBUTE:
8098 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
8099 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
8100 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
178191e1 8101 case EXEC_OMP_TEAMS_LOOP:
6c7a4dfd
JJ		 8102 resolve_omp_do (code);
8103 break;
dd2fc525 8104 case EXEC_OMP_CANCEL:
77167196 8105 case EXEC_OMP_ERROR:
53d5b59c 8106 case EXEC_OMP_MASKED:
6c7a4dfd
JJ		 8107 case EXEC_OMP_PARALLEL_WORKSHARE:
8108 case EXEC_OMP_PARALLEL:
53d5b59c 8109 case EXEC_OMP_PARALLEL_MASKED:
0e3702f8 8110 case EXEC_OMP_PARALLEL_MASTER:
6c7a4dfd 8111 case EXEC_OMP_PARALLEL_SECTIONS:
f8d535f3 8112 case EXEC_OMP_SCOPE:
6c7a4dfd
JJ		 8113 case EXEC_OMP_SECTIONS:
8114 case EXEC_OMP_SINGLE:
f014c653
JJ		 8115 case EXEC_OMP_TARGET:
8116 case EXEC_OMP_TARGET_DATA:
b4c3a85b
JJ		 8117 case EXEC_OMP_TARGET_ENTER_DATA:
8118 case EXEC_OMP_TARGET_EXIT_DATA:
8119 case EXEC_OMP_TARGET_PARALLEL:
f014c653 8120 case EXEC_OMP_TARGET_TEAMS:
adb3f093 8121 case EXEC_OMP_TASK:
9a5de4d5 8122 case EXEC_OMP_TASKWAIT:
f014c653 8123 case EXEC_OMP_TEAMS:
dd2fc525 8124 case EXEC_OMP_WORKSHARE:
a61c4964 8125 case EXEC_OMP_DEPOBJ:
6c7a4dfd 8126 if (code->ext.omp_clauses)
2ac33bca 8127 resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
6c7a4dfd 8128 break;
f014c653
JJ		 8129 case EXEC_OMP_TARGET_UPDATE:
8130 if (code->ext.omp_clauses)
2ac33bca 8131 resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
f014c653
JJ		 8132 if (code->ext.omp_clauses == NULL
8133 || (code->ext.omp_clauses->lists[OMP_LIST_TO] == NULL
8134 && code->ext.omp_clauses->lists[OMP_LIST_FROM] == NULL))
8135 gfc_error ("OMP TARGET UPDATE at %L requires at least one TO or "
8136 "FROM clause", &code->loc);
8137 break;
6c7a4dfd 8138 case EXEC_OMP_ATOMIC:
1fc5e7ef 8139 resolve_omp_clauses (code, code->block->ext.omp_clauses, NULL);
6c7a4dfd
JJ		 8140 resolve_omp_atomic (code);
8141 break;
c7c24828 8142 case EXEC_OMP_CRITICAL:
20d0d652 8143 resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
c7c24828
TB		 8144 if (!code->ext.omp_clauses->critical_name
8145 && code->ext.omp_clauses->hint
8146 && code->ext.omp_clauses->hint->ts.type == BT_INTEGER
8147 && code->ext.omp_clauses->hint->expr_type == EXPR_CONSTANT
8148 && mpz_sgn (code->ext.omp_clauses->hint->value.integer) != 0)
8149 gfc_error ("OMP CRITICAL at %L with HINT clause requires a NAME, "
8150 "except when omp_sync_hint_none is used", &code->loc);
8151 break;
005cff4e
TB		 8152 case EXEC_OMP_SCAN:
8153 /* Flag is only used to checking, hence, it is unset afterwards. */
8154 if (!code->ext.omp_clauses->if_present)
8155 gfc_error ("Unexpected !$OMP SCAN at %L outside loop construct with "
8156 "%<inscan%> REDUCTION clause", &code->loc);
8157 code->ext.omp_clauses->if_present = false;
8158 resolve_omp_clauses (code, code->ext.omp_clauses, ns);
8159 break;
6c7a4dfd
JJ		 8160 default:
8161 break;
8162 }
8163}
dd2fc525
JJ		 8164
8165/* Resolve !$omp declare simd constructs in NS. */
8166
8167void
8168gfc_resolve_omp_declare_simd (gfc_namespace *ns)
8169{
8170 gfc_omp_declare_simd *ods;
8171
8172 for (ods = ns->omp_declare_simd; ods; ods = ods->next)
8173 {
b4c3a85b
JJ		 8174 if (ods->proc_name != NULL
8175 && ods->proc_name != ns->proc_name)
f014c653 8176 gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure "
c4100eae 8177 "%qs at %L", ns->proc_name->name, &ods->where);
dd2fc525 8178 if (ods->clauses)
2ac33bca 8179 resolve_omp_clauses (NULL, ods->clauses, ns);
dd2fc525
JJ		 8180 }
8181}
5f23671d
JJ		 8182
8183struct omp_udr_callback_data
8184{
8185 gfc_omp_udr *omp_udr;
8186 bool is_initializer;
8187};
8188
8189static int
8190omp_udr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
8191 void *data)
8192{
8193 struct omp_udr_callback_data *cd = (struct omp_udr_callback_data *) data;
8194 if ((*e)->expr_type == EXPR_VARIABLE)
8195 {
8196 if (cd->is_initializer)
8197 {
8198 if ((*e)->symtree->n.sym != cd->omp_udr->omp_priv
8199 && (*e)->symtree->n.sym != cd->omp_udr->omp_orig)
8200 gfc_error ("Variable other than OMP_PRIV or OMP_ORIG used in "
8201 "INITIALIZER clause of !$OMP DECLARE REDUCTION at %L",
8202 &(*e)->where);
8203 }
8204 else
8205 {
8206 if ((*e)->symtree->n.sym != cd->omp_udr->omp_out
8207 && (*e)->symtree->n.sym != cd->omp_udr->omp_in)
8208 gfc_error ("Variable other than OMP_OUT or OMP_IN used in "
8209 "combiner of !$OMP DECLARE REDUCTION at %L",
8210 &(*e)->where);
8211 }
8212 }
5f23671d
JJ		 8213 return 0;
8214}
8215
8216/* Resolve !$omp declare reduction constructs. */
8217
8218static void
8219gfc_resolve_omp_udr (gfc_omp_udr *omp_udr)
8220{
8221 gfc_actual_arglist *a;
8222 const char *predef_name = NULL;
8223
5f23671d
JJ		 8224 switch (omp_udr->rop)
8225 {
8226 case OMP_REDUCTION_PLUS:
8227 case OMP_REDUCTION_TIMES:
8228 case OMP_REDUCTION_MINUS:
8229 case OMP_REDUCTION_AND:
8230 case OMP_REDUCTION_OR:
8231 case OMP_REDUCTION_EQV:
8232 case OMP_REDUCTION_NEQV:
8233 case OMP_REDUCTION_MAX:
8234 case OMP_REDUCTION_USER:
8235 break;
8236 default:
8237 gfc_error ("Invalid operator for !$OMP DECLARE REDUCTION %s at %L",
8238 omp_udr->name, &omp_udr->where);
8239 return;
8240 }
8241
8242 if (gfc_omp_udr_predef (omp_udr->rop, omp_udr->name,
8243 &omp_udr->ts, &predef_name))
8244 {
8245 if (predef_name)
8246 gfc_error_now ("Redefinition of predefined %s "
8247 "!$OMP DECLARE REDUCTION at %L",
8248 predef_name, &omp_udr->where);
8249 else
8250 gfc_error_now ("Redefinition of predefined "
8251 "!$OMP DECLARE REDUCTION at %L", &omp_udr->where);
8252 return;
8253 }
8254
8255 if (omp_udr->ts.type == BT_CHARACTER
8256 && omp_udr->ts.u.cl->length
8257 && omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
8258 {
8259 gfc_error ("CHARACTER length in !$OMP DECLARE REDUCTION %s not "
8260 "constant at %L", omp_udr->name, &omp_udr->where);
8261 return;
8262 }
8263
8264 struct omp_udr_callback_data cd;
8265 cd.omp_udr = omp_udr;
8266 cd.is_initializer = false;
8267 gfc_code_walker (&omp_udr->combiner_ns->code, gfc_dummy_code_callback,
8268 omp_udr_callback, &cd);
8269 if (omp_udr->combiner_ns->code->op == EXEC_CALL)
8270 {
8271 for (a = omp_udr->combiner_ns->code->ext.actual; a; a = a->next)
8272 if (a->expr == NULL)
8273 break;
8274 if (a)
8275 gfc_error ("Subroutine call with alternate returns in combiner "
8276 "of !$OMP DECLARE REDUCTION at %L",
8277 &omp_udr->combiner_ns->code->loc);
5f23671d
JJ		 8278 }
8279 if (omp_udr->initializer_ns)
8280 {
8281 cd.is_initializer = true;
8282 gfc_code_walker (&omp_udr->initializer_ns->code, gfc_dummy_code_callback,
8283 omp_udr_callback, &cd);
8284 if (omp_udr->initializer_ns->code->op == EXEC_CALL)
8285 {
8286 for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
8287 if (a->expr == NULL)
8288 break;
8289 if (a)
8290 gfc_error ("Subroutine call with alternate returns in "
8291 "INITIALIZER clause of !$OMP DECLARE REDUCTION "
8292 "at %L", &omp_udr->initializer_ns->code->loc);
8293 for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
8294 if (a->expr
8295 && a->expr->expr_type == EXPR_VARIABLE
8296 && a->expr->symtree->n.sym == omp_udr->omp_priv
8297 && a->expr->ref == NULL)
8298 break;
8299 if (a == NULL)
8300 gfc_error ("One of actual subroutine arguments in INITIALIZER "
8301 "clause of !$OMP DECLARE REDUCTION must be OMP_PRIV "
8302 "at %L", &omp_udr->initializer_ns->code->loc);
5f23671d
JJ		 8303 }
8304 }
8305 else if (omp_udr->ts.type == BT_DERIVED
8306 && !gfc_has_default_initializer (omp_udr->ts.u.derived))
8307 {
8308 gfc_error ("Missing INITIALIZER clause for !$OMP DECLARE REDUCTION "
8309 "of derived type without default initializer at %L",
8310 &omp_udr->where);
8311 return;
8312 }
8313}
8314
8315void
8316gfc_resolve_omp_udrs (gfc_symtree *st)
8317{
8318 gfc_omp_udr *omp_udr;
8319
8320 if (st == NULL)
8321 return;
8322 gfc_resolve_omp_udrs (st->left);
8323 gfc_resolve_omp_udrs (st->right);
8324 for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
8325 gfc_resolve_omp_udr (omp_udr);
8326}
Mirror of https://gcc.gnu.org/git/gcc.git