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