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