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