?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Fix memory leak in tree-vect-slp.c
[official-gcc.git] / gcc / fortran / openmp.c
blob1481719f6e695ecbc375a1f95813270a8467dc8d
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 match
1415 gfc_match_oacc_parallel_loop (void)
1416 {
1417 gfc_omp_clauses *c;
1418 if (gfc_match_omp_clauses (&c, OACC_PARALLEL_LOOP_CLAUSES, false, false,
1419 true) != MATCH_YES)
1420 return MATCH_ERROR;
1421
1422 new_st.op = EXEC_OACC_PARALLEL_LOOP;
1423 new_st.ext.omp_clauses = c;
1424 return MATCH_YES;
1425 }
1426
1427
1428 match
1429 gfc_match_oacc_parallel (void)
1430 {
1431 gfc_omp_clauses *c;
1432 if (gfc_match_omp_clauses (&c, OACC_PARALLEL_CLAUSES, false, false, true)
1433 != MATCH_YES)
1434 return MATCH_ERROR;
1435
1436 new_st.op = EXEC_OACC_PARALLEL;
1437 new_st.ext.omp_clauses = c;
1438 return MATCH_YES;
1439 }
1440
1441
1442 match
1443 gfc_match_oacc_kernels_loop (void)
1444 {
1445 gfc_omp_clauses *c;
1446 if (gfc_match_omp_clauses (&c, OACC_KERNELS_LOOP_CLAUSES, false, false,
1447 true) != MATCH_YES)
1448 return MATCH_ERROR;
1449
1450 new_st.op = EXEC_OACC_KERNELS_LOOP;
1451 new_st.ext.omp_clauses = c;
1452 return MATCH_YES;
1453 }
1454
1455
1456 match
1457 gfc_match_oacc_kernels (void)
1458 {
1459 gfc_omp_clauses *c;
1460 if (gfc_match_omp_clauses (&c, OACC_KERNELS_CLAUSES, false, false, true)
1461 != MATCH_YES)
1462 return MATCH_ERROR;
1463
1464 new_st.op = EXEC_OACC_KERNELS;
1465 new_st.ext.omp_clauses = c;
1466 return MATCH_YES;
1467 }
1468
1469
1470 match
1471 gfc_match_oacc_data (void)
1472 {
1473 gfc_omp_clauses *c;
1474 if (gfc_match_omp_clauses (&c, OACC_DATA_CLAUSES, false, false, true)
1475 != MATCH_YES)
1476 return MATCH_ERROR;
1477
1478 new_st.op = EXEC_OACC_DATA;
1479 new_st.ext.omp_clauses = c;
1480 return MATCH_YES;
1481 }
1482
1483
1484 match
1485 gfc_match_oacc_host_data (void)
1486 {
1487 gfc_omp_clauses *c;
1488 if (gfc_match_omp_clauses (&c, OACC_HOST_DATA_CLAUSES, false, false, true)
1489 != MATCH_YES)
1490 return MATCH_ERROR;
1491
1492 new_st.op = EXEC_OACC_HOST_DATA;
1493 new_st.ext.omp_clauses = c;
1494 return MATCH_YES;
1495 }
1496
1497
1498 match
1499 gfc_match_oacc_loop (void)
1500 {
1501 gfc_omp_clauses *c;
1502 if (gfc_match_omp_clauses (&c, OACC_LOOP_CLAUSES, false, false, true)
1503 != MATCH_YES)
1504 return MATCH_ERROR;
1505
1506 new_st.op = EXEC_OACC_LOOP;
1507 new_st.ext.omp_clauses = c;
1508 return MATCH_YES;
1509 }
1510
1511
1512 match
1513 gfc_match_oacc_declare (void)
1514 {
1515 gfc_omp_clauses *c;
1516 gfc_omp_namelist *n;
1517 gfc_namespace *ns = gfc_current_ns;
1518 gfc_oacc_declare *new_oc;
1519 bool module_var = false;
1520 locus where = gfc_current_locus;
1521
1522 if (gfc_match_omp_clauses (&c, OACC_DECLARE_CLAUSES, false, false, true)
1523 != MATCH_YES)
1524 return MATCH_ERROR;
1525
1526 for (n = c->lists[OMP_LIST_DEVICE_RESIDENT]; n != NULL; n = n->next)
1527 n->sym->attr.oacc_declare_device_resident = 1;
1528
1529 for (n = c->lists[OMP_LIST_LINK]; n != NULL; n = n->next)
1530 n->sym->attr.oacc_declare_link = 1;
1531
1532 for (n = c->lists[OMP_LIST_MAP]; n != NULL; n = n->next)
1533 {
1534 gfc_symbol *s = n->sym;
1535
1536 if (s->ns->proc_name && s->ns->proc_name->attr.proc == PROC_MODULE)
1537 {
1538 if (n->u.map_op != OMP_MAP_FORCE_ALLOC
1539 && n->u.map_op != OMP_MAP_FORCE_TO)
1540 {
1541 gfc_error ("Invalid clause in module with $!ACC DECLARE at %L",
1542 &where);
1543 return MATCH_ERROR;
1544 }
1545
1546 module_var = true;
1547 }
1548
1549 if (s->attr.use_assoc)
1550 {
1551 gfc_error ("Variable is USE-associated with $!ACC DECLARE at %L",
1552 &where);
1553 return MATCH_ERROR;
1554 }
1555
1556 if ((s->attr.dimension || s->attr.codimension)
1557 && s->attr.dummy && s->as->type != AS_EXPLICIT)
1558 {
1559 gfc_error ("Assumed-size dummy array with $!ACC DECLARE at %L",
1560 &where);
1561 return MATCH_ERROR;
1562 }
1563
1564 switch (n->u.map_op)
1565 {
1566 case OMP_MAP_FORCE_ALLOC:
1567 s->attr.oacc_declare_create = 1;
1568 break;
1569
1570 case OMP_MAP_FORCE_TO:
1571 s->attr.oacc_declare_copyin = 1;
1572 break;
1573
1574 case OMP_MAP_FORCE_DEVICEPTR:
1575 s->attr.oacc_declare_deviceptr = 1;
1576 break;
1577
1578 default:
1579 break;
1580 }
1581 }
1582
1583 new_oc = gfc_get_oacc_declare ();
1584 new_oc->next = ns->oacc_declare;
1585 new_oc->module_var = module_var;
1586 new_oc->clauses = c;
1587 new_oc->loc = gfc_current_locus;
1588 ns->oacc_declare = new_oc;
1589
1590 return MATCH_YES;
1591 }
1592
1593
1594 match
1595 gfc_match_oacc_update (void)
1596 {
1597 gfc_omp_clauses *c;
1598 locus here = gfc_current_locus;
1599
1600 if (gfc_match_omp_clauses (&c, OACC_UPDATE_CLAUSES, false, false, true)
1601 != MATCH_YES)
1602 return MATCH_ERROR;
1603
1604 if (!c->lists[OMP_LIST_MAP])
1605 {
1606 gfc_error ("%<acc update%> must contain at least one "
1607 "%<device%> or %<host%> or %<self%> clause at %L", &here);
1608 return MATCH_ERROR;
1609 }
1610
1611 new_st.op = EXEC_OACC_UPDATE;
1612 new_st.ext.omp_clauses = c;
1613 return MATCH_YES;
1614 }
1615
1616
1617 match
1618 gfc_match_oacc_enter_data (void)
1619 {
1620 gfc_omp_clauses *c;
1621 if (gfc_match_omp_clauses (&c, OACC_ENTER_DATA_CLAUSES, false, false, true)
1622 != MATCH_YES)
1623 return MATCH_ERROR;
1624
1625 new_st.op = EXEC_OACC_ENTER_DATA;
1626 new_st.ext.omp_clauses = c;
1627 return MATCH_YES;
1628 }
1629
1630
1631 match
1632 gfc_match_oacc_exit_data (void)
1633 {
1634 gfc_omp_clauses *c;
1635 if (gfc_match_omp_clauses (&c, OACC_EXIT_DATA_CLAUSES, false, false, true)
1636 != MATCH_YES)
1637 return MATCH_ERROR;
1638
1639 new_st.op = EXEC_OACC_EXIT_DATA;
1640 new_st.ext.omp_clauses = c;
1641 return MATCH_YES;
1642 }
1643
1644
1645 match
1646 gfc_match_oacc_wait (void)
1647 {
1648 gfc_omp_clauses *c = gfc_get_omp_clauses ();
1649 gfc_expr_list *wait_list = NULL, *el;
1650
1651 match_oacc_expr_list (" (", &wait_list, true);
1652 gfc_match_omp_clauses (&c, OACC_WAIT_CLAUSES, false, false, true);
1653
1654 if (gfc_match_omp_eos () != MATCH_YES)
1655 {
1656 gfc_error ("Unexpected junk in !$ACC WAIT at %C");
1657 return MATCH_ERROR;
1658 }
1659
1660 if (wait_list)
1661 for (el = wait_list; el; el = el->next)
1662 {
1663 if (el->expr == NULL)
1664 {
1665 gfc_error ("Invalid argument to $!ACC WAIT at %L",
1666 &wait_list->expr->where);
1667 return MATCH_ERROR;
1668 }
1669
1670 if (!gfc_resolve_expr (el->expr)
1671 || el->expr->ts.type != BT_INTEGER || el->expr->rank != 0
1672 || el->expr->expr_type != EXPR_CONSTANT)
1673 {
1674 gfc_error ("WAIT clause at %L requires a scalar INTEGER expression",
1675 &el->expr->where);
1676
1677 return MATCH_ERROR;
1678 }
1679 }
1680 c->wait_list = wait_list;
1681 new_st.op = EXEC_OACC_WAIT;
1682 new_st.ext.omp_clauses = c;
1683 return MATCH_YES;
1684 }
1685
1686
1687 match
1688 gfc_match_oacc_cache (void)
1689 {
1690 gfc_omp_clauses *c = gfc_get_omp_clauses ();
1691 match m = gfc_match_omp_variable_list (" (",
1692 &c->lists[OMP_LIST_CACHE], true,
1693 NULL, NULL, true);
1694 if (m != MATCH_YES)
1695 {
1696 gfc_free_omp_clauses(c);
1697 return m;
1698 }
1699
1700 if (gfc_current_state() != COMP_DO
1701 && gfc_current_state() != COMP_DO_CONCURRENT)
1702 {
1703 gfc_error ("ACC CACHE directive must be inside of loop %C");
1704 gfc_free_omp_clauses(c);
1705 return MATCH_ERROR;
1706 }
1707
1708 new_st.op = EXEC_OACC_CACHE;
1709 new_st.ext.omp_clauses = c;
1710 return MATCH_YES;
1711 }
1712
1713 /* Determine the loop level for a routine. */
1714
1715 static int
1716 gfc_oacc_routine_dims (gfc_omp_clauses *clauses)
1717 {
1718 int level = -1;
1719
1720 if (clauses)
1721 {
1722 unsigned mask = 0;
1723
1724 if (clauses->gang)
1725 level = GOMP_DIM_GANG, mask |= GOMP_DIM_MASK (level);
1726 if (clauses->worker)
1727 level = GOMP_DIM_WORKER, mask |= GOMP_DIM_MASK (level);
1728 if (clauses->vector)
1729 level = GOMP_DIM_VECTOR, mask |= GOMP_DIM_MASK (level);
1730 if (clauses->seq)
1731 level = GOMP_DIM_MAX, mask |= GOMP_DIM_MASK (level);
1732
1733 if (mask != (mask & -mask))
1734 gfc_error ("Multiple loop axes specified for routine");
1735 }
1736
1737 if (level < 0)
1738 level = GOMP_DIM_MAX;
1739
1740 return level;
1741 }
1742
1743 match
1744 gfc_match_oacc_routine (void)
1745 {
1746 locus old_loc;
1747 gfc_symbol *sym = NULL;
1748 match m;
1749 gfc_omp_clauses *c = NULL;
1750 gfc_oacc_routine_name *n = NULL;
1751
1752 old_loc = gfc_current_locus;
1753
1754 m = gfc_match (" (");
1755
1756 if (gfc_current_ns->proc_name
1757 && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
1758 && m == MATCH_YES)
1759 {
1760 gfc_error ("Only the !$ACC ROUTINE form without "
1761 "list is allowed in interface block at %C");
1762 goto cleanup;
1763 }
1764
1765 if (m == MATCH_YES)
1766 {
1767 char buffer[GFC_MAX_SYMBOL_LEN + 1];
1768 gfc_symtree *st;
1769
1770 m = gfc_match_name (buffer);
1771 if (m == MATCH_YES)
1772 {
1773 st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);
1774 if (st)
1775 {
1776 sym = st->n.sym;
1777 if (strcmp (sym->name, gfc_current_ns->proc_name->name) == 0)
1778 sym = NULL;
1779 }
1780
1781 if (st == NULL
1782 || (sym
1783 && !sym->attr.external
1784 && !sym->attr.function
1785 && !sym->attr.subroutine))
1786 {
1787 gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, "
1788 "invalid function name %s",
1789 (sym) ? sym->name : buffer);
1790 gfc_current_locus = old_loc;
1791 return MATCH_ERROR;
1792 }
1793 }
1794 else
1795 {
1796 gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C");
1797 gfc_current_locus = old_loc;
1798 return MATCH_ERROR;
1799 }
1800
1801 if (gfc_match_char (')') != MATCH_YES)
1802 {
1803 gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting"
1804 " ')' after NAME");
1805 gfc_current_locus = old_loc;
1806 return MATCH_ERROR;
1807 }
1808 }
1809
1810 if (gfc_match_omp_eos () != MATCH_YES
1811 && (gfc_match_omp_clauses (&c, OACC_ROUTINE_CLAUSES, false, false, true)
1812 != MATCH_YES))
1813 return MATCH_ERROR;
1814
1815 if (sym != NULL)
1816 {
1817 n = gfc_get_oacc_routine_name ();
1818 n->sym = sym;
1819 n->clauses = NULL;
1820 n->next = NULL;
1821 if (gfc_current_ns->oacc_routine_names != NULL)
1822 n->next = gfc_current_ns->oacc_routine_names;
1823
1824 gfc_current_ns->oacc_routine_names = n;
1825 }
1826 else if (gfc_current_ns->proc_name)
1827 {
1828 if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
1829 gfc_current_ns->proc_name->name,
1830 &old_loc))
1831 goto cleanup;
1832 gfc_current_ns->proc_name->attr.oacc_function
1833 = gfc_oacc_routine_dims (c) + 1;
1834 }
1835
1836 if (n)
1837 n->clauses = c;
1838 else if (gfc_current_ns->oacc_routine)
1839 gfc_current_ns->oacc_routine_clauses = c;
1840
1841 new_st.op = EXEC_OACC_ROUTINE;
1842 new_st.ext.omp_clauses = c;
1843 return MATCH_YES;
1844
1845 cleanup:
1846 gfc_current_locus = old_loc;
1847 return MATCH_ERROR;
1848 }
1849
1850
1851 #define OMP_PARALLEL_CLAUSES \
1852 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \
1853 | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IF \
1854 | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_PROC_BIND)
1855 #define OMP_DECLARE_SIMD_CLAUSES \
1856 (OMP_CLAUSE_SIMDLEN | OMP_CLAUSE_LINEAR | OMP_CLAUSE_UNIFORM \
1857 | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_INBRANCH | OMP_CLAUSE_NOTINBRANCH)
1858 #define OMP_DO_CLAUSES \
1859 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
1860 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
1861 | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE)
1862 #define OMP_SECTIONS_CLAUSES \
1863 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
1864 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
1865 #define OMP_SIMD_CLAUSES \
1866 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
1867 | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_SAFELEN | OMP_CLAUSE_LINEAR \
1868 | OMP_CLAUSE_ALIGNED)
1869 #define OMP_TASK_CLAUSES \
1870 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \
1871 | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED \
1872 | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE | OMP_CLAUSE_DEPEND)
1873 #define OMP_TARGET_CLAUSES \
1874 (OMP_CLAUSE_DEVICE | OMP_CLAUSE_MAP | OMP_CLAUSE_IF)
1875 #define OMP_TARGET_DATA_CLAUSES \
1876 (OMP_CLAUSE_DEVICE | OMP_CLAUSE_MAP | OMP_CLAUSE_IF)
1877 #define OMP_TARGET_UPDATE_CLAUSES \
1878 (OMP_CLAUSE_DEVICE | OMP_CLAUSE_IF | OMP_CLAUSE_TO | OMP_CLAUSE_FROM)
1879 #define OMP_TEAMS_CLAUSES \
1880 (OMP_CLAUSE_NUM_TEAMS | OMP_CLAUSE_THREAD_LIMIT | OMP_CLAUSE_DEFAULT \
1881 | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \
1882 | OMP_CLAUSE_REDUCTION)
1883 #define OMP_DISTRIBUTE_CLAUSES \
1884 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_COLLAPSE \
1885 | OMP_CLAUSE_DIST_SCHEDULE)
1886
1887
1888 static match
1889 match_omp (gfc_exec_op op, unsigned int mask)
1890 {
1891 gfc_omp_clauses *c;
1892 if (gfc_match_omp_clauses (&c, mask) != MATCH_YES)
1893 return MATCH_ERROR;
1894 new_st.op = op;
1895 new_st.ext.omp_clauses = c;
1896 return MATCH_YES;
1897 }
1898
1899
1900 match
1901 gfc_match_omp_critical (void)
1902 {
1903 char n[GFC_MAX_SYMBOL_LEN+1];
1904
1905 if (gfc_match (" ( %n )", n) != MATCH_YES)
1906 n[0] = '\0';
1907 if (gfc_match_omp_eos () != MATCH_YES)
1908 {
1909 gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
1910 return MATCH_ERROR;
1911 }
1912 new_st.op = EXEC_OMP_CRITICAL;
1913 new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
1914 return MATCH_YES;
1915 }
1916
1917
1918 match
1919 gfc_match_omp_distribute (void)
1920 {
1921 return match_omp (EXEC_OMP_DISTRIBUTE, OMP_DISTRIBUTE_CLAUSES);
1922 }
1923
1924
1925 match
1926 gfc_match_omp_distribute_parallel_do (void)
1927 {
1928 return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO,
1929 OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
1930 | OMP_DO_CLAUSES);
1931 }
1932
1933
1934 match
1935 gfc_match_omp_distribute_parallel_do_simd (void)
1936 {
1937 return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD,
1938 (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
1939 | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
1940 & ~OMP_CLAUSE_ORDERED);
1941 }
1942
1943
1944 match
1945 gfc_match_omp_distribute_simd (void)
1946 {
1947 return match_omp (EXEC_OMP_DISTRIBUTE_SIMD,
1948 OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
1949 }
1950
1951
1952 match
1953 gfc_match_omp_do (void)
1954 {
1955 return match_omp (EXEC_OMP_DO, OMP_DO_CLAUSES);
1956 }
1957
1958
1959 match
1960 gfc_match_omp_do_simd (void)
1961 {
1962 return match_omp (EXEC_OMP_DO_SIMD, ((OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
1963 & ~OMP_CLAUSE_ORDERED));
1964 }
1965
1966
1967 match
1968 gfc_match_omp_flush (void)
1969 {
1970 gfc_omp_namelist *list = NULL;
1971 gfc_match_omp_variable_list (" (", &list, true);
1972 if (gfc_match_omp_eos () != MATCH_YES)
1973 {
1974 gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
1975 gfc_free_omp_namelist (list);
1976 return MATCH_ERROR;
1977 }
1978 new_st.op = EXEC_OMP_FLUSH;
1979 new_st.ext.omp_namelist = list;
1980 return MATCH_YES;
1981 }
1982
1983
1984 match
1985 gfc_match_omp_declare_simd (void)
1986 {
1987 locus where = gfc_current_locus;
1988 gfc_symbol *proc_name;
1989 gfc_omp_clauses *c;
1990 gfc_omp_declare_simd *ods;
1991
1992 if (gfc_match (" ( %s ) ", &proc_name) != MATCH_YES)
1993 return MATCH_ERROR;
1994
1995 if (gfc_match_omp_clauses (&c, OMP_DECLARE_SIMD_CLAUSES, true,
1996 false) != MATCH_YES)
1997 return MATCH_ERROR;
1998
1999 ods = gfc_get_omp_declare_simd ();
2000 ods->where = where;
2001 ods->proc_name = proc_name;
2002 ods->clauses = c;
2003 ods->next = gfc_current_ns->omp_declare_simd;
2004 gfc_current_ns->omp_declare_simd = ods;
2005 return MATCH_YES;
2006 }
2007
2008
2009 static bool
2010 match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2)
2011 {
2012 match m;
2013 locus old_loc = gfc_current_locus;
2014 char sname[GFC_MAX_SYMBOL_LEN + 1];
2015 gfc_symbol *sym;
2016 gfc_namespace *ns = gfc_current_ns;
2017 gfc_expr *lvalue = NULL, *rvalue = NULL;
2018 gfc_symtree *st;
2019 gfc_actual_arglist *arglist;
2020
2021 m = gfc_match (" %v =", &lvalue);
2022 if (m != MATCH_YES)
2023 gfc_current_locus = old_loc;
2024 else
2025 {
2026 m = gfc_match (" %e )", &rvalue);
2027 if (m == MATCH_YES)
2028 {
2029 ns->code = gfc_get_code (EXEC_ASSIGN);
2030 ns->code->expr1 = lvalue;
2031 ns->code->expr2 = rvalue;
2032 ns->code->loc = old_loc;
2033 return true;
2034 }
2035
2036 gfc_current_locus = old_loc;
2037 gfc_free_expr (lvalue);
2038 }
2039
2040 m = gfc_match (" %n", sname);
2041 if (m != MATCH_YES)
2042 return false;
2043
2044 if (strcmp (sname, omp_sym1->name) == 0
2045 || strcmp (sname, omp_sym2->name) == 0)
2046 return false;
2047
2048 gfc_current_ns = ns->parent;
2049 if (gfc_get_ha_sym_tree (sname, &st))
2050 return false;
2051
2052 sym = st->n.sym;
2053 if (sym->attr.flavor != FL_PROCEDURE
2054 && sym->attr.flavor != FL_UNKNOWN)
2055 return false;
2056
2057 if (!sym->attr.generic
2058 && !sym->attr.subroutine
2059 && !sym->attr.function)
2060 {
2061 if (!(sym->attr.external && !sym->attr.referenced))
2062 {
2063 /* ...create a symbol in this scope... */
2064 if (sym->ns != gfc_current_ns
2065 && gfc_get_sym_tree (sname, NULL, &st, false) == 1)
2066 return false;
2067
2068 if (sym != st->n.sym)
2069 sym = st->n.sym;
2070 }
2071
2072 /* ...and then to try to make the symbol into a subroutine. */
2073 if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
2074 return false;
2075 }
2076
2077 gfc_set_sym_referenced (sym);
2078 gfc_gobble_whitespace ();
2079 if (gfc_peek_ascii_char () != '(')
2080 return false;
2081
2082 gfc_current_ns = ns;
2083 m = gfc_match_actual_arglist (1, &arglist);
2084 if (m != MATCH_YES)
2085 return false;
2086
2087 if (gfc_match_char (')') != MATCH_YES)
2088 return false;
2089
2090 ns->code = gfc_get_code (EXEC_CALL);
2091 ns->code->symtree = st;
2092 ns->code->ext.actual = arglist;
2093 ns->code->loc = old_loc;
2094 return true;
2095 }
2096
2097 static bool
2098 gfc_omp_udr_predef (gfc_omp_reduction_op rop, const char *name,
2099 gfc_typespec *ts, const char **n)
2100 {
2101 if (!gfc_numeric_ts (ts) && ts->type != BT_LOGICAL)
2102 return false;
2103
2104 switch (rop)
2105 {
2106 case OMP_REDUCTION_PLUS:
2107 case OMP_REDUCTION_MINUS:
2108 case OMP_REDUCTION_TIMES:
2109 return ts->type != BT_LOGICAL;
2110 case OMP_REDUCTION_AND:
2111 case OMP_REDUCTION_OR:
2112 case OMP_REDUCTION_EQV:
2113 case OMP_REDUCTION_NEQV:
2114 return ts->type == BT_LOGICAL;
2115 case OMP_REDUCTION_USER:
2116 if (name[0] != '.' && (ts->type == BT_INTEGER || ts->type == BT_REAL))
2117 {
2118 gfc_symbol *sym;
2119
2120 gfc_find_symbol (name, NULL, 1, &sym);
2121 if (sym != NULL)
2122 {
2123 if (sym->attr.intrinsic)
2124 *n = sym->name;
2125 else if ((sym->attr.flavor != FL_UNKNOWN
2126 && sym->attr.flavor != FL_PROCEDURE)
2127 || sym->attr.external
2128 || sym->attr.generic
2129 || sym->attr.entry
2130 || sym->attr.result
2131 || sym->attr.dummy
2132 || sym->attr.subroutine
2133 || sym->attr.pointer
2134 || sym->attr.target
2135 || sym->attr.cray_pointer
2136 || sym->attr.cray_pointee
2137 || (sym->attr.proc != PROC_UNKNOWN
2138 && sym->attr.proc != PROC_INTRINSIC)
2139 || sym->attr.if_source != IFSRC_UNKNOWN
2140 || sym == sym->ns->proc_name)
2141 *n = NULL;
2142 else
2143 *n = sym->name;
2144 }
2145 else
2146 *n = name;
2147 if (*n
2148 && (strcmp (*n, "max") == 0 || strcmp (*n, "min") == 0))
2149 return true;
2150 else if (*n
2151 && ts->type == BT_INTEGER
2152 && (strcmp (*n, "iand") == 0
2153 || strcmp (*n, "ior") == 0
2154 || strcmp (*n, "ieor") == 0))
2155 return true;
2156 }
2157 break;
2158 default:
2159 break;
2160 }
2161 return false;
2162 }
2163
2164 gfc_omp_udr *
2165 gfc_omp_udr_find (gfc_symtree *st, gfc_typespec *ts)
2166 {
2167 gfc_omp_udr *omp_udr;
2168
2169 if (st == NULL)
2170 return NULL;
2171
2172 for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
2173 if (omp_udr->ts.type == ts->type
2174 || ((omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
2175 && (ts->type == BT_DERIVED || ts->type == BT_CLASS)))
2176 {
2177 if (omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
2178 {
2179 if (strcmp (omp_udr->ts.u.derived->name, ts->u.derived->name) == 0)
2180 return omp_udr;
2181 }
2182 else if (omp_udr->ts.kind == ts->kind)
2183 {
2184 if (omp_udr->ts.type == BT_CHARACTER)
2185 {
2186 if (omp_udr->ts.u.cl->length == NULL
2187 || ts->u.cl->length == NULL)
2188 return omp_udr;
2189 if (omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
2190 return omp_udr;
2191 if (ts->u.cl->length->expr_type != EXPR_CONSTANT)
2192 return omp_udr;
2193 if (omp_udr->ts.u.cl->length->ts.type != BT_INTEGER)
2194 return omp_udr;
2195 if (ts->u.cl->length->ts.type != BT_INTEGER)
2196 return omp_udr;
2197 if (gfc_compare_expr (omp_udr->ts.u.cl->length,
2198 ts->u.cl->length, INTRINSIC_EQ) != 0)
2199 continue;
2200 }
2201 return omp_udr;
2202 }
2203 }
2204 return NULL;
2205 }
2206
2207 match
2208 gfc_match_omp_declare_reduction (void)
2209 {
2210 match m;
2211 gfc_intrinsic_op op;
2212 char name[GFC_MAX_SYMBOL_LEN + 3];
2213 auto_vec<gfc_typespec, 5> tss;
2214 gfc_typespec ts;
2215 unsigned int i;
2216 gfc_symtree *st;
2217 locus where = gfc_current_locus;
2218 locus end_loc = gfc_current_locus;
2219 bool end_loc_set = false;
2220 gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
2221
2222 if (gfc_match_char ('(') != MATCH_YES)
2223 return MATCH_ERROR;
2224
2225 m = gfc_match (" %o : ", &op);
2226 if (m == MATCH_ERROR)
2227 return MATCH_ERROR;
2228 if (m == MATCH_YES)
2229 {
2230 snprintf (name, sizeof name, "operator %s", gfc_op2string (op));
2231 rop = (gfc_omp_reduction_op) op;
2232 }
2233 else
2234 {
2235 m = gfc_match_defined_op_name (name + 1, 1);
2236 if (m == MATCH_ERROR)
2237 return MATCH_ERROR;
2238 if (m == MATCH_YES)
2239 {
2240 name[0] = '.';
2241 strcat (name, ".");
2242 if (gfc_match (" : ") != MATCH_YES)
2243 return MATCH_ERROR;
2244 }
2245 else
2246 {
2247 if (gfc_match (" %n : ", name) != MATCH_YES)
2248 return MATCH_ERROR;
2249 }
2250 rop = OMP_REDUCTION_USER;
2251 }
2252
2253 m = gfc_match_type_spec (&ts);
2254 if (m != MATCH_YES)
2255 return MATCH_ERROR;
2256 /* Treat len=: the same as len=*. */
2257 if (ts.type == BT_CHARACTER)
2258 ts.deferred = false;
2259 tss.safe_push (ts);
2260
2261 while (gfc_match_char (',') == MATCH_YES)
2262 {
2263 m = gfc_match_type_spec (&ts);
2264 if (m != MATCH_YES)
2265 return MATCH_ERROR;
2266 tss.safe_push (ts);
2267 }
2268 if (gfc_match_char (':') != MATCH_YES)
2269 return MATCH_ERROR;
2270
2271 st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
2272 for (i = 0; i < tss.length (); i++)
2273 {
2274 gfc_symtree *omp_out, *omp_in;
2275 gfc_symtree *omp_priv = NULL, *omp_orig = NULL;
2276 gfc_namespace *combiner_ns, *initializer_ns = NULL;
2277 gfc_omp_udr *prev_udr, *omp_udr;
2278 const char *predef_name = NULL;
2279
2280 omp_udr = gfc_get_omp_udr ();
2281 omp_udr->name = gfc_get_string (name);
2282 omp_udr->rop = rop;
2283 omp_udr->ts = tss[i];
2284 omp_udr->where = where;
2285
2286 gfc_current_ns = combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
2287 combiner_ns->proc_name = combiner_ns->parent->proc_name;
2288
2289 gfc_get_sym_tree ("omp_out", combiner_ns, &omp_out, false);
2290 gfc_get_sym_tree ("omp_in", combiner_ns, &omp_in, false);
2291 combiner_ns->omp_udr_ns = 1;
2292 omp_out->n.sym->ts = tss[i];
2293 omp_in->n.sym->ts = tss[i];
2294 omp_out->n.sym->attr.omp_udr_artificial_var = 1;
2295 omp_in->n.sym->attr.omp_udr_artificial_var = 1;
2296 omp_out->n.sym->attr.flavor = FL_VARIABLE;
2297 omp_in->n.sym->attr.flavor = FL_VARIABLE;
2298 gfc_commit_symbols ();
2299 omp_udr->combiner_ns = combiner_ns;
2300 omp_udr->omp_out = omp_out->n.sym;
2301 omp_udr->omp_in = omp_in->n.sym;
2302
2303 locus old_loc = gfc_current_locus;
2304
2305 if (!match_udr_expr (omp_out, omp_in))
2306 {
2307 syntax:
2308 gfc_current_locus = old_loc;
2309 gfc_current_ns = combiner_ns->parent;
2310 gfc_undo_symbols ();
2311 gfc_free_omp_udr (omp_udr);
2312 return MATCH_ERROR;
2313 }
2314
2315 if (gfc_match (" initializer ( ") == MATCH_YES)
2316 {
2317 gfc_current_ns = combiner_ns->parent;
2318 initializer_ns = gfc_get_namespace (gfc_current_ns, 1);
2319 gfc_current_ns = initializer_ns;
2320 initializer_ns->proc_name = initializer_ns->parent->proc_name;
2321
2322 gfc_get_sym_tree ("omp_priv", initializer_ns, &omp_priv, false);
2323 gfc_get_sym_tree ("omp_orig", initializer_ns, &omp_orig, false);
2324 initializer_ns->omp_udr_ns = 1;
2325 omp_priv->n.sym->ts = tss[i];
2326 omp_orig->n.sym->ts = tss[i];
2327 omp_priv->n.sym->attr.omp_udr_artificial_var = 1;
2328 omp_orig->n.sym->attr.omp_udr_artificial_var = 1;
2329 omp_priv->n.sym->attr.flavor = FL_VARIABLE;
2330 omp_orig->n.sym->attr.flavor = FL_VARIABLE;
2331 gfc_commit_symbols ();
2332 omp_udr->initializer_ns = initializer_ns;
2333 omp_udr->omp_priv = omp_priv->n.sym;
2334 omp_udr->omp_orig = omp_orig->n.sym;
2335
2336 if (!match_udr_expr (omp_priv, omp_orig))
2337 goto syntax;
2338 }
2339
2340 gfc_current_ns = combiner_ns->parent;
2341 if (!end_loc_set)
2342 {
2343 end_loc_set = true;
2344 end_loc = gfc_current_locus;
2345 }
2346 gfc_current_locus = old_loc;
2347
2348 prev_udr = gfc_omp_udr_find (st, &tss[i]);
2349 if (gfc_omp_udr_predef (rop, name, &tss[i], &predef_name)
2350 /* Don't error on !$omp declare reduction (min : integer : ...)
2351 just yet, there could be integer :: min afterwards,
2352 making it valid. When the UDR is resolved, we'll get
2353 to it again. */
2354 && (rop != OMP_REDUCTION_USER || name[0] == '.'))
2355 {
2356 if (predef_name)
2357 gfc_error_now ("Redefinition of predefined %s "
2358 "!$OMP DECLARE REDUCTION at %L",
2359 predef_name, &where);
2360 else
2361 gfc_error_now ("Redefinition of predefined "
2362 "!$OMP DECLARE REDUCTION at %L", &where);
2363 }
2364 else if (prev_udr)
2365 {
2366 gfc_error_now ("Redefinition of !$OMP DECLARE REDUCTION at %L",
2367 &where);
2368 gfc_error_now ("Previous !$OMP DECLARE REDUCTION at %L",
2369 &prev_udr->where);
2370 }
2371 else if (st)
2372 {
2373 omp_udr->next = st->n.omp_udr;
2374 st->n.omp_udr = omp_udr;
2375 }
2376 else
2377 {
2378 st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name);
2379 st->n.omp_udr = omp_udr;
2380 }
2381 }
2382
2383 if (end_loc_set)
2384 {
2385 gfc_current_locus = end_loc;
2386 if (gfc_match_omp_eos () != MATCH_YES)
2387 {
2388 gfc_error ("Unexpected junk after !$OMP DECLARE REDUCTION at %C");
2389 gfc_current_locus = where;
2390 return MATCH_ERROR;
2391 }
2392
2393 return MATCH_YES;
2394 }
2395 gfc_clear_error ();
2396 return MATCH_ERROR;
2397 }
2398
2399
2400 match
2401 gfc_match_omp_declare_target (void)
2402 {
2403 locus old_loc;
2404 char n[GFC_MAX_SYMBOL_LEN+1];
2405 gfc_symbol *sym;
2406 match m;
2407 gfc_symtree *st;
2408
2409 old_loc = gfc_current_locus;
2410
2411 m = gfc_match (" (");
2412
2413 if (gfc_current_ns->proc_name
2414 && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
2415 && m == MATCH_YES)
2416 {
2417 gfc_error ("Only the !$OMP DECLARE TARGET form without "
2418 "list is allowed in interface block at %C");
2419 goto cleanup;
2420 }
2421
2422 if (m == MATCH_NO
2423 && gfc_current_ns->proc_name
2424 && gfc_match_omp_eos () == MATCH_YES)
2425 {
2426 if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
2427 gfc_current_ns->proc_name->name,
2428 &old_loc))
2429 goto cleanup;
2430 return MATCH_YES;
2431 }
2432
2433 if (m != MATCH_YES)
2434 return m;
2435
2436 for (;;)
2437 {
2438 m = gfc_match_symbol (&sym, 0);
2439 switch (m)
2440 {
2441 case MATCH_YES:
2442 if (sym->attr.in_common)
2443 gfc_error_now ("OMP DECLARE TARGET on a variable at %C is an "
2444 "element of a COMMON block");
2445 else if (!gfc_add_omp_declare_target (&sym->attr, sym->name,
2446 &sym->declared_at))
2447 goto cleanup;
2448 goto next_item;
2449 case MATCH_NO:
2450 break;
2451 case MATCH_ERROR:
2452 goto cleanup;
2453 }
2454
2455 m = gfc_match (" / %n /", n);
2456 if (m == MATCH_ERROR)
2457 goto cleanup;
2458 if (m == MATCH_NO || n[0] == '\0')
2459 goto syntax;
2460
2461 st = gfc_find_symtree (gfc_current_ns->common_root, n);
2462 if (st == NULL)
2463 {
2464 gfc_error ("COMMON block /%s/ not found at %C", n);
2465 goto cleanup;
2466 }
2467 st->n.common->omp_declare_target = 1;
2468 for (sym = st->n.common->head; sym; sym = sym->common_next)
2469 if (!gfc_add_omp_declare_target (&sym->attr, sym->name,
2470 &sym->declared_at))
2471 goto cleanup;
2472
2473 next_item:
2474 if (gfc_match_char (')') == MATCH_YES)
2475 break;
2476 if (gfc_match_char (',') != MATCH_YES)
2477 goto syntax;
2478 }
2479
2480 if (gfc_match_omp_eos () != MATCH_YES)
2481 {
2482 gfc_error ("Unexpected junk after !$OMP DECLARE TARGET at %C");
2483 goto cleanup;
2484 }
2485 return MATCH_YES;
2486
2487 syntax:
2488 gfc_error ("Syntax error in !$OMP DECLARE TARGET list at %C");
2489
2490 cleanup:
2491 gfc_current_locus = old_loc;
2492 return MATCH_ERROR;
2493 }
2494
2495
2496 match
2497 gfc_match_omp_threadprivate (void)
2498 {
2499 locus old_loc;
2500 char n[GFC_MAX_SYMBOL_LEN+1];
2501 gfc_symbol *sym;
2502 match m;
2503 gfc_symtree *st;
2504
2505 old_loc = gfc_current_locus;
2506
2507 m = gfc_match (" (");
2508 if (m != MATCH_YES)
2509 return m;
2510
2511 for (;;)
2512 {
2513 m = gfc_match_symbol (&sym, 0);
2514 switch (m)
2515 {
2516 case MATCH_YES:
2517 if (sym->attr.in_common)
2518 gfc_error_now ("Threadprivate variable at %C is an element of "
2519 "a COMMON block");
2520 else if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at))
2521 goto cleanup;
2522 goto next_item;
2523 case MATCH_NO:
2524 break;
2525 case MATCH_ERROR:
2526 goto cleanup;
2527 }
2528
2529 m = gfc_match (" / %n /", n);
2530 if (m == MATCH_ERROR)
2531 goto cleanup;
2532 if (m == MATCH_NO || n[0] == '\0')
2533 goto syntax;
2534
2535 st = gfc_find_symtree (gfc_current_ns->common_root, n);
2536 if (st == NULL)
2537 {
2538 gfc_error ("COMMON block /%s/ not found at %C", n);
2539 goto cleanup;
2540 }
2541 st->n.common->threadprivate = 1;
2542 for (sym = st->n.common->head; sym; sym = sym->common_next)
2543 if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at))
2544 goto cleanup;
2545
2546 next_item:
2547 if (gfc_match_char (')') == MATCH_YES)
2548 break;
2549 if (gfc_match_char (',') != MATCH_YES)
2550 goto syntax;
2551 }
2552
2553 if (gfc_match_omp_eos () != MATCH_YES)
2554 {
2555 gfc_error ("Unexpected junk after OMP THREADPRIVATE at %C");
2556 goto cleanup;
2557 }
2558
2559 return MATCH_YES;
2560
2561 syntax:
2562 gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C");
2563
2564 cleanup:
2565 gfc_current_locus = old_loc;
2566 return MATCH_ERROR;
2567 }
2568
2569
2570 match
2571 gfc_match_omp_parallel (void)
2572 {
2573 return match_omp (EXEC_OMP_PARALLEL, OMP_PARALLEL_CLAUSES);
2574 }
2575
2576
2577 match
2578 gfc_match_omp_parallel_do (void)
2579 {
2580 return match_omp (EXEC_OMP_PARALLEL_DO,
2581 OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES);
2582 }
2583
2584
2585 match
2586 gfc_match_omp_parallel_do_simd (void)
2587 {
2588 return match_omp (EXEC_OMP_PARALLEL_DO_SIMD,
2589 (OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
2590 & ~OMP_CLAUSE_ORDERED);
2591 }
2592
2593
2594 match
2595 gfc_match_omp_parallel_sections (void)
2596 {
2597 return match_omp (EXEC_OMP_PARALLEL_SECTIONS,
2598 OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES);
2599 }
2600
2601
2602 match
2603 gfc_match_omp_parallel_workshare (void)
2604 {
2605 return match_omp (EXEC_OMP_PARALLEL_WORKSHARE, OMP_PARALLEL_CLAUSES);
2606 }
2607
2608
2609 match
2610 gfc_match_omp_sections (void)
2611 {
2612 return match_omp (EXEC_OMP_SECTIONS, OMP_SECTIONS_CLAUSES);
2613 }
2614
2615
2616 match
2617 gfc_match_omp_simd (void)
2618 {
2619 return match_omp (EXEC_OMP_SIMD, OMP_SIMD_CLAUSES);
2620 }
2621
2622
2623 match
2624 gfc_match_omp_single (void)
2625 {
2626 return match_omp (EXEC_OMP_SINGLE,
2627 OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE);
2628 }
2629
2630
2631 match
2632 gfc_match_omp_task (void)
2633 {
2634 return match_omp (EXEC_OMP_TASK, OMP_TASK_CLAUSES);
2635 }
2636
2637
2638 match
2639 gfc_match_omp_taskwait (void)
2640 {
2641 if (gfc_match_omp_eos () != MATCH_YES)
2642 {
2643 gfc_error ("Unexpected junk after TASKWAIT clause at %C");
2644 return MATCH_ERROR;
2645 }
2646 new_st.op = EXEC_OMP_TASKWAIT;
2647 new_st.ext.omp_clauses = NULL;
2648 return MATCH_YES;
2649 }
2650
2651
2652 match
2653 gfc_match_omp_taskyield (void)
2654 {
2655 if (gfc_match_omp_eos () != MATCH_YES)
2656 {
2657 gfc_error ("Unexpected junk after TASKYIELD clause at %C");
2658 return MATCH_ERROR;
2659 }
2660 new_st.op = EXEC_OMP_TASKYIELD;
2661 new_st.ext.omp_clauses = NULL;
2662 return MATCH_YES;
2663 }
2664
2665
2666 match
2667 gfc_match_omp_target (void)
2668 {
2669 return match_omp (EXEC_OMP_TARGET, OMP_TARGET_CLAUSES);
2670 }
2671
2672
2673 match
2674 gfc_match_omp_target_data (void)
2675 {
2676 return match_omp (EXEC_OMP_TARGET_DATA, OMP_TARGET_DATA_CLAUSES);
2677 }
2678
2679
2680 match
2681 gfc_match_omp_target_teams (void)
2682 {
2683 return match_omp (EXEC_OMP_TARGET_TEAMS,
2684 OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES);
2685 }
2686
2687
2688 match
2689 gfc_match_omp_target_teams_distribute (void)
2690 {
2691 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE,
2692 OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
2693 | OMP_DISTRIBUTE_CLAUSES);
2694 }
2695
2696
2697 match
2698 gfc_match_omp_target_teams_distribute_parallel_do (void)
2699 {
2700 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO,
2701 OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
2702 | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
2703 | OMP_DO_CLAUSES);
2704 }
2705
2706
2707 match
2708 gfc_match_omp_target_teams_distribute_parallel_do_simd (void)
2709 {
2710 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
2711 (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
2712 | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
2713 | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
2714 & ~OMP_CLAUSE_ORDERED);
2715 }
2716
2717
2718 match
2719 gfc_match_omp_target_teams_distribute_simd (void)
2720 {
2721 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD,
2722 OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
2723 | OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
2724 }
2725
2726
2727 match
2728 gfc_match_omp_target_update (void)
2729 {
2730 return match_omp (EXEC_OMP_TARGET_UPDATE, OMP_TARGET_UPDATE_CLAUSES);
2731 }
2732
2733
2734 match
2735 gfc_match_omp_teams (void)
2736 {
2737 return match_omp (EXEC_OMP_TEAMS, OMP_TEAMS_CLAUSES);
2738 }
2739
2740
2741 match
2742 gfc_match_omp_teams_distribute (void)
2743 {
2744 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE,
2745 OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES);
2746 }
2747
2748
2749 match
2750 gfc_match_omp_teams_distribute_parallel_do (void)
2751 {
2752 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO,
2753 OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
2754 | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES);
2755 }
2756
2757
2758 match
2759 gfc_match_omp_teams_distribute_parallel_do_simd (void)
2760 {
2761 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
2762 (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
2763 | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
2764 | OMP_SIMD_CLAUSES) & ~OMP_CLAUSE_ORDERED);
2765 }
2766
2767
2768 match
2769 gfc_match_omp_teams_distribute_simd (void)
2770 {
2771 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_SIMD,
2772 OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
2773 | OMP_SIMD_CLAUSES);
2774 }
2775
2776
2777 match
2778 gfc_match_omp_workshare (void)
2779 {
2780 if (gfc_match_omp_eos () != MATCH_YES)
2781 {
2782 gfc_error ("Unexpected junk after $OMP WORKSHARE statement at %C");
2783 return MATCH_ERROR;
2784 }
2785 new_st.op = EXEC_OMP_WORKSHARE;
2786 new_st.ext.omp_clauses = gfc_get_omp_clauses ();
2787 return MATCH_YES;
2788 }
2789
2790
2791 match
2792 gfc_match_omp_master (void)
2793 {
2794 if (gfc_match_omp_eos () != MATCH_YES)
2795 {
2796 gfc_error ("Unexpected junk after $OMP MASTER statement at %C");
2797 return MATCH_ERROR;
2798 }
2799 new_st.op = EXEC_OMP_MASTER;
2800 new_st.ext.omp_clauses = NULL;
2801 return MATCH_YES;
2802 }
2803
2804
2805 match
2806 gfc_match_omp_ordered (void)
2807 {
2808 if (gfc_match_omp_eos () != MATCH_YES)
2809 {
2810 gfc_error ("Unexpected junk after $OMP ORDERED statement at %C");
2811 return MATCH_ERROR;
2812 }
2813 new_st.op = EXEC_OMP_ORDERED;
2814 new_st.ext.omp_clauses = NULL;
2815 return MATCH_YES;
2816 }
2817
2818
2819 static match
2820 gfc_match_omp_oacc_atomic (bool omp_p)
2821 {
2822 gfc_omp_atomic_op op = GFC_OMP_ATOMIC_UPDATE;
2823 int seq_cst = 0;
2824 if (gfc_match ("% seq_cst") == MATCH_YES)
2825 seq_cst = 1;
2826 locus old_loc = gfc_current_locus;
2827 if (seq_cst && gfc_match_char (',') == MATCH_YES)
2828 seq_cst = 2;
2829 if (seq_cst == 2
2830 || gfc_match_space () == MATCH_YES)
2831 {
2832 gfc_gobble_whitespace ();
2833 if (gfc_match ("update") == MATCH_YES)
2834 op = GFC_OMP_ATOMIC_UPDATE;
2835 else if (gfc_match ("read") == MATCH_YES)
2836 op = GFC_OMP_ATOMIC_READ;
2837 else if (gfc_match ("write") == MATCH_YES)
2838 op = GFC_OMP_ATOMIC_WRITE;
2839 else if (gfc_match ("capture") == MATCH_YES)
2840 op = GFC_OMP_ATOMIC_CAPTURE;
2841 else
2842 {
2843 if (seq_cst == 2)
2844 gfc_current_locus = old_loc;
2845 goto finish;
2846 }
2847 if (!seq_cst
2848 && (gfc_match (", seq_cst") == MATCH_YES
2849 || gfc_match ("% seq_cst") == MATCH_YES))
2850 seq_cst = 1;
2851 }
2852 finish:
2853 if (gfc_match_omp_eos () != MATCH_YES)
2854 {
2855 gfc_error ("Unexpected junk after $OMP ATOMIC statement at %C");
2856 return MATCH_ERROR;
2857 }
2858 new_st.op = (omp_p ? EXEC_OMP_ATOMIC : EXEC_OACC_ATOMIC);
2859 if (seq_cst)
2860 op = (gfc_omp_atomic_op) (op | GFC_OMP_ATOMIC_SEQ_CST);
2861 new_st.ext.omp_atomic = op;
2862 return MATCH_YES;
2863 }
2864
2865 match
2866 gfc_match_oacc_atomic (void)
2867 {
2868 return gfc_match_omp_oacc_atomic (false);
2869 }
2870
2871 match
2872 gfc_match_omp_atomic (void)
2873 {
2874 return gfc_match_omp_oacc_atomic (true);
2875 }
2876
2877 match
2878 gfc_match_omp_barrier (void)
2879 {
2880 if (gfc_match_omp_eos () != MATCH_YES)
2881 {
2882 gfc_error ("Unexpected junk after $OMP BARRIER statement at %C");
2883 return MATCH_ERROR;
2884 }
2885 new_st.op = EXEC_OMP_BARRIER;
2886 new_st.ext.omp_clauses = NULL;
2887 return MATCH_YES;
2888 }
2889
2890
2891 match
2892 gfc_match_omp_taskgroup (void)
2893 {
2894 if (gfc_match_omp_eos () != MATCH_YES)
2895 {
2896 gfc_error ("Unexpected junk after $OMP TASKGROUP statement at %C");
2897 return MATCH_ERROR;
2898 }
2899 new_st.op = EXEC_OMP_TASKGROUP;
2900 return MATCH_YES;
2901 }
2902
2903
2904 static enum gfc_omp_cancel_kind
2905 gfc_match_omp_cancel_kind (void)
2906 {
2907 if (gfc_match_space () != MATCH_YES)
2908 return OMP_CANCEL_UNKNOWN;
2909 if (gfc_match ("parallel") == MATCH_YES)
2910 return OMP_CANCEL_PARALLEL;
2911 if (gfc_match ("sections") == MATCH_YES)
2912 return OMP_CANCEL_SECTIONS;
2913 if (gfc_match ("do") == MATCH_YES)
2914 return OMP_CANCEL_DO;
2915 if (gfc_match ("taskgroup") == MATCH_YES)
2916 return OMP_CANCEL_TASKGROUP;
2917 return OMP_CANCEL_UNKNOWN;
2918 }
2919
2920
2921 match
2922 gfc_match_omp_cancel (void)
2923 {
2924 gfc_omp_clauses *c;
2925 enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
2926 if (kind == OMP_CANCEL_UNKNOWN)
2927 return MATCH_ERROR;
2928 if (gfc_match_omp_clauses (&c, OMP_CLAUSE_IF, false) != MATCH_YES)
2929 return MATCH_ERROR;
2930 c->cancel = kind;
2931 new_st.op = EXEC_OMP_CANCEL;
2932 new_st.ext.omp_clauses = c;
2933 return MATCH_YES;
2934 }
2935
2936
2937 match
2938 gfc_match_omp_cancellation_point (void)
2939 {
2940 gfc_omp_clauses *c;
2941 enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
2942 if (kind == OMP_CANCEL_UNKNOWN)
2943 return MATCH_ERROR;
2944 if (gfc_match_omp_eos () != MATCH_YES)
2945 {
2946 gfc_error ("Unexpected junk after $OMP CANCELLATION POINT statement "
2947 "at %C");
2948 return MATCH_ERROR;
2949 }
2950 c = gfc_get_omp_clauses ();
2951 c->cancel = kind;
2952 new_st.op = EXEC_OMP_CANCELLATION_POINT;
2953 new_st.ext.omp_clauses = c;
2954 return MATCH_YES;
2955 }
2956
2957
2958 match
2959 gfc_match_omp_end_nowait (void)
2960 {
2961 bool nowait = false;
2962 if (gfc_match ("% nowait") == MATCH_YES)
2963 nowait = true;
2964 if (gfc_match_omp_eos () != MATCH_YES)
2965 {
2966 gfc_error ("Unexpected junk after NOWAIT clause at %C");
2967 return MATCH_ERROR;
2968 }
2969 new_st.op = EXEC_OMP_END_NOWAIT;
2970 new_st.ext.omp_bool = nowait;
2971 return MATCH_YES;
2972 }
2973
2974
2975 match
2976 gfc_match_omp_end_single (void)
2977 {
2978 gfc_omp_clauses *c;
2979 if (gfc_match ("% nowait") == MATCH_YES)
2980 {
2981 new_st.op = EXEC_OMP_END_NOWAIT;
2982 new_st.ext.omp_bool = true;
2983 return MATCH_YES;
2984 }
2985 if (gfc_match_omp_clauses (&c, OMP_CLAUSE_COPYPRIVATE) != MATCH_YES)
2986 return MATCH_ERROR;
2987 new_st.op = EXEC_OMP_END_SINGLE;
2988 new_st.ext.omp_clauses = c;
2989 return MATCH_YES;
2990 }
2991
2992
2993 static bool
2994 oacc_is_loop (gfc_code *code)
2995 {
2996 return code->op == EXEC_OACC_PARALLEL_LOOP
2997 || code->op == EXEC_OACC_KERNELS_LOOP
2998 || code->op == EXEC_OACC_LOOP;
2999 }
3000
3001 static void
3002 resolve_oacc_scalar_int_expr (gfc_expr *expr, const char *clause)
3003 {
3004 if (!gfc_resolve_expr (expr)
3005 || expr->ts.type != BT_INTEGER || expr->rank != 0)
3006 gfc_error ("%s clause at %L requires a scalar INTEGER expression",
3007 clause, &expr->where);
3008 }
3009
3010
3011 static void
3012 resolve_oacc_positive_int_expr (gfc_expr *expr, const char *clause)
3013 {
3014 resolve_oacc_scalar_int_expr (expr, clause);
3015 if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_INTEGER
3016 && mpz_sgn(expr->value.integer) <= 0)
3017 gfc_warning (0, "INTEGER expression of %s clause at %L must be positive",
3018 clause, &expr->where);
3019 }
3020
3021 /* Emits error when symbol is pointer, cray pointer or cray pointee
3022 of derived of polymorphic type. */
3023
3024 static void
3025 check_symbol_not_pointer (gfc_symbol *sym, locus loc, const char *name)
3026 {
3027 if (sym->ts.type == BT_DERIVED && sym->attr.pointer)
3028 gfc_error ("POINTER object %qs of derived type in %s clause at %L",
3029 sym->name, name, &loc);
3030 if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointer)
3031 gfc_error ("Cray pointer object of derived type %qs in %s clause at %L",
3032 sym->name, name, &loc);
3033 if (sym->ts.type == BT_DERIVED && sym->attr.cray_pointee)
3034 gfc_error ("Cray pointee object of derived type %qs in %s clause at %L",
3035 sym->name, name, &loc);
3036
3037 if ((sym->ts.type == BT_ASSUMED && sym->attr.pointer)
3038 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
3039 && CLASS_DATA (sym)->attr.pointer))
3040 gfc_error ("POINTER object %qs of polymorphic type in %s clause at %L",
3041 sym->name, name, &loc);
3042 if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointer)
3043 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
3044 && CLASS_DATA (sym)->attr.cray_pointer))
3045 gfc_error ("Cray pointer object of polymorphic type %qs in %s clause at %L",
3046 sym->name, name, &loc);
3047 if ((sym->ts.type == BT_ASSUMED && sym->attr.cray_pointee)
3048 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
3049 && CLASS_DATA (sym)->attr.cray_pointee))
3050 gfc_error ("Cray pointee object of polymorphic type %qs in %s clause at %L",
3051 sym->name, name, &loc);
3052 }
3053
3054 /* Emits error when symbol represents assumed size/rank array. */
3055
3056 static void
3057 check_array_not_assumed (gfc_symbol *sym, locus loc, const char *name)
3058 {
3059 if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
3060 gfc_error ("Assumed size array %qs in %s clause at %L",
3061 sym->name, name, &loc);
3062 if (sym->as && sym->as->type == AS_ASSUMED_RANK)
3063 gfc_error ("Assumed rank array %qs in %s clause at %L",
3064 sym->name, name, &loc);
3065 if (sym->as && sym->as->type == AS_DEFERRED && sym->attr.pointer
3066 && !sym->attr.contiguous)
3067 gfc_error ("Noncontiguous deferred shape array %qs in %s clause at %L",
3068 sym->name, name, &loc);
3069 }
3070
3071 static void
3072 resolve_oacc_data_clauses (gfc_symbol *sym, locus loc, const char *name)
3073 {
3074 if (sym->ts.type == BT_DERIVED && sym->attr.allocatable)
3075 gfc_error ("ALLOCATABLE object %qs of derived type in %s clause at %L",
3076 sym->name, name, &loc);
3077 if ((sym->ts.type == BT_ASSUMED && sym->attr.allocatable)
3078 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
3079 && CLASS_DATA (sym)->attr.allocatable))
3080 gfc_error ("ALLOCATABLE object %qs of polymorphic type "
3081 "in %s clause at %L", sym->name, name, &loc);
3082 check_symbol_not_pointer (sym, loc, name);
3083 check_array_not_assumed (sym, loc, name);
3084 }
3085
3086 static void
3087 resolve_oacc_deviceptr_clause (gfc_symbol *sym, locus loc, const char *name)
3088 {
3089 if (sym->attr.pointer
3090 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
3091 && CLASS_DATA (sym)->attr.class_pointer))
3092 gfc_error ("POINTER object %qs in %s clause at %L",
3093 sym->name, name, &loc);
3094 if (sym->attr.cray_pointer
3095 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
3096 && CLASS_DATA (sym)->attr.cray_pointer))
3097 gfc_error ("Cray pointer object %qs in %s clause at %L",
3098 sym->name, name, &loc);
3099 if (sym->attr.cray_pointee
3100 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
3101 && CLASS_DATA (sym)->attr.cray_pointee))
3102 gfc_error ("Cray pointee object %qs in %s clause at %L",
3103 sym->name, name, &loc);
3104 if (sym->attr.allocatable
3105 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
3106 && CLASS_DATA (sym)->attr.allocatable))
3107 gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
3108 sym->name, name, &loc);
3109 if (sym->attr.value)
3110 gfc_error ("VALUE object %qs in %s clause at %L",
3111 sym->name, name, &loc);
3112 check_array_not_assumed (sym, loc, name);
3113 }
3114
3115
3116 struct resolve_omp_udr_callback_data
3117 {
3118 gfc_symbol *sym1, *sym2;
3119 };
3120
3121
3122 static int
3123 resolve_omp_udr_callback (gfc_expr **e, int *, void *data)
3124 {
3125 struct resolve_omp_udr_callback_data *rcd
3126 = (struct resolve_omp_udr_callback_data *) data;
3127 if ((*e)->expr_type == EXPR_VARIABLE
3128 && ((*e)->symtree->n.sym == rcd->sym1
3129 || (*e)->symtree->n.sym == rcd->sym2))
3130 {
3131 gfc_ref *ref = gfc_get_ref ();
3132 ref->type = REF_ARRAY;
3133 ref->u.ar.where = (*e)->where;
3134 ref->u.ar.as = (*e)->symtree->n.sym->as;
3135 ref->u.ar.type = AR_FULL;
3136 ref->u.ar.dimen = 0;
3137 ref->next = (*e)->ref;
3138 (*e)->ref = ref;
3139 }
3140 return 0;
3141 }
3142
3143
3144 static int
3145 resolve_omp_udr_callback2 (gfc_expr **e, int *, void *)
3146 {
3147 if ((*e)->expr_type == EXPR_FUNCTION
3148 && (*e)->value.function.isym == NULL)
3149 {
3150 gfc_symbol *sym = (*e)->symtree->n.sym;
3151 if (!sym->attr.intrinsic
3152 && sym->attr.if_source == IFSRC_UNKNOWN)
3153 gfc_error ("Implicitly declared function %s used in "
3154 "!$OMP DECLARE REDUCTION at %L ", sym->name, &(*e)->where);
3155 }
3156 return 0;
3157 }
3158
3159
3160 static gfc_code *
3161 resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns,
3162 gfc_symbol *sym1, gfc_symbol *sym2)
3163 {
3164 gfc_code *copy;
3165 gfc_symbol sym1_copy, sym2_copy;
3166
3167 if (ns->code->op == EXEC_ASSIGN)
3168 {
3169 copy = gfc_get_code (EXEC_ASSIGN);
3170 copy->expr1 = gfc_copy_expr (ns->code->expr1);
3171 copy->expr2 = gfc_copy_expr (ns->code->expr2);
3172 }
3173 else
3174 {
3175 copy = gfc_get_code (EXEC_CALL);
3176 copy->symtree = ns->code->symtree;
3177 copy->ext.actual = gfc_copy_actual_arglist (ns->code->ext.actual);
3178 }
3179 copy->loc = ns->code->loc;
3180 sym1_copy = *sym1;
3181 sym2_copy = *sym2;
3182 *sym1 = *n->sym;
3183 *sym2 = *n->sym;
3184 sym1->name = sym1_copy.name;
3185 sym2->name = sym2_copy.name;
3186 ns->proc_name = ns->parent->proc_name;
3187 if (n->sym->attr.dimension)
3188 {
3189 struct resolve_omp_udr_callback_data rcd;
3190 rcd.sym1 = sym1;
3191 rcd.sym2 = sym2;
3192 gfc_code_walker (&copy, gfc_dummy_code_callback,
3193 resolve_omp_udr_callback, &rcd);
3194 }
3195 gfc_resolve_code (copy, gfc_current_ns);
3196 if (copy->op == EXEC_CALL && copy->resolved_isym == NULL)
3197 {
3198 gfc_symbol *sym = copy->resolved_sym;
3199 if (sym
3200 && !sym->attr.intrinsic
3201 && sym->attr.if_source == IFSRC_UNKNOWN)
3202 gfc_error ("Implicitly declared subroutine %s used in "
3203 "!$OMP DECLARE REDUCTION at %L ", sym->name,
3204 &copy->loc);
3205 }
3206 gfc_code_walker (&copy, gfc_dummy_code_callback,
3207 resolve_omp_udr_callback2, NULL);
3208 *sym1 = sym1_copy;
3209 *sym2 = sym2_copy;
3210 return copy;
3211 }
3212
3213 /* OpenMP directive resolving routines. */
3214
3215 static void
3216 resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
3217 gfc_namespace *ns, bool openacc = false)
3218 {
3219 gfc_omp_namelist *n;
3220 gfc_expr_list *el;
3221 int list;
3222 static const char *clause_names[]
3223 = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
3224 "COPYIN", "UNIFORM", "ALIGNED", "LINEAR", "DEPEND", "MAP",
3225 "TO", "FROM", "REDUCTION", "DEVICE_RESIDENT", "LINK", "USE_DEVICE",
3226 "CACHE" };
3227
3228 if (omp_clauses == NULL)
3229 return;
3230
3231 if (omp_clauses->if_expr)
3232 {
3233 gfc_expr *expr = omp_clauses->if_expr;
3234 if (!gfc_resolve_expr (expr)
3235 || expr->ts.type != BT_LOGICAL || expr->rank != 0)
3236 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
3237 &expr->where);
3238 }
3239 if (omp_clauses->final_expr)
3240 {
3241 gfc_expr *expr = omp_clauses->final_expr;
3242 if (!gfc_resolve_expr (expr)
3243 || expr->ts.type != BT_LOGICAL || expr->rank != 0)
3244 gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression",
3245 &expr->where);
3246 }
3247 if (omp_clauses->num_threads)
3248 {
3249 gfc_expr *expr = omp_clauses->num_threads;
3250 if (!gfc_resolve_expr (expr)
3251 || expr->ts.type != BT_INTEGER || expr->rank != 0)
3252 gfc_error ("NUM_THREADS clause at %L requires a scalar "
3253 "INTEGER expression", &expr->where);
3254 }
3255 if (omp_clauses->chunk_size)
3256 {
3257 gfc_expr *expr = omp_clauses->chunk_size;
3258 if (!gfc_resolve_expr (expr)
3259 || expr->ts.type != BT_INTEGER || expr->rank != 0)
3260 gfc_error ("SCHEDULE clause's chunk_size at %L requires "
3261 "a scalar INTEGER expression", &expr->where);
3262 }
3263
3264 /* Check that no symbol appears on multiple clauses, except that
3265 a symbol can appear on both firstprivate and lastprivate. */
3266 for (list = 0; list < OMP_LIST_NUM; list++)
3267 for (n = omp_clauses->lists[list]; n; n = n->next)
3268 {
3269 n->sym->mark = 0;
3270 if (n->sym->attr.flavor == FL_VARIABLE
3271 || n->sym->attr.proc_pointer
3272 || (!code && (!n->sym->attr.dummy || n->sym->ns != ns)))
3273 {
3274 if (!code && (!n->sym->attr.dummy || n->sym->ns != ns))
3275 gfc_error ("Variable %qs is not a dummy argument at %L",
3276 n->sym->name, &n->where);
3277 continue;
3278 }
3279 if (n->sym->attr.flavor == FL_PROCEDURE
3280 && n->sym->result == n->sym
3281 && n->sym->attr.function)
3282 {
3283 if (gfc_current_ns->proc_name == n->sym
3284 || (gfc_current_ns->parent
3285 && gfc_current_ns->parent->proc_name == n->sym))
3286 continue;
3287 if (gfc_current_ns->proc_name->attr.entry_master)
3288 {
3289 gfc_entry_list *el = gfc_current_ns->entries;
3290 for (; el; el = el->next)
3291 if (el->sym == n->sym)
3292 break;
3293 if (el)
3294 continue;
3295 }
3296 if (gfc_current_ns->parent
3297 && gfc_current_ns->parent->proc_name->attr.entry_master)
3298 {
3299 gfc_entry_list *el = gfc_current_ns->parent->entries;
3300 for (; el; el = el->next)
3301 if (el->sym == n->sym)
3302 break;
3303 if (el)
3304 continue;
3305 }
3306 }
3307 gfc_error ("Object %qs is not a variable at %L", n->sym->name,
3308 &n->where);
3309 }
3310
3311 for (list = 0; list < OMP_LIST_NUM; list++)
3312 if (list != OMP_LIST_FIRSTPRIVATE
3313 && list != OMP_LIST_LASTPRIVATE
3314 && list != OMP_LIST_ALIGNED
3315 && list != OMP_LIST_DEPEND
3316 && (list != OMP_LIST_MAP || openacc)
3317 && list != OMP_LIST_FROM
3318 && list != OMP_LIST_TO
3319 && (list != OMP_LIST_REDUCTION || !openacc))
3320 for (n = omp_clauses->lists[list]; n; n = n->next)
3321 {
3322 if (n->sym->mark)
3323 gfc_error ("Symbol %qs present on multiple clauses at %L",
3324 n->sym->name, &n->where);
3325 else
3326 n->sym->mark = 1;
3327 }
3328
3329 gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1);
3330 for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE; list++)
3331 for (n = omp_clauses->lists[list]; n; n = n->next)
3332 if (n->sym->mark)
3333 {
3334 gfc_error ("Symbol %qs present on multiple clauses at %L",
3335 n->sym->name, &n->where);
3336 n->sym->mark = 0;
3337 }
3338
3339 for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next)
3340 {
3341 if (n->sym->mark)
3342 gfc_error ("Symbol %qs present on multiple clauses at %L",
3343 n->sym->name, &n->where);
3344 else
3345 n->sym->mark = 1;
3346 }
3347 for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
3348 n->sym->mark = 0;
3349
3350 for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
3351 {
3352 if (n->sym->mark)
3353 gfc_error ("Symbol %qs present on multiple clauses at %L",
3354 n->sym->name, &n->where);
3355 else
3356 n->sym->mark = 1;
3357 }
3358
3359 for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
3360 n->sym->mark = 0;
3361
3362 for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
3363 {
3364 if (n->sym->mark)
3365 gfc_error ("Symbol %qs present on multiple clauses at %L",
3366 n->sym->name, &n->where);
3367 else
3368 n->sym->mark = 1;
3369 }
3370
3371 /* OpenACC reductions. */
3372 if (openacc)
3373 {
3374 for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next)
3375 n->sym->mark = 0;
3376
3377 for (n = omp_clauses->lists[OMP_LIST_REDUCTION]; n; n = n->next)
3378 {
3379 if (n->sym->mark)
3380 gfc_error ("Symbol %qs present on multiple clauses at %L",
3381 n->sym->name, &n->where);
3382 else
3383 n->sym->mark = 1;
3384
3385 /* OpenACC does not support reductions on arrays. */
3386 if (n->sym->as)
3387 gfc_error ("Array %qs is not permitted in reduction at %L",
3388 n->sym->name, &n->where);
3389 }
3390 }
3391
3392 for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
3393 n->sym->mark = 0;
3394 for (n = omp_clauses->lists[OMP_LIST_FROM]; n; n = n->next)
3395 if (n->expr == NULL)
3396 n->sym->mark = 1;
3397 for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
3398 {
3399 if (n->expr == NULL && n->sym->mark)
3400 gfc_error ("Symbol %qs present on both FROM and TO clauses at %L",
3401 n->sym->name, &n->where);
3402 else
3403 n->sym->mark = 1;
3404 }
3405
3406 for (list = 0; list < OMP_LIST_NUM; list++)
3407 if ((n = omp_clauses->lists[list]) != NULL)
3408 {
3409 const char *name;
3410
3411 if (list < OMP_LIST_NUM)
3412 name = clause_names[list];
3413 else
3414 gcc_unreachable ();
3415
3416 switch (list)
3417 {
3418 case OMP_LIST_COPYIN:
3419 for (; n != NULL; n = n->next)
3420 {
3421 if (!n->sym->attr.threadprivate)
3422 gfc_error ("Non-THREADPRIVATE object %qs in COPYIN clause"
3423 " at %L", n->sym->name, &n->where);
3424 }
3425 break;
3426 case OMP_LIST_COPYPRIVATE:
3427 for (; n != NULL; n = n->next)
3428 {
3429 if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
3430 gfc_error ("Assumed size array %qs in COPYPRIVATE clause "
3431 "at %L", n->sym->name, &n->where);
3432 if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
3433 gfc_error ("INTENT(IN) POINTER %qs in COPYPRIVATE clause "
3434 "at %L", n->sym->name, &n->where);
3435 }
3436 break;
3437 case OMP_LIST_SHARED:
3438 for (; n != NULL; n = n->next)
3439 {
3440 if (n->sym->attr.threadprivate)
3441 gfc_error ("THREADPRIVATE object %qs in SHARED clause at "
3442 "%L", n->sym->name, &n->where);
3443 if (n->sym->attr.cray_pointee)
3444 gfc_error ("Cray pointee %qs in SHARED clause at %L",
3445 n->sym->name, &n->where);
3446 if (n->sym->attr.associate_var)
3447 gfc_error ("ASSOCIATE name %qs in SHARED clause at %L",
3448 n->sym->name, &n->where);
3449 }
3450 break;
3451 case OMP_LIST_ALIGNED:
3452 for (; n != NULL; n = n->next)
3453 {
3454 if (!n->sym->attr.pointer
3455 && !n->sym->attr.allocatable
3456 && !n->sym->attr.cray_pointer
3457 && (n->sym->ts.type != BT_DERIVED
3458 || (n->sym->ts.u.derived->from_intmod
3459 != INTMOD_ISO_C_BINDING)
3460 || (n->sym->ts.u.derived->intmod_sym_id
3461 != ISOCBINDING_PTR)))
3462 gfc_error ("%qs in ALIGNED clause must be POINTER, "
3463 "ALLOCATABLE, Cray pointer or C_PTR at %L",
3464 n->sym->name, &n->where);
3465 else if (n->expr)
3466 {
3467 gfc_expr *expr = n->expr;
3468 int alignment = 0;
3469 if (!gfc_resolve_expr (expr)
3470 || expr->ts.type != BT_INTEGER
3471 || expr->rank != 0
3472 || gfc_extract_int (expr, &alignment)
3473 || alignment <= 0)
3474 gfc_error ("%qs in ALIGNED clause at %L requires a scalar "
3475 "positive constant integer alignment "
3476 "expression", n->sym->name, &n->where);
3477 }
3478 }
3479 break;
3480 case OMP_LIST_DEPEND:
3481 case OMP_LIST_MAP:
3482 case OMP_LIST_TO:
3483 case OMP_LIST_FROM:
3484 case OMP_LIST_CACHE:
3485 for (; n != NULL; n = n->next)
3486 {
3487 if (n->expr)
3488 {
3489 if (!gfc_resolve_expr (n->expr)
3490 || n->expr->expr_type != EXPR_VARIABLE
3491 || n->expr->ref == NULL
3492 || n->expr->ref->next
3493 || n->expr->ref->type != REF_ARRAY)
3494 gfc_error ("%qs in %s clause at %L is not a proper "
3495 "array section", n->sym->name, name,
3496 &n->where);
3497 else if (n->expr->ref->u.ar.codimen)
3498 gfc_error ("Coarrays not supported in %s clause at %L",
3499 name, &n->where);
3500 else
3501 {
3502 int i;
3503 gfc_array_ref *ar = &n->expr->ref->u.ar;
3504 for (i = 0; i < ar->dimen; i++)
3505 if (ar->stride[i])
3506 {
3507 gfc_error ("Stride should not be specified for "
3508 "array section in %s clause at %L",
3509 name, &n->where);
3510 break;
3511 }
3512 else if (ar->dimen_type[i] != DIMEN_ELEMENT
3513 && ar->dimen_type[i] != DIMEN_RANGE)
3514 {
3515 gfc_error ("%qs in %s clause at %L is not a "
3516 "proper array section",
3517 n->sym->name, name, &n->where);
3518 break;
3519 }
3520 else if (list == OMP_LIST_DEPEND
3521 && ar->start[i]
3522 && ar->start[i]->expr_type == EXPR_CONSTANT
3523 && ar->end[i]
3524 && ar->end[i]->expr_type == EXPR_CONSTANT
3525 && mpz_cmp (ar->start[i]->value.integer,
3526 ar->end[i]->value.integer) > 0)
3527 {
3528 gfc_error ("%qs in DEPEND clause at %L is a "
3529 "zero size array section",
3530 n->sym->name, &n->where);
3531 break;
3532 }
3533 }
3534 }
3535 else if (openacc)
3536 {
3537 if (list == OMP_LIST_MAP
3538 && n->u.map_op == OMP_MAP_FORCE_DEVICEPTR)
3539 resolve_oacc_deviceptr_clause (n->sym, n->where, name);
3540 else
3541 resolve_oacc_data_clauses (n->sym, n->where, name);
3542 }
3543 }
3544
3545 if (list != OMP_LIST_DEPEND)
3546 for (n = omp_clauses->lists[list]; n != NULL; n = n->next)
3547 {
3548 n->sym->attr.referenced = 1;
3549 if (n->sym->attr.threadprivate)
3550 gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
3551 n->sym->name, name, &n->where);
3552 if (n->sym->attr.cray_pointee)
3553 gfc_error ("Cray pointee %qs in %s clause at %L",
3554 n->sym->name, name, &n->where);
3555 }
3556 break;
3557 default:
3558 for (; n != NULL; n = n->next)
3559 {
3560 bool bad = false;
3561 if (n->sym->attr.threadprivate)
3562 gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
3563 n->sym->name, name, &n->where);
3564 if (n->sym->attr.cray_pointee)
3565 gfc_error ("Cray pointee %qs in %s clause at %L",
3566 n->sym->name, name, &n->where);
3567 if (n->sym->attr.associate_var)
3568 gfc_error ("ASSOCIATE name %qs in %s clause at %L",
3569 n->sym->name, name, &n->where);
3570 if (list != OMP_LIST_PRIVATE)
3571 {
3572 if (n->sym->attr.proc_pointer && list == OMP_LIST_REDUCTION)
3573 gfc_error ("Procedure pointer %qs in %s clause at %L",
3574 n->sym->name, name, &n->where);
3575 if (n->sym->attr.pointer && list == OMP_LIST_REDUCTION)
3576 gfc_error ("POINTER object %qs in %s clause at %L",
3577 n->sym->name, name, &n->where);
3578 if (n->sym->attr.cray_pointer && list == OMP_LIST_REDUCTION)
3579 gfc_error ("Cray pointer %qs in %s clause at %L",
3580 n->sym->name, name, &n->where);
3581 }
3582 if (code
3583 && (oacc_is_loop (code) || code->op == EXEC_OACC_PARALLEL))
3584 check_array_not_assumed (n->sym, n->where, name);
3585 else if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
3586 gfc_error ("Assumed size array %qs in %s clause at %L",
3587 n->sym->name, name, &n->where);
3588 if (n->sym->attr.in_namelist && list != OMP_LIST_REDUCTION)
3589 gfc_error ("Variable %qs in %s clause is used in "
3590 "NAMELIST statement at %L",
3591 n->sym->name, name, &n->where);
3592 if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
3593 switch (list)
3594 {
3595 case OMP_LIST_PRIVATE:
3596 case OMP_LIST_LASTPRIVATE:
3597 case OMP_LIST_LINEAR:
3598 /* case OMP_LIST_REDUCTION: */
3599 gfc_error ("INTENT(IN) POINTER %qs in %s clause at %L",
3600 n->sym->name, name, &n->where);
3601 break;
3602 default:
3603 break;
3604 }
3605
3606 switch (list)
3607 {
3608 case OMP_LIST_REDUCTION:
3609 switch (n->u.reduction_op)
3610 {
3611 case OMP_REDUCTION_PLUS:
3612 case OMP_REDUCTION_TIMES:
3613 case OMP_REDUCTION_MINUS:
3614 if (!gfc_numeric_ts (&n->sym->ts))
3615 bad = true;
3616 break;
3617 case OMP_REDUCTION_AND:
3618 case OMP_REDUCTION_OR:
3619 case OMP_REDUCTION_EQV:
3620 case OMP_REDUCTION_NEQV:
3621 if (n->sym->ts.type != BT_LOGICAL)
3622 bad = true;
3623 break;
3624 case OMP_REDUCTION_MAX:
3625 case OMP_REDUCTION_MIN:
3626 if (n->sym->ts.type != BT_INTEGER
3627 && n->sym->ts.type != BT_REAL)
3628 bad = true;
3629 break;
3630 case OMP_REDUCTION_IAND:
3631 case OMP_REDUCTION_IOR:
3632 case OMP_REDUCTION_IEOR:
3633 if (n->sym->ts.type != BT_INTEGER)
3634 bad = true;
3635 break;
3636 case OMP_REDUCTION_USER:
3637 bad = true;
3638 break;
3639 default:
3640 break;
3641 }
3642 if (!bad)
3643 n->udr = NULL;
3644 else
3645 {
3646 const char *udr_name = NULL;
3647 if (n->udr)
3648 {
3649 udr_name = n->udr->udr->name;
3650 n->udr->udr
3651 = gfc_find_omp_udr (NULL, udr_name,
3652 &n->sym->ts);
3653 if (n->udr->udr == NULL)
3654 {
3655 free (n->udr);
3656 n->udr = NULL;
3657 }
3658 }
3659 if (n->udr == NULL)
3660 {
3661 if (udr_name == NULL)
3662 switch (n->u.reduction_op)
3663 {
3664 case OMP_REDUCTION_PLUS:
3665 case OMP_REDUCTION_TIMES:
3666 case OMP_REDUCTION_MINUS:
3667 case OMP_REDUCTION_AND:
3668 case OMP_REDUCTION_OR:
3669 case OMP_REDUCTION_EQV:
3670 case OMP_REDUCTION_NEQV:
3671 udr_name = gfc_op2string ((gfc_intrinsic_op)
3672 n->u.reduction_op);
3673 break;
3674 case OMP_REDUCTION_MAX:
3675 udr_name = "max";
3676 break;
3677 case OMP_REDUCTION_MIN:
3678 udr_name = "min";
3679 break;
3680 case OMP_REDUCTION_IAND:
3681 udr_name = "iand";
3682 break;
3683 case OMP_REDUCTION_IOR:
3684 udr_name = "ior";
3685 break;
3686 case OMP_REDUCTION_IEOR:
3687 udr_name = "ieor";
3688 break;
3689 default:
3690 gcc_unreachable ();
3691 }
3692 gfc_error ("!$OMP DECLARE REDUCTION %s not found "
3693 "for type %s at %L", udr_name,
3694 gfc_typename (&n->sym->ts), &n->where);
3695 }
3696 else
3697 {
3698 gfc_omp_udr *udr = n->udr->udr;
3699 n->u.reduction_op = OMP_REDUCTION_USER;
3700 n->udr->combiner
3701 = resolve_omp_udr_clause (n, udr->combiner_ns,
3702 udr->omp_out,
3703 udr->omp_in);
3704 if (udr->initializer_ns)
3705 n->udr->initializer
3706 = resolve_omp_udr_clause (n,
3707 udr->initializer_ns,
3708 udr->omp_priv,
3709 udr->omp_orig);
3710 }
3711 }
3712 break;
3713 case OMP_LIST_LINEAR:
3714 if (n->sym->ts.type != BT_INTEGER)
3715 gfc_error ("LINEAR variable %qs must be INTEGER "
3716 "at %L", n->sym->name, &n->where);
3717 else if (!code && !n->sym->attr.value)
3718 gfc_error ("LINEAR dummy argument %qs must have VALUE "
3719 "attribute at %L", n->sym->name, &n->where);
3720 else if (n->expr)
3721 {
3722 gfc_expr *expr = n->expr;
3723 if (!gfc_resolve_expr (expr)
3724 || expr->ts.type != BT_INTEGER
3725 || expr->rank != 0)
3726 gfc_error ("%qs in LINEAR clause at %L requires "
3727 "a scalar integer linear-step expression",
3728 n->sym->name, &n->where);
3729 else if (!code && expr->expr_type != EXPR_CONSTANT)
3730 gfc_error ("%qs in LINEAR clause at %L requires "
3731 "a constant integer linear-step expression",
3732 n->sym->name, &n->where);
3733 }
3734 break;
3735 /* Workaround for PR middle-end/26316, nothing really needs
3736 to be done here for OMP_LIST_PRIVATE. */
3737 case OMP_LIST_PRIVATE:
3738 gcc_assert (code && code->op != EXEC_NOP);
3739 break;
3740 case OMP_LIST_USE_DEVICE:
3741 if (n->sym->attr.allocatable
3742 || (n->sym->ts.type == BT_CLASS && CLASS_DATA (n->sym)
3743 && CLASS_DATA (n->sym)->attr.allocatable))
3744 gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
3745 n->sym->name, name, &n->where);
3746 if (n->sym->attr.pointer
3747 || (n->sym->ts.type == BT_CLASS && CLASS_DATA (n->sym)
3748 && CLASS_DATA (n->sym)->attr.class_pointer))
3749 gfc_error ("POINTER object %qs in %s clause at %L",
3750 n->sym->name, name, &n->where);
3751 if (n->sym->attr.cray_pointer)
3752 gfc_error ("Cray pointer object %qs in %s clause at %L",
3753 n->sym->name, name, &n->where);
3754 if (n->sym->attr.cray_pointee)
3755 gfc_error ("Cray pointee object %qs in %s clause at %L",
3756 n->sym->name, name, &n->where);
3757 /* FALLTHRU */
3758 case OMP_LIST_DEVICE_RESIDENT:
3759 check_symbol_not_pointer (n->sym, n->where, name);
3760 check_array_not_assumed (n->sym, n->where, name);
3761 break;
3762 default:
3763 break;
3764 }
3765 }
3766 break;
3767 }
3768 }
3769 if (omp_clauses->safelen_expr)
3770 {
3771 gfc_expr *expr = omp_clauses->safelen_expr;
3772 if (!gfc_resolve_expr (expr)
3773 || expr->ts.type != BT_INTEGER || expr->rank != 0)
3774 gfc_error ("SAFELEN clause at %L requires a scalar "
3775 "INTEGER expression", &expr->where);
3776 }
3777 if (omp_clauses->simdlen_expr)
3778 {
3779 gfc_expr *expr = omp_clauses->simdlen_expr;
3780 if (!gfc_resolve_expr (expr)
3781 || expr->ts.type != BT_INTEGER || expr->rank != 0)
3782 gfc_error ("SIMDLEN clause at %L requires a scalar "
3783 "INTEGER expression", &expr->where);
3784 }
3785 if (omp_clauses->num_teams)
3786 {
3787 gfc_expr *expr = omp_clauses->num_teams;
3788 if (!gfc_resolve_expr (expr)
3789 || expr->ts.type != BT_INTEGER || expr->rank != 0)
3790 gfc_error ("NUM_TEAMS clause at %L requires a scalar "
3791 "INTEGER expression", &expr->where);
3792 }
3793 if (omp_clauses->device)
3794 {
3795 gfc_expr *expr = omp_clauses->device;
3796 if (!gfc_resolve_expr (expr)
3797 || expr->ts.type != BT_INTEGER || expr->rank != 0)
3798 gfc_error ("DEVICE clause at %L requires a scalar "
3799 "INTEGER expression", &expr->where);
3800 }
3801 if (omp_clauses->dist_chunk_size)
3802 {
3803 gfc_expr *expr = omp_clauses->dist_chunk_size;
3804 if (!gfc_resolve_expr (expr)
3805 || expr->ts.type != BT_INTEGER || expr->rank != 0)
3806 gfc_error ("DIST_SCHEDULE clause's chunk_size at %L requires "
3807 "a scalar INTEGER expression", &expr->where);
3808 }
3809 if (omp_clauses->thread_limit)
3810 {
3811 gfc_expr *expr = omp_clauses->thread_limit;
3812 if (!gfc_resolve_expr (expr)
3813 || expr->ts.type != BT_INTEGER || expr->rank != 0)
3814 gfc_error ("THREAD_LIMIT clause at %L requires a scalar "
3815 "INTEGER expression", &expr->where);
3816 }
3817 if (omp_clauses->async)
3818 if (omp_clauses->async_expr)
3819 resolve_oacc_scalar_int_expr (omp_clauses->async_expr, "ASYNC");
3820 if (omp_clauses->num_gangs_expr)
3821 resolve_oacc_positive_int_expr (omp_clauses->num_gangs_expr, "NUM_GANGS");
3822 if (omp_clauses->num_workers_expr)
3823 resolve_oacc_positive_int_expr (omp_clauses->num_workers_expr,
3824 "NUM_WORKERS");
3825 if (omp_clauses->vector_length_expr)
3826 resolve_oacc_positive_int_expr (omp_clauses->vector_length_expr,
3827 "VECTOR_LENGTH");
3828 if (omp_clauses->gang_num_expr)
3829 resolve_oacc_positive_int_expr (omp_clauses->gang_num_expr, "GANG");
3830 if (omp_clauses->gang_static_expr)
3831 resolve_oacc_positive_int_expr (omp_clauses->gang_static_expr, "GANG");
3832 if (omp_clauses->worker_expr)
3833 resolve_oacc_positive_int_expr (omp_clauses->worker_expr, "WORKER");
3834 if (omp_clauses->vector_expr)
3835 resolve_oacc_positive_int_expr (omp_clauses->vector_expr, "VECTOR");
3836 if (omp_clauses->wait)
3837 if (omp_clauses->wait_list)
3838 for (el = omp_clauses->wait_list; el; el = el->next)
3839 resolve_oacc_scalar_int_expr (el->expr, "WAIT");
3840 }
3841
3842
3843 /* Return true if SYM is ever referenced in EXPR except in the SE node. */
3844
3845 static bool
3846 expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
3847 {
3848 gfc_actual_arglist *arg;
3849 if (e == NULL || e == se)
3850 return false;
3851 switch (e->expr_type)
3852 {
3853 case EXPR_CONSTANT:
3854 case EXPR_NULL:
3855 case EXPR_VARIABLE:
3856 case EXPR_STRUCTURE:
3857 case EXPR_ARRAY:
3858 if (e->symtree != NULL
3859 && e->symtree->n.sym == s)
3860 return true;
3861 return false;
3862 case EXPR_SUBSTRING:
3863 if (e->ref != NULL
3864 && (expr_references_sym (e->ref->u.ss.start, s, se)
3865 || expr_references_sym (e->ref->u.ss.end, s, se)))
3866 return true;
3867 return false;
3868 case EXPR_OP:
3869 if (expr_references_sym (e->value.op.op2, s, se))
3870 return true;
3871 return expr_references_sym (e->value.op.op1, s, se);
3872 case EXPR_FUNCTION:
3873 for (arg = e->value.function.actual; arg; arg = arg->next)
3874 if (expr_references_sym (arg->expr, s, se))
3875 return true;
3876 return false;
3877 default:
3878 gcc_unreachable ();
3879 }
3880 }
3881
3882
3883 /* If EXPR is a conversion function that widens the type
3884 if WIDENING is true or narrows the type if WIDENING is false,
3885 return the inner expression, otherwise return NULL. */
3886
3887 static gfc_expr *
3888 is_conversion (gfc_expr *expr, bool widening)
3889 {
3890 gfc_typespec *ts1, *ts2;
3891
3892 if (expr->expr_type != EXPR_FUNCTION
3893 || expr->value.function.isym == NULL
3894 || expr->value.function.esym != NULL
3895 || expr->value.function.isym->id != GFC_ISYM_CONVERSION)
3896 return NULL;
3897
3898 if (widening)
3899 {
3900 ts1 = &expr->ts;
3901 ts2 = &expr->value.function.actual->expr->ts;
3902 }
3903 else
3904 {
3905 ts1 = &expr->value.function.actual->expr->ts;
3906 ts2 = &expr->ts;
3907 }
3908
3909 if (ts1->type > ts2->type
3910 || (ts1->type == ts2->type && ts1->kind > ts2->kind))
3911 return expr->value.function.actual->expr;
3912
3913 return NULL;
3914 }
3915
3916
3917 static void
3918 resolve_omp_atomic (gfc_code *code)
3919 {
3920 gfc_code *atomic_code = code;
3921 gfc_symbol *var;
3922 gfc_expr *expr2, *expr2_tmp;
3923 gfc_omp_atomic_op aop
3924 = (gfc_omp_atomic_op) (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK);
3925
3926 code = code->block->next;
3927 gcc_assert (code->op == EXEC_ASSIGN);
3928 gcc_assert (((aop != GFC_OMP_ATOMIC_CAPTURE) && code->next == NULL)
3929 || ((aop == GFC_OMP_ATOMIC_CAPTURE)
3930 && code->next != NULL
3931 && code->next->op == EXEC_ASSIGN
3932 && code->next->next == NULL));
3933
3934 if (code->expr1->expr_type != EXPR_VARIABLE
3935 || code->expr1->symtree == NULL
3936 || code->expr1->rank != 0
3937 || (code->expr1->ts.type != BT_INTEGER
3938 && code->expr1->ts.type != BT_REAL
3939 && code->expr1->ts.type != BT_COMPLEX
3940 && code->expr1->ts.type != BT_LOGICAL))
3941 {
3942 gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
3943 "intrinsic type at %L", &code->loc);
3944 return;
3945 }
3946
3947 var = code->expr1->symtree->n.sym;
3948 expr2 = is_conversion (code->expr2, false);
3949 if (expr2 == NULL)
3950 {
3951 if (aop == GFC_OMP_ATOMIC_READ || aop == GFC_OMP_ATOMIC_WRITE)
3952 expr2 = is_conversion (code->expr2, true);
3953 if (expr2 == NULL)
3954 expr2 = code->expr2;
3955 }
3956
3957 switch (aop)
3958 {
3959 case GFC_OMP_ATOMIC_READ:
3960 if (expr2->expr_type != EXPR_VARIABLE
3961 || expr2->symtree == NULL
3962 || expr2->rank != 0
3963 || (expr2->ts.type != BT_INTEGER
3964 && expr2->ts.type != BT_REAL
3965 && expr2->ts.type != BT_COMPLEX
3966 && expr2->ts.type != BT_LOGICAL))
3967 gfc_error ("!$OMP ATOMIC READ statement must read from a scalar "
3968 "variable of intrinsic type at %L", &expr2->where);
3969 return;
3970 case GFC_OMP_ATOMIC_WRITE:
3971 if (expr2->rank != 0 || expr_references_sym (code->expr2, var, NULL))
3972 gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr "
3973 "must be scalar and cannot reference var at %L",
3974 &expr2->where);
3975 return;
3976 case GFC_OMP_ATOMIC_CAPTURE:
3977 expr2_tmp = expr2;
3978 if (expr2 == code->expr2)
3979 {
3980 expr2_tmp = is_conversion (code->expr2, true);
3981 if (expr2_tmp == NULL)
3982 expr2_tmp = expr2;
3983 }
3984 if (expr2_tmp->expr_type == EXPR_VARIABLE)
3985 {
3986 if (expr2_tmp->symtree == NULL
3987 || expr2_tmp->rank != 0
3988 || (expr2_tmp->ts.type != BT_INTEGER
3989 && expr2_tmp->ts.type != BT_REAL
3990 && expr2_tmp->ts.type != BT_COMPLEX
3991 && expr2_tmp->ts.type != BT_LOGICAL)
3992 || expr2_tmp->symtree->n.sym == var)
3993 {
3994 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read from "
3995 "a scalar variable of intrinsic type at %L",
3996 &expr2_tmp->where);
3997 return;
3998 }
3999 var = expr2_tmp->symtree->n.sym;
4000 code = code->next;
4001 if (code->expr1->expr_type != EXPR_VARIABLE
4002 || code->expr1->symtree == NULL
4003 || code->expr1->rank != 0
4004 || (code->expr1->ts.type != BT_INTEGER
4005 && code->expr1->ts.type != BT_REAL
4006 && code->expr1->ts.type != BT_COMPLEX
4007 && code->expr1->ts.type != BT_LOGICAL))
4008 {
4009 gfc_error ("!$OMP ATOMIC CAPTURE update statement must set "
4010 "a scalar variable of intrinsic type at %L",
4011 &code->expr1->where);
4012 return;
4013 }
4014 if (code->expr1->symtree->n.sym != var)
4015 {
4016 gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
4017 "different variable than update statement writes "
4018 "into at %L", &code->expr1->where);
4019 return;
4020 }
4021 expr2 = is_conversion (code->expr2, false);
4022 if (expr2 == NULL)
4023 expr2 = code->expr2;
4024 }
4025 break;
4026 default:
4027 break;
4028 }
4029
4030 if (gfc_expr_attr (code->expr1).allocatable)
4031 {
4032 gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L",
4033 &code->loc);
4034 return;
4035 }
4036
4037 if (aop == GFC_OMP_ATOMIC_CAPTURE
4038 && code->next == NULL
4039 && code->expr2->rank == 0
4040 && !expr_references_sym (code->expr2, var, NULL))
4041 atomic_code->ext.omp_atomic
4042 = (gfc_omp_atomic_op) (atomic_code->ext.omp_atomic
4043 | GFC_OMP_ATOMIC_SWAP);
4044 else if (expr2->expr_type == EXPR_OP)
4045 {
4046 gfc_expr *v = NULL, *e, *c;
4047 gfc_intrinsic_op op = expr2->value.op.op;
4048 gfc_intrinsic_op alt_op = INTRINSIC_NONE;
4049
4050 switch (op)
4051 {
4052 case INTRINSIC_PLUS:
4053 alt_op = INTRINSIC_MINUS;
4054 break;
4055 case INTRINSIC_TIMES:
4056 alt_op = INTRINSIC_DIVIDE;
4057 break;
4058 case INTRINSIC_MINUS:
4059 alt_op = INTRINSIC_PLUS;
4060 break;
4061 case INTRINSIC_DIVIDE:
4062 alt_op = INTRINSIC_TIMES;
4063 break;
4064 case INTRINSIC_AND:
4065 case INTRINSIC_OR:
4066 break;
4067 case INTRINSIC_EQV:
4068 alt_op = INTRINSIC_NEQV;
4069 break;
4070 case INTRINSIC_NEQV:
4071 alt_op = INTRINSIC_EQV;
4072 break;
4073 default:
4074 gfc_error ("!$OMP ATOMIC assignment operator must be binary "
4075 "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
4076 &expr2->where);
4077 return;
4078 }
4079
4080 /* Check for var = var op expr resp. var = expr op var where
4081 expr doesn't reference var and var op expr is mathematically
4082 equivalent to var op (expr) resp. expr op var equivalent to
4083 (expr) op var. We rely here on the fact that the matcher
4084 for x op1 y op2 z where op1 and op2 have equal precedence
4085 returns (x op1 y) op2 z. */
4086 e = expr2->value.op.op2;
4087 if (e->expr_type == EXPR_VARIABLE
4088 && e->symtree != NULL
4089 && e->symtree->n.sym == var)
4090 v = e;
4091 else if ((c = is_conversion (e, true)) != NULL
4092 && c->expr_type == EXPR_VARIABLE
4093 && c->symtree != NULL
4094 && c->symtree->n.sym == var)
4095 v = c;
4096 else
4097 {
4098 gfc_expr **p = NULL, **q;
4099 for (q = &expr2->value.op.op1; (e = *q) != NULL; )
4100 if (e->expr_type == EXPR_VARIABLE
4101 && e->symtree != NULL
4102 && e->symtree->n.sym == var)
4103 {
4104 v = e;
4105 break;
4106 }
4107 else if ((c = is_conversion (e, true)) != NULL)
4108 q = &e->value.function.actual->expr;
4109 else if (e->expr_type != EXPR_OP
4110 || (e->value.op.op != op
4111 && e->value.op.op != alt_op)
4112 || e->rank != 0)
4113 break;
4114 else
4115 {
4116 p = q;
4117 q = &e->value.op.op1;
4118 }
4119
4120 if (v == NULL)
4121 {
4122 gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
4123 "or var = expr op var at %L", &expr2->where);
4124 return;
4125 }
4126
4127 if (p != NULL)
4128 {
4129 e = *p;
4130 switch (e->value.op.op)
4131 {
4132 case INTRINSIC_MINUS:
4133 case INTRINSIC_DIVIDE:
4134 case INTRINSIC_EQV:
4135 case INTRINSIC_NEQV:
4136 gfc_error ("!$OMP ATOMIC var = var op expr not "
4137 "mathematically equivalent to var = var op "
4138 "(expr) at %L", &expr2->where);
4139 break;
4140 default:
4141 break;
4142 }
4143
4144 /* Canonicalize into var = var op (expr). */
4145 *p = e->value.op.op2;
4146 e->value.op.op2 = expr2;
4147 e->ts = expr2->ts;
4148 if (code->expr2 == expr2)
4149 code->expr2 = expr2 = e;
4150 else
4151 code->expr2->value.function.actual->expr = expr2 = e;
4152
4153 if (!gfc_compare_types (&expr2->value.op.op1->ts, &expr2->ts))
4154 {
4155 for (p = &expr2->value.op.op1; *p != v;
4156 p = &(*p)->value.function.actual->expr)
4157 ;
4158 *p = NULL;
4159 gfc_free_expr (expr2->value.op.op1);
4160 expr2->value.op.op1 = v;
4161 gfc_convert_type (v, &expr2->ts, 2);
4162 }
4163 }
4164 }
4165
4166 if (e->rank != 0 || expr_references_sym (code->expr2, var, v))
4167 {
4168 gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
4169 "must be scalar and cannot reference var at %L",
4170 &expr2->where);
4171 return;
4172 }
4173 }
4174 else if (expr2->expr_type == EXPR_FUNCTION
4175 && expr2->value.function.isym != NULL
4176 && expr2->value.function.esym == NULL
4177 && expr2->value.function.actual != NULL
4178 && expr2->value.function.actual->next != NULL)
4179 {
4180 gfc_actual_arglist *arg, *var_arg;
4181
4182 switch (expr2->value.function.isym->id)
4183 {
4184 case GFC_ISYM_MIN:
4185 case GFC_ISYM_MAX:
4186 break;
4187 case GFC_ISYM_IAND:
4188 case GFC_ISYM_IOR:
4189 case GFC_ISYM_IEOR:
4190 if (expr2->value.function.actual->next->next != NULL)
4191 {
4192 gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
4193 "or IEOR must have two arguments at %L",
4194 &expr2->where);
4195 return;
4196 }
4197 break;
4198 default:
4199 gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
4200 "MIN, MAX, IAND, IOR or IEOR at %L",
4201 &expr2->where);
4202 return;
4203 }
4204
4205 var_arg = NULL;
4206 for (arg = expr2->value.function.actual; arg; arg = arg->next)
4207 {
4208 if ((arg == expr2->value.function.actual
4209 || (var_arg == NULL && arg->next == NULL))
4210 && arg->expr->expr_type == EXPR_VARIABLE
4211 && arg->expr->symtree != NULL
4212 && arg->expr->symtree->n.sym == var)
4213 var_arg = arg;
4214 else if (expr_references_sym (arg->expr, var, NULL))
4215 {
4216 gfc_error ("!$OMP ATOMIC intrinsic arguments except one must "
4217 "not reference %qs at %L",
4218 var->name, &arg->expr->where);
4219 return;
4220 }
4221 if (arg->expr->rank != 0)
4222 {
4223 gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
4224 "at %L", &arg->expr->where);
4225 return;
4226 }
4227 }
4228
4229 if (var_arg == NULL)
4230 {
4231 gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
4232 "be %qs at %L", var->name, &expr2->where);
4233 return;
4234 }
4235
4236 if (var_arg != expr2->value.function.actual)
4237 {
4238 /* Canonicalize, so that var comes first. */
4239 gcc_assert (var_arg->next == NULL);
4240 for (arg = expr2->value.function.actual;
4241 arg->next != var_arg; arg = arg->next)
4242 ;
4243 var_arg->next = expr2->value.function.actual;
4244 expr2->value.function.actual = var_arg;
4245 arg->next = NULL;
4246 }
4247 }
4248 else
4249 gfc_error ("!$OMP ATOMIC assignment must have an operator or "
4250 "intrinsic on right hand side at %L", &expr2->where);
4251
4252 if (aop == GFC_OMP_ATOMIC_CAPTURE && code->next)
4253 {
4254 code = code->next;
4255 if (code->expr1->expr_type != EXPR_VARIABLE
4256 || code->expr1->symtree == NULL
4257 || code->expr1->rank != 0
4258 || (code->expr1->ts.type != BT_INTEGER
4259 && code->expr1->ts.type != BT_REAL
4260 && code->expr1->ts.type != BT_COMPLEX
4261 && code->expr1->ts.type != BT_LOGICAL))
4262 {
4263 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must set "
4264 "a scalar variable of intrinsic type at %L",
4265 &code->expr1->where);
4266 return;
4267 }
4268
4269 expr2 = is_conversion (code->expr2, false);
4270 if (expr2 == NULL)
4271 {
4272 expr2 = is_conversion (code->expr2, true);
4273 if (expr2 == NULL)
4274 expr2 = code->expr2;
4275 }
4276
4277 if (expr2->expr_type != EXPR_VARIABLE
4278 || expr2->symtree == NULL
4279 || expr2->rank != 0
4280 || (expr2->ts.type != BT_INTEGER
4281 && expr2->ts.type != BT_REAL
4282 && expr2->ts.type != BT_COMPLEX
4283 && expr2->ts.type != BT_LOGICAL))
4284 {
4285 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read "
4286 "from a scalar variable of intrinsic type at %L",
4287 &expr2->where);
4288 return;
4289 }
4290 if (expr2->symtree->n.sym != var)
4291 {
4292 gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
4293 "different variable than update statement writes "
4294 "into at %L", &expr2->where);
4295 return;
4296 }
4297 }
4298 }
4299
4300
4301 struct fortran_omp_context
4302 {
4303 gfc_code *code;
4304 hash_set<gfc_symbol *> *sharing_clauses;
4305 hash_set<gfc_symbol *> *private_iterators;
4306 struct fortran_omp_context *previous;
4307 bool is_openmp;
4308 } *omp_current_ctx;
4309 static gfc_code *omp_current_do_code;
4310 static int omp_current_do_collapse;
4311
4312 void
4313 gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
4314 {
4315 if (code->block->next && code->block->next->op == EXEC_DO)
4316 {
4317 int i;
4318 gfc_code *c;
4319
4320 omp_current_do_code = code->block->next;
4321 omp_current_do_collapse = code->ext.omp_clauses->collapse;
4322 for (i = 1, c = omp_current_do_code; i < omp_current_do_collapse; i++)
4323 {
4324 c = c->block;
4325 if (c->op != EXEC_DO || c->next == NULL)
4326 break;
4327 c = c->next;
4328 if (c->op != EXEC_DO)
4329 break;
4330 }
4331 if (i < omp_current_do_collapse || omp_current_do_collapse <= 0)
4332 omp_current_do_collapse = 1;
4333 }
4334 gfc_resolve_blocks (code->block, ns);
4335 omp_current_do_collapse = 0;
4336 omp_current_do_code = NULL;
4337 }
4338
4339
4340 void
4341 gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
4342 {
4343 struct fortran_omp_context ctx;
4344 gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
4345 gfc_omp_namelist *n;
4346 int list;
4347
4348 ctx.code = code;
4349 ctx.sharing_clauses = new hash_set<gfc_symbol *>;
4350 ctx.private_iterators = new hash_set<gfc_symbol *>;
4351 ctx.previous = omp_current_ctx;
4352 ctx.is_openmp = true;
4353 omp_current_ctx = &ctx;
4354
4355 for (list = 0; list < OMP_LIST_NUM; list++)
4356 switch (list)
4357 {
4358 case OMP_LIST_SHARED:
4359 case OMP_LIST_PRIVATE:
4360 case OMP_LIST_FIRSTPRIVATE:
4361 case OMP_LIST_LASTPRIVATE:
4362 case OMP_LIST_REDUCTION:
4363 case OMP_LIST_LINEAR:
4364 for (n = omp_clauses->lists[list]; n; n = n->next)
4365 ctx.sharing_clauses->add (n->sym);
4366 break;
4367 default:
4368 break;
4369 }
4370
4371 switch (code->op)
4372 {
4373 case EXEC_OMP_PARALLEL_DO:
4374 case EXEC_OMP_PARALLEL_DO_SIMD:
4375 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
4376 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
4377 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4378 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
4379 case EXEC_OMP_TEAMS_DISTRIBUTE:
4380 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
4381 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4382 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
4383 gfc_resolve_omp_do_blocks (code, ns);
4384 break;
4385 default:
4386 gfc_resolve_blocks (code->block, ns);
4387 }
4388
4389 omp_current_ctx = ctx.previous;
4390 delete ctx.sharing_clauses;
4391 delete ctx.private_iterators;
4392 }
4393
4394
4395 /* Save and clear openmp.c private state. */
4396
4397 void
4398 gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *state)
4399 {
4400 state->ptrs[0] = omp_current_ctx;
4401 state->ptrs[1] = omp_current_do_code;
4402 state->ints[0] = omp_current_do_collapse;
4403 omp_current_ctx = NULL;
4404 omp_current_do_code = NULL;
4405 omp_current_do_collapse = 0;
4406 }
4407
4408
4409 /* Restore openmp.c private state from the saved state. */
4410
4411 void
4412 gfc_omp_restore_state (struct gfc_omp_saved_state *state)
4413 {
4414 omp_current_ctx = (struct fortran_omp_context *) state->ptrs[0];
4415 omp_current_do_code = (gfc_code *) state->ptrs[1];
4416 omp_current_do_collapse = state->ints[0];
4417 }
4418
4419
4420 /* Note a DO iterator variable. This is special in !$omp parallel
4421 construct, where they are predetermined private. */
4422
4423 void
4424 gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym)
4425 {
4426 int i = omp_current_do_collapse;
4427 gfc_code *c = omp_current_do_code;
4428
4429 if (sym->attr.threadprivate)
4430 return;
4431
4432 /* !$omp do and !$omp parallel do iteration variable is predetermined
4433 private just in the !$omp do resp. !$omp parallel do construct,
4434 with no implications for the outer parallel constructs. */
4435
4436 while (i-- >= 1)
4437 {
4438 if (code == c)
4439 return;
4440
4441 c = c->block->next;
4442 }
4443
4444 if (omp_current_ctx == NULL)
4445 return;
4446
4447 /* An openacc context may represent a data clause. Abort if so. */
4448 if (!omp_current_ctx->is_openmp && !oacc_is_loop (omp_current_ctx->code))
4449 return;
4450
4451 if (omp_current_ctx->is_openmp
4452 && omp_current_ctx->sharing_clauses->contains (sym))
4453 return;
4454
4455 if (! omp_current_ctx->private_iterators->add (sym))
4456 {
4457 gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses;
4458 gfc_omp_namelist *p;
4459
4460 p = gfc_get_omp_namelist ();
4461 p->sym = sym;
4462 p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
4463 omp_clauses->lists[OMP_LIST_PRIVATE] = p;
4464 }
4465 }
4466
4467
4468 static void
4469 resolve_omp_do (gfc_code *code)
4470 {
4471 gfc_code *do_code, *c;
4472 int list, i, collapse;
4473 gfc_omp_namelist *n;
4474 gfc_symbol *dovar;
4475 const char *name;
4476 bool is_simd = false;
4477
4478 switch (code->op)
4479 {
4480 case EXEC_OMP_DISTRIBUTE: name = "!$OMP DISTRIBUTE"; break;
4481 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
4482 name = "!$OMP DISTRIBUTE PARALLEL DO";
4483 break;
4484 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
4485 name = "!$OMP DISTRIBUTE PARALLEL DO SIMD";
4486 is_simd = true;
4487 break;
4488 case EXEC_OMP_DISTRIBUTE_SIMD:
4489 name = "!$OMP DISTRIBUTE SIMD";
4490 is_simd = true;
4491 break;
4492 case EXEC_OMP_DO: name = "!$OMP DO"; break;
4493 case EXEC_OMP_DO_SIMD: name = "!$OMP DO SIMD"; is_simd = true; break;
4494 case EXEC_OMP_PARALLEL_DO: name = "!$OMP PARALLEL DO"; break;
4495 case EXEC_OMP_PARALLEL_DO_SIMD:
4496 name = "!$OMP PARALLEL DO SIMD";
4497 is_simd = true;
4498 break;
4499 case EXEC_OMP_SIMD: name = "!$OMP SIMD"; is_simd = true; break;
4500 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
4501 name = "!$OMP TARGET TEAMS_DISTRIBUTE";
4502 break;
4503 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
4504 name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
4505 break;
4506 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4507 name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
4508 is_simd = true;
4509 break;
4510 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
4511 name = "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
4512 is_simd = true;
4513 break;
4514 case EXEC_OMP_TEAMS_DISTRIBUTE: name = "!$OMP TEAMS_DISTRIBUTE"; break;
4515 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
4516 name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
4517 break;
4518 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
4519 name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
4520 is_simd = true;
4521 break;
4522 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
4523 name = "!$OMP TEAMS DISTRIBUTE SIMD";
4524 is_simd = true;
4525 break;
4526 default: gcc_unreachable ();
4527 }
4528
4529 if (code->ext.omp_clauses)
4530 resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
4531
4532 do_code = code->block->next;
4533 collapse = code->ext.omp_clauses->collapse;
4534 if (collapse <= 0)
4535 collapse = 1;
4536 for (i = 1; i <= collapse; i++)
4537 {
4538 if (do_code->op == EXEC_DO_WHILE)
4539 {
4540 gfc_error ("%s cannot be a DO WHILE or DO without loop control "
4541 "at %L", name, &do_code->loc);
4542 break;
4543 }
4544 if (do_code->op == EXEC_DO_CONCURRENT)
4545 {
4546 gfc_error ("%s cannot be a DO CONCURRENT loop at %L", name,
4547 &do_code->loc);
4548 break;
4549 }
4550 gcc_assert (do_code->op == EXEC_DO);
4551 if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
4552 gfc_error ("%s iteration variable must be of type integer at %L",
4553 name, &do_code->loc);
4554 dovar = do_code->ext.iterator->var->symtree->n.sym;
4555 if (dovar->attr.threadprivate)
4556 gfc_error ("%s iteration variable must not be THREADPRIVATE "
4557 "at %L", name, &do_code->loc);
4558 if (code->ext.omp_clauses)
4559 for (list = 0; list < OMP_LIST_NUM; list++)
4560 if (!is_simd
4561 ? (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE)
4562 : code->ext.omp_clauses->collapse > 1
4563 ? (list != OMP_LIST_LASTPRIVATE)
4564 : (list != OMP_LIST_LINEAR))
4565 for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
4566 if (dovar == n->sym)
4567 {
4568 if (!is_simd)
4569 gfc_error ("%s iteration variable present on clause "
4570 "other than PRIVATE or LASTPRIVATE at %L",
4571 name, &do_code->loc);
4572 else if (code->ext.omp_clauses->collapse > 1)
4573 gfc_error ("%s iteration variable present on clause "
4574 "other than LASTPRIVATE at %L",
4575 name, &do_code->loc);
4576 else
4577 gfc_error ("%s iteration variable present on clause "
4578 "other than LINEAR at %L",
4579 name, &do_code->loc);
4580 break;
4581 }
4582 if (i > 1)
4583 {
4584 gfc_code *do_code2 = code->block->next;
4585 int j;
4586
4587 for (j = 1; j < i; j++)
4588 {
4589 gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
4590 if (dovar == ivar
4591 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
4592 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
4593 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
4594 {
4595 gfc_error ("%s collapsed loops don't form rectangular "
4596 "iteration space at %L", name, &do_code->loc);
4597 break;
4598 }
4599 if (j < i)
4600 break;
4601 do_code2 = do_code2->block->next;
4602 }
4603 }
4604 if (i == collapse)
4605 break;
4606 for (c = do_code->next; c; c = c->next)
4607 if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
4608 {
4609 gfc_error ("collapsed %s loops not perfectly nested at %L",
4610 name, &c->loc);
4611 break;
4612 }
4613 if (c)
4614 break;
4615 do_code = do_code->block;
4616 if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE)
4617 {
4618 gfc_error ("not enough DO loops for collapsed %s at %L",
4619 name, &code->loc);
4620 break;
4621 }
4622 do_code = do_code->next;
4623 if (do_code == NULL
4624 || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE))
4625 {
4626 gfc_error ("not enough DO loops for collapsed %s at %L",
4627 name, &code->loc);
4628 break;
4629 }
4630 }
4631 }
4632
4633 static bool
4634 oacc_is_parallel (gfc_code *code)
4635 {
4636 return code->op == EXEC_OACC_PARALLEL || code->op == EXEC_OACC_PARALLEL_LOOP;
4637 }
4638
4639 static bool
4640 oacc_is_kernels (gfc_code *code)
4641 {
4642 return code->op == EXEC_OACC_KERNELS || code->op == EXEC_OACC_KERNELS_LOOP;
4643 }
4644
4645 static gfc_statement
4646 omp_code_to_statement (gfc_code *code)
4647 {
4648 switch (code->op)
4649 {
4650 case EXEC_OMP_PARALLEL:
4651 return ST_OMP_PARALLEL;
4652 case EXEC_OMP_PARALLEL_SECTIONS:
4653 return ST_OMP_PARALLEL_SECTIONS;
4654 case EXEC_OMP_SECTIONS:
4655 return ST_OMP_SECTIONS;
4656 case EXEC_OMP_ORDERED:
4657 return ST_OMP_ORDERED;
4658 case EXEC_OMP_CRITICAL:
4659 return ST_OMP_CRITICAL;
4660 case EXEC_OMP_MASTER:
4661 return ST_OMP_MASTER;
4662 case EXEC_OMP_SINGLE:
4663 return ST_OMP_SINGLE;
4664 case EXEC_OMP_TASK:
4665 return ST_OMP_TASK;
4666 case EXEC_OMP_WORKSHARE:
4667 return ST_OMP_WORKSHARE;
4668 case EXEC_OMP_PARALLEL_WORKSHARE:
4669 return ST_OMP_PARALLEL_WORKSHARE;
4670 case EXEC_OMP_DO:
4671 return ST_OMP_DO;
4672 default:
4673 gcc_unreachable ();
4674 }
4675 }
4676
4677 static gfc_statement
4678 oacc_code_to_statement (gfc_code *code)
4679 {
4680 switch (code->op)
4681 {
4682 case EXEC_OACC_PARALLEL:
4683 return ST_OACC_PARALLEL;
4684 case EXEC_OACC_KERNELS:
4685 return ST_OACC_KERNELS;
4686 case EXEC_OACC_DATA:
4687 return ST_OACC_DATA;
4688 case EXEC_OACC_HOST_DATA:
4689 return ST_OACC_HOST_DATA;
4690 case EXEC_OACC_PARALLEL_LOOP:
4691 return ST_OACC_PARALLEL_LOOP;
4692 case EXEC_OACC_KERNELS_LOOP:
4693 return ST_OACC_KERNELS_LOOP;
4694 case EXEC_OACC_LOOP:
4695 return ST_OACC_LOOP;
4696 case EXEC_OACC_ATOMIC:
4697 return ST_OACC_ATOMIC;
4698 default:
4699 gcc_unreachable ();
4700 }
4701 }
4702
4703 static void
4704 resolve_oacc_directive_inside_omp_region (gfc_code *code)
4705 {
4706 if (omp_current_ctx != NULL && omp_current_ctx->is_openmp)
4707 {
4708 gfc_statement st = omp_code_to_statement (omp_current_ctx->code);
4709 gfc_statement oacc_st = oacc_code_to_statement (code);
4710 gfc_error ("The %s directive cannot be specified within "
4711 "a %s region at %L", gfc_ascii_statement (oacc_st),
4712 gfc_ascii_statement (st), &code->loc);
4713 }
4714 }
4715
4716 static void
4717 resolve_omp_directive_inside_oacc_region (gfc_code *code)
4718 {
4719 if (omp_current_ctx != NULL && !omp_current_ctx->is_openmp)
4720 {
4721 gfc_statement st = oacc_code_to_statement (omp_current_ctx->code);
4722 gfc_statement omp_st = omp_code_to_statement (code);
4723 gfc_error ("The %s directive cannot be specified within "
4724 "a %s region at %L", gfc_ascii_statement (omp_st),
4725 gfc_ascii_statement (st), &code->loc);
4726 }
4727 }
4728
4729
4730 static void
4731 resolve_oacc_nested_loops (gfc_code *code, gfc_code* do_code, int collapse,
4732 const char *clause)
4733 {
4734 gfc_symbol *dovar;
4735 gfc_code *c;
4736 int i;
4737
4738 for (i = 1; i <= collapse; i++)
4739 {
4740 if (do_code->op == EXEC_DO_WHILE)
4741 {
4742 gfc_error ("!$ACC LOOP cannot be a DO WHILE or DO without loop control "
4743 "at %L", &do_code->loc);
4744 break;
4745 }
4746 gcc_assert (do_code->op == EXEC_DO || do_code->op == EXEC_DO_CONCURRENT);
4747 if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
4748 gfc_error ("!$ACC LOOP iteration variable must be of type integer at %L",
4749 &do_code->loc);
4750 dovar = do_code->ext.iterator->var->symtree->n.sym;
4751 if (i > 1)
4752 {
4753 gfc_code *do_code2 = code->block->next;
4754 int j;
4755
4756 for (j = 1; j < i; j++)
4757 {
4758 gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
4759 if (dovar == ivar
4760 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
4761 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
4762 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
4763 {
4764 gfc_error ("!$ACC LOOP %s loops don't form rectangular iteration space at %L",
4765 clause, &do_code->loc);
4766 break;
4767 }
4768 if (j < i)
4769 break;
4770 do_code2 = do_code2->block->next;
4771 }
4772 }
4773 if (i == collapse)
4774 break;
4775 for (c = do_code->next; c; c = c->next)
4776 if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
4777 {
4778 gfc_error ("%s !$ACC LOOP loops not perfectly nested at %L",
4779 clause, &c->loc);
4780 break;
4781 }
4782 if (c)
4783 break;
4784 do_code = do_code->block;
4785 if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
4786 && do_code->op != EXEC_DO_CONCURRENT)
4787 {
4788 gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
4789 clause, &code->loc);
4790 break;
4791 }
4792 do_code = do_code->next;
4793 if (do_code == NULL
4794 || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
4795 && do_code->op != EXEC_DO_CONCURRENT))
4796 {
4797 gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
4798 clause, &code->loc);
4799 break;
4800 }
4801 }
4802 }
4803
4804
4805 static void
4806 resolve_oacc_params_in_parallel (gfc_code *code, const char *clause,
4807 const char *arg)
4808 {
4809 fortran_omp_context *c;
4810
4811 if (oacc_is_parallel (code))
4812 gfc_error ("!$ACC LOOP %s in PARALLEL region doesn't allow "
4813 "%s arguments at %L", clause, arg, &code->loc);
4814 for (c = omp_current_ctx; c; c = c->previous)
4815 {
4816 if (oacc_is_loop (c->code))
4817 break;
4818 if (oacc_is_parallel (c->code))
4819 gfc_error ("!$ACC LOOP %s in PARALLEL region doesn't allow "
4820 "%s arguments at %L", clause, arg, &code->loc);
4821 }
4822 }
4823
4824
4825 static void
4826 resolve_oacc_loop_blocks (gfc_code *code)
4827 {
4828 fortran_omp_context *c;
4829
4830 if (!oacc_is_loop (code))
4831 return;
4832
4833 if (code->op == EXEC_OACC_LOOP)
4834 for (c = omp_current_ctx; c; c = c->previous)
4835 {
4836 if (oacc_is_loop (c->code))
4837 {
4838 if (code->ext.omp_clauses->gang)
4839 {
4840 if (c->code->ext.omp_clauses->gang)
4841 gfc_error ("Loop parallelized across gangs is not allowed "
4842 "inside another loop parallelized across gangs at %L",
4843 &code->loc);
4844 if (c->code->ext.omp_clauses->worker)
4845 gfc_error ("Loop parallelized across gangs is not allowed "
4846 "inside loop parallelized across workers at %L",
4847 &code->loc);
4848 if (c->code->ext.omp_clauses->vector)
4849 gfc_error ("Loop parallelized across gangs is not allowed "
4850 "inside loop parallelized across workers at %L",
4851 &code->loc);
4852 }
4853 if (code->ext.omp_clauses->worker)
4854 {
4855 if (c->code->ext.omp_clauses->worker)
4856 gfc_error ("Loop parallelized across workers is not allowed "
4857 "inside another loop parallelized across workers at %L",
4858 &code->loc);
4859 if (c->code->ext.omp_clauses->vector)
4860 gfc_error ("Loop parallelized across workers is not allowed "
4861 "inside another loop parallelized across vectors at %L",
4862 &code->loc);
4863 }
4864 if (code->ext.omp_clauses->vector)
4865 if (c->code->ext.omp_clauses->vector)
4866 gfc_error ("Loop parallelized across vectors is not allowed "
4867 "inside another loop parallelized across vectors at %L",
4868 &code->loc);
4869 }
4870
4871 if (oacc_is_parallel (c->code) || oacc_is_kernels (c->code))
4872 break;
4873 }
4874
4875 if (code->ext.omp_clauses->seq)
4876 {
4877 if (code->ext.omp_clauses->independent)
4878 gfc_error ("Clause SEQ conflicts with INDEPENDENT at %L", &code->loc);
4879 if (code->ext.omp_clauses->gang)
4880 gfc_error ("Clause SEQ conflicts with GANG at %L", &code->loc);
4881 if (code->ext.omp_clauses->worker)
4882 gfc_error ("Clause SEQ conflicts with WORKER at %L", &code->loc);
4883 if (code->ext.omp_clauses->vector)
4884 gfc_error ("Clause SEQ conflicts with VECTOR at %L", &code->loc);
4885 if (code->ext.omp_clauses->par_auto)
4886 gfc_error ("Clause SEQ conflicts with AUTO at %L", &code->loc);
4887 }
4888 if (code->ext.omp_clauses->par_auto)
4889 {
4890 if (code->ext.omp_clauses->gang)
4891 gfc_error ("Clause AUTO conflicts with GANG at %L", &code->loc);
4892 if (code->ext.omp_clauses->worker)
4893 gfc_error ("Clause AUTO conflicts with WORKER at %L", &code->loc);
4894 if (code->ext.omp_clauses->vector)
4895 gfc_error ("Clause AUTO conflicts with VECTOR at %L", &code->loc);
4896 }
4897 if (code->ext.omp_clauses->tile_list && code->ext.omp_clauses->gang
4898 && code->ext.omp_clauses->worker && code->ext.omp_clauses->vector)
4899 gfc_error ("Tiled loop cannot be parallelized across gangs, workers and "
4900 "vectors at the same time at %L", &code->loc);
4901
4902 if (code->ext.omp_clauses->gang
4903 && code->ext.omp_clauses->gang_num_expr)
4904 resolve_oacc_params_in_parallel (code, "GANG", "num");
4905
4906 if (code->ext.omp_clauses->worker
4907 && code->ext.omp_clauses->worker_expr)
4908 resolve_oacc_params_in_parallel (code, "WORKER", "num");
4909
4910 if (code->ext.omp_clauses->vector
4911 && code->ext.omp_clauses->vector_expr)
4912 resolve_oacc_params_in_parallel (code, "VECTOR", "length");
4913
4914 if (code->ext.omp_clauses->tile_list)
4915 {
4916 gfc_expr_list *el;
4917 int num = 0;
4918 for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
4919 {
4920 num++;
4921 if (el->expr == NULL)
4922 {
4923 /* NULL expressions are used to represent '*' arguments.
4924 Convert those to a -1 expressions. */
4925 el->expr = gfc_get_constant_expr (BT_INTEGER,
4926 gfc_default_integer_kind,
4927 &code->loc);
4928 mpz_set_si (el->expr->value.integer, -1);
4929 }
4930 else
4931 {
4932 resolve_oacc_positive_int_expr (el->expr, "TILE");
4933 if (el->expr->expr_type != EXPR_CONSTANT)
4934 gfc_error ("TILE requires constant expression at %L",
4935 &code->loc);
4936 }
4937 }
4938 resolve_oacc_nested_loops (code, code->block->next, num, "tiled");
4939 }
4940 }
4941
4942
4943 void
4944 gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns)
4945 {
4946 fortran_omp_context ctx;
4947
4948 resolve_oacc_loop_blocks (code);
4949
4950 ctx.code = code;
4951 ctx.sharing_clauses = NULL;
4952 ctx.private_iterators = new hash_set<gfc_symbol *>;
4953 ctx.previous = omp_current_ctx;
4954 ctx.is_openmp = false;
4955 omp_current_ctx = &ctx;
4956
4957 gfc_resolve_blocks (code->block, ns);
4958
4959 omp_current_ctx = ctx.previous;
4960 delete ctx.private_iterators;
4961 }
4962
4963
4964 static void
4965 resolve_oacc_loop (gfc_code *code)
4966 {
4967 gfc_code *do_code;
4968 int collapse;
4969
4970 if (code->ext.omp_clauses)
4971 resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
4972
4973 do_code = code->block->next;
4974 collapse = code->ext.omp_clauses->collapse;
4975
4976 if (collapse <= 0)
4977 collapse = 1;
4978 resolve_oacc_nested_loops (code, do_code, collapse, "collapsed");
4979 }
4980
4981 void
4982 gfc_resolve_oacc_declare (gfc_namespace *ns)
4983 {
4984 int list;
4985 gfc_omp_namelist *n;
4986 gfc_oacc_declare *oc;
4987
4988 if (ns->oacc_declare == NULL)
4989 return;
4990
4991 for (oc = ns->oacc_declare; oc; oc = oc->next)
4992 {
4993 for (list = 0; list < OMP_LIST_NUM; list++)
4994 for (n = oc->clauses->lists[list]; n; n = n->next)
4995 {
4996 n->sym->mark = 0;
4997 if (n->sym->attr.flavor == FL_PARAMETER)
4998 {
4999 gfc_error ("PARAMETER object %qs is not allowed at %L",
5000 n->sym->name, &oc->loc);
5001 continue;
5002 }
5003
5004 if (n->expr && n->expr->ref->type == REF_ARRAY)
5005 {
5006 gfc_error ("Array sections: %qs not allowed in"
5007 " $!ACC DECLARE at %L", n->sym->name, &oc->loc);
5008 continue;
5009 }
5010 }
5011
5012 for (n = oc->clauses->lists[OMP_LIST_DEVICE_RESIDENT]; n; n = n->next)
5013 check_array_not_assumed (n->sym, oc->loc, "DEVICE_RESIDENT");
5014 }
5015
5016 for (oc = ns->oacc_declare; oc; oc = oc->next)
5017 {
5018 for (list = 0; list < OMP_LIST_NUM; list++)
5019 for (n = oc->clauses->lists[list]; n; n = n->next)
5020 {
5021 if (n->sym->mark)
5022 {
5023 gfc_error ("Symbol %qs present on multiple clauses at %L",
5024 n->sym->name, &oc->loc);
5025 continue;
5026 }
5027 else
5028 n->sym->mark = 1;
5029 }
5030 }
5031
5032 for (oc = ns->oacc_declare; oc; oc = oc->next)
5033 {
5034 for (list = 0; list < OMP_LIST_NUM; list++)
5035 for (n = oc->clauses->lists[list]; n; n = n->next)
5036 n->sym->mark = 0;
5037 }
5038 }
5039
5040 void
5041 gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
5042 {
5043 resolve_oacc_directive_inside_omp_region (code);
5044
5045 switch (code->op)
5046 {
5047 case EXEC_OACC_PARALLEL:
5048 case EXEC_OACC_KERNELS:
5049 case EXEC_OACC_DATA:
5050 case EXEC_OACC_HOST_DATA:
5051 case EXEC_OACC_UPDATE:
5052 case EXEC_OACC_ENTER_DATA:
5053 case EXEC_OACC_EXIT_DATA:
5054 case EXEC_OACC_WAIT:
5055 case EXEC_OACC_CACHE:
5056 resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
5057 break;
5058 case EXEC_OACC_PARALLEL_LOOP:
5059 case EXEC_OACC_KERNELS_LOOP:
5060 case EXEC_OACC_LOOP:
5061 resolve_oacc_loop (code);
5062 break;
5063 case EXEC_OACC_ATOMIC:
5064 resolve_omp_atomic (code);
5065 break;
5066 default:
5067 break;
5068 }
5069 }
5070
5071
5072 /* Resolve OpenMP directive clauses and check various requirements
5073 of each directive. */
5074
5075 void
5076 gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
5077 {
5078 resolve_omp_directive_inside_oacc_region (code);
5079
5080 if (code->op != EXEC_OMP_ATOMIC)
5081 gfc_maybe_initialize_eh ();
5082
5083 switch (code->op)
5084 {
5085 case EXEC_OMP_DISTRIBUTE:
5086 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
5087 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
5088 case EXEC_OMP_DISTRIBUTE_SIMD:
5089 case EXEC_OMP_DO:
5090 case EXEC_OMP_DO_SIMD:
5091 case EXEC_OMP_PARALLEL_DO:
5092 case EXEC_OMP_PARALLEL_DO_SIMD:
5093 case EXEC_OMP_SIMD:
5094 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
5095 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
5096 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5097 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
5098 case EXEC_OMP_TEAMS_DISTRIBUTE:
5099 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
5100 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5101 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
5102 resolve_omp_do (code);
5103 break;
5104 case EXEC_OMP_CANCEL:
5105 case EXEC_OMP_PARALLEL_WORKSHARE:
5106 case EXEC_OMP_PARALLEL:
5107 case EXEC_OMP_PARALLEL_SECTIONS:
5108 case EXEC_OMP_SECTIONS:
5109 case EXEC_OMP_SINGLE:
5110 case EXEC_OMP_TARGET:
5111 case EXEC_OMP_TARGET_DATA:
5112 case EXEC_OMP_TARGET_TEAMS:
5113 case EXEC_OMP_TASK:
5114 case EXEC_OMP_TEAMS:
5115 case EXEC_OMP_WORKSHARE:
5116 if (code->ext.omp_clauses)
5117 resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
5118 break;
5119 case EXEC_OMP_TARGET_UPDATE:
5120 if (code->ext.omp_clauses)
5121 resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
5122 if (code->ext.omp_clauses == NULL
5123 || (code->ext.omp_clauses->lists[OMP_LIST_TO] == NULL
5124 && code->ext.omp_clauses->lists[OMP_LIST_FROM] == NULL))
5125 gfc_error ("OMP TARGET UPDATE at %L requires at least one TO or "
5126 "FROM clause", &code->loc);
5127 break;
5128 case EXEC_OMP_ATOMIC:
5129 resolve_omp_atomic (code);
5130 break;
5131 default:
5132 break;
5133 }
5134 }
5135
5136 /* Resolve !$omp declare simd constructs in NS. */
5137
5138 void
5139 gfc_resolve_omp_declare_simd (gfc_namespace *ns)
5140 {
5141 gfc_omp_declare_simd *ods;
5142
5143 for (ods = ns->omp_declare_simd; ods; ods = ods->next)
5144 {
5145 if (ods->proc_name != ns->proc_name)
5146 gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure "
5147 "%qs at %L", ns->proc_name->name, &ods->where);
5148 if (ods->clauses)
5149 resolve_omp_clauses (NULL, ods->clauses, ns);
5150 }
5151 }
5152
5153 struct omp_udr_callback_data
5154 {
5155 gfc_omp_udr *omp_udr;
5156 bool is_initializer;
5157 };
5158
5159 static int
5160 omp_udr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
5161 void *data)
5162 {
5163 struct omp_udr_callback_data *cd = (struct omp_udr_callback_data *) data;
5164 if ((*e)->expr_type == EXPR_VARIABLE)
5165 {
5166 if (cd->is_initializer)
5167 {
5168 if ((*e)->symtree->n.sym != cd->omp_udr->omp_priv
5169 && (*e)->symtree->n.sym != cd->omp_udr->omp_orig)
5170 gfc_error ("Variable other than OMP_PRIV or OMP_ORIG used in "
5171 "INITIALIZER clause of !$OMP DECLARE REDUCTION at %L",
5172 &(*e)->where);
5173 }
5174 else
5175 {
5176 if ((*e)->symtree->n.sym != cd->omp_udr->omp_out
5177 && (*e)->symtree->n.sym != cd->omp_udr->omp_in)
5178 gfc_error ("Variable other than OMP_OUT or OMP_IN used in "
5179 "combiner of !$OMP DECLARE REDUCTION at %L",
5180 &(*e)->where);
5181 }
5182 }
5183 return 0;
5184 }
5185
5186 /* Resolve !$omp declare reduction constructs. */
5187
5188 static void
5189 gfc_resolve_omp_udr (gfc_omp_udr *omp_udr)
5190 {
5191 gfc_actual_arglist *a;
5192 const char *predef_name = NULL;
5193
5194 switch (omp_udr->rop)
5195 {
5196 case OMP_REDUCTION_PLUS:
5197 case OMP_REDUCTION_TIMES:
5198 case OMP_REDUCTION_MINUS:
5199 case OMP_REDUCTION_AND:
5200 case OMP_REDUCTION_OR:
5201 case OMP_REDUCTION_EQV:
5202 case OMP_REDUCTION_NEQV:
5203 case OMP_REDUCTION_MAX:
5204 case OMP_REDUCTION_USER:
5205 break;
5206 default:
5207 gfc_error ("Invalid operator for !$OMP DECLARE REDUCTION %s at %L",
5208 omp_udr->name, &omp_udr->where);
5209 return;
5210 }
5211
5212 if (gfc_omp_udr_predef (omp_udr->rop, omp_udr->name,
5213 &omp_udr->ts, &predef_name))
5214 {
5215 if (predef_name)
5216 gfc_error_now ("Redefinition of predefined %s "
5217 "!$OMP DECLARE REDUCTION at %L",
5218 predef_name, &omp_udr->where);
5219 else
5220 gfc_error_now ("Redefinition of predefined "
5221 "!$OMP DECLARE REDUCTION at %L", &omp_udr->where);
5222 return;
5223 }
5224
5225 if (omp_udr->ts.type == BT_CHARACTER
5226 && omp_udr->ts.u.cl->length
5227 && omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
5228 {
5229 gfc_error ("CHARACTER length in !$OMP DECLARE REDUCTION %s not "
5230 "constant at %L", omp_udr->name, &omp_udr->where);
5231 return;
5232 }
5233
5234 struct omp_udr_callback_data cd;
5235 cd.omp_udr = omp_udr;
5236 cd.is_initializer = false;
5237 gfc_code_walker (&omp_udr->combiner_ns->code, gfc_dummy_code_callback,
5238 omp_udr_callback, &cd);
5239 if (omp_udr->combiner_ns->code->op == EXEC_CALL)
5240 {
5241 for (a = omp_udr->combiner_ns->code->ext.actual; a; a = a->next)
5242 if (a->expr == NULL)
5243 break;
5244 if (a)
5245 gfc_error ("Subroutine call with alternate returns in combiner "
5246 "of !$OMP DECLARE REDUCTION at %L",
5247 &omp_udr->combiner_ns->code->loc);
5248 }
5249 if (omp_udr->initializer_ns)
5250 {
5251 cd.is_initializer = true;
5252 gfc_code_walker (&omp_udr->initializer_ns->code, gfc_dummy_code_callback,
5253 omp_udr_callback, &cd);
5254 if (omp_udr->initializer_ns->code->op == EXEC_CALL)
5255 {
5256 for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
5257 if (a->expr == NULL)
5258 break;
5259 if (a)
5260 gfc_error ("Subroutine call with alternate returns in "
5261 "INITIALIZER clause of !$OMP DECLARE REDUCTION "
5262 "at %L", &omp_udr->initializer_ns->code->loc);
5263 for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
5264 if (a->expr
5265 && a->expr->expr_type == EXPR_VARIABLE
5266 && a->expr->symtree->n.sym == omp_udr->omp_priv
5267 && a->expr->ref == NULL)
5268 break;
5269 if (a == NULL)
5270 gfc_error ("One of actual subroutine arguments in INITIALIZER "
5271 "clause of !$OMP DECLARE REDUCTION must be OMP_PRIV "
5272 "at %L", &omp_udr->initializer_ns->code->loc);
5273 }
5274 }
5275 else if (omp_udr->ts.type == BT_DERIVED
5276 && !gfc_has_default_initializer (omp_udr->ts.u.derived))
5277 {
5278 gfc_error ("Missing INITIALIZER clause for !$OMP DECLARE REDUCTION "
5279 "of derived type without default initializer at %L",
5280 &omp_udr->where);
5281 return;
5282 }
5283 }
5284
5285 void
5286 gfc_resolve_omp_udrs (gfc_symtree *st)
5287 {
5288 gfc_omp_udr *omp_udr;
5289
5290 if (st == NULL)
5291 return;
5292 gfc_resolve_omp_udrs (st->left);
5293 gfc_resolve_omp_udrs (st->right);
5294 for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
5295 gfc_resolve_omp_udr (omp_udr);
5296 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org