Bug Summary

File:build/gcc/fortran/openmp.c
Warning:line 5977, column 16
Although the value stored to 'c' is used in the enclosing expression, the value is never actually read from 'c'

Annotated Source Code

Press '?' to see keyboard shortcuts

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