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