projects / gcc.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
match.pd: Implement simple complex operations cancelling.
[gcc.git] / gcc / fortran / openmp.c
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
31 /* Match an end of OpenMP directive. End of OpenMP directive is optional
32 whitespace, followed by '\n' or comment '!'. */
33
34 match
35 gfc_match_omp_eos (void)
36 {
37 locus old_loc;
38 char c;
39
40 old_loc = gfc_current_locus;
41 gfc_gobble_whitespace ();
42
43 c = gfc_next_ascii_char ();
44 switch (c)
45 {
46 case '!':
47 do
48 c = gfc_next_ascii_char ();
49 while (c != '\n');
50 /* Fall through */
51
52 case '\n':
53 return MATCH_YES;
54 }
55
56 gfc_current_locus = old_loc;
57 return MATCH_NO;
58 }
59
60 /* Free an omp_clauses structure. */
61
62 void
63 gfc_free_omp_clauses (gfc_omp_clauses *c)
64 {
65 int i;
66 if (c == NULL)
67 return;
68
69 gfc_free_expr (c->if_expr);
70 gfc_free_expr (c->final_expr);
71 gfc_free_expr (c->num_threads);
72 gfc_free_expr (c->chunk_size);
73 gfc_free_expr (c->safelen_expr);
74 gfc_free_expr (c->simdlen_expr);
75 gfc_free_expr (c->num_teams);
76 gfc_free_expr (c->device);
77 gfc_free_expr (c->thread_limit);
78 gfc_free_expr (c->dist_chunk_size);
79 for (i = 0; i < OMP_LIST_NUM; i++)
80 gfc_free_omp_namelist (c->lists[i]);
81 free (c);
82 }
83
84 /* Free an !$omp declare simd construct list. */
85
86 void
87 gfc_free_omp_declare_simd (gfc_omp_declare_simd *ods)
88 {
89 if (ods)
90 {
91 gfc_free_omp_clauses (ods->clauses);
92 free (ods);
93 }
94 }
95
96 void
97 gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *list)
98 {
99 while (list)
100 {
101 gfc_omp_declare_simd *current = list;
102 list = list->next;
103 gfc_free_omp_declare_simd (current);
104 }
105 }
106
107 /* Free an !$omp declare reduction. */
108
109 void
110 gfc_free_omp_udr (gfc_omp_udr *omp_udr)
111 {
112 if (omp_udr)
113 {
114 gfc_free_omp_udr (omp_udr->next);
115 gfc_free_namespace (omp_udr->combiner_ns);
116 if (omp_udr->initializer_ns)
117 gfc_free_namespace (omp_udr->initializer_ns);
118 free (omp_udr);
119 }
120 }
121
122
123 static gfc_omp_udr *
124 gfc_find_omp_udr (gfc_namespace *ns, const char *name, gfc_typespec *ts)
125 {
126 gfc_symtree *st;
127
128 if (ns == NULL)
129 ns = gfc_current_ns;
130 do
131 {
132 gfc_omp_udr *omp_udr;
133
134 st = gfc_find_symtree (ns->omp_udr_root, name);
135 if (st != NULL)
136 for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
137 if (ts == NULL)
138 return omp_udr;
139 else if (gfc_compare_types (&omp_udr->ts, ts))
140 {
141 if (ts->type == BT_CHARACTER)
142 {
143 if (omp_udr->ts.u.cl->length == NULL)
144 return omp_udr;
145 if (ts->u.cl->length == NULL)
146 continue;
147 if (gfc_compare_expr (omp_udr->ts.u.cl->length,
148 ts->u.cl->length,
149 INTRINSIC_EQ) != 0)
150 continue;
151 }
152 return omp_udr;
153 }
154
155 /* Don't escape an interface block. */
156 if (ns && !ns->has_import_set
157 && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
158 break;
159
160 ns = ns->parent;
161 }
162 while (ns != NULL);
163
164 return NULL;
165 }
166
167
168 /* Match a variable/common block list and construct a namelist from it. */
169
170 static match
171 gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list,
172 bool allow_common, bool *end_colon = NULL,
173 gfc_omp_namelist ***headp = NULL,
174 bool allow_sections = false)
175 {
176 gfc_omp_namelist *head, *tail, *p;
177 locus old_loc, cur_loc;
178 char n[GFC_MAX_SYMBOL_LEN+1];
179 gfc_symbol *sym;
180 match m;
181 gfc_symtree *st;
182
183 head = tail = NULL;
184
185 old_loc = gfc_current_locus;
186
187 m = gfc_match (str);
188 if (m != MATCH_YES)
189 return m;
190
191 for (;;)
192 {
193 cur_loc = gfc_current_locus;
194 m = gfc_match_symbol (&sym, 1);
195 switch (m)
196 {
197 case MATCH_YES:
198 gfc_expr *expr;
199 expr = NULL;
200 if (allow_sections && gfc_peek_ascii_char () == '(')
201 {
202 gfc_current_locus = cur_loc;
203 m = gfc_match_variable (&expr, 0);
204 switch (m)
205 {
206 case MATCH_ERROR:
207 goto cleanup;
208 case MATCH_NO:
209 goto syntax;
210 default:
211 break;
212 }
213 }
214 gfc_set_sym_referenced (sym);
215 p = gfc_get_omp_namelist ();
216 if (head == NULL)
217 head = tail = p;
218 else
219 {
220 tail->next = p;
221 tail = tail->next;
222 }
223 tail->sym = sym;
224 tail->expr = expr;
225 goto next_item;
226 case MATCH_NO:
227 break;
228 case MATCH_ERROR:
229 goto cleanup;
230 }
231
232 if (!allow_common)
233 goto syntax;
234
235 m = gfc_match (" / %n /", n);
236 if (m == MATCH_ERROR)
237 goto cleanup;
238 if (m == MATCH_NO)
239 goto syntax;
240
241 st = gfc_find_symtree (gfc_current_ns->common_root, n);
242 if (st == NULL)
243 {
244 gfc_error ("COMMON block /%s/ not found at %C", n);
245 goto cleanup;
246 }
247 for (sym = st->n.common->head; sym; sym = sym->common_next)
248 {
249 gfc_set_sym_referenced (sym);
250 p = gfc_get_omp_namelist ();
251 if (head == NULL)
252 head = tail = p;
253 else
254 {
255 tail->next = p;
256 tail = tail->next;
257 }
258 tail->sym = sym;
259 }
260
261 next_item:
262 if (end_colon && gfc_match_char (':') == MATCH_YES)
263 {
264 *end_colon = true;
265 break;
266 }
267 if (gfc_match_char (')') == MATCH_YES)
268 break;
269 if (gfc_match_char (',') != MATCH_YES)
270 goto syntax;
271 }
272
273 while (*list)
274 list = &(*list)->next;
275
276 *list = head;
277 if (headp)
278 *headp = list;
279 return MATCH_YES;
280
281 syntax:
282 gfc_error ("Syntax error in OpenMP variable list at %C");
283
284 cleanup:
285 gfc_free_omp_namelist (head);
286 gfc_current_locus = old_loc;
287 return MATCH_ERROR;
288 }
289
290 #define OMP_CLAUSE_PRIVATE (1U << 0)
291 #define OMP_CLAUSE_FIRSTPRIVATE (1U << 1)
292 #define OMP_CLAUSE_LASTPRIVATE (1U << 2)
293 #define OMP_CLAUSE_COPYPRIVATE (1U << 3)
294 #define OMP_CLAUSE_SHARED (1U << 4)
295 #define OMP_CLAUSE_COPYIN (1U << 5)
296 #define OMP_CLAUSE_REDUCTION (1U << 6)
297 #define OMP_CLAUSE_IF (1U << 7)
298 #define OMP_CLAUSE_NUM_THREADS (1U << 8)
299 #define OMP_CLAUSE_SCHEDULE (1U << 9)
300 #define OMP_CLAUSE_DEFAULT (1U << 10)
301 #define OMP_CLAUSE_ORDERED (1U << 11)
302 #define OMP_CLAUSE_COLLAPSE (1U << 12)
303 #define OMP_CLAUSE_UNTIED (1U << 13)
304 #define OMP_CLAUSE_FINAL (1U << 14)
305 #define OMP_CLAUSE_MERGEABLE (1U << 15)
306 #define OMP_CLAUSE_ALIGNED (1U << 16)
307 #define OMP_CLAUSE_DEPEND (1U << 17)
308 #define OMP_CLAUSE_INBRANCH (1U << 18)
309 #define OMP_CLAUSE_LINEAR (1U << 19)
310 #define OMP_CLAUSE_NOTINBRANCH (1U << 20)
311 #define OMP_CLAUSE_PROC_BIND (1U << 21)
312 #define OMP_CLAUSE_SAFELEN (1U << 22)
313 #define OMP_CLAUSE_SIMDLEN (1U << 23)
314 #define OMP_CLAUSE_UNIFORM (1U << 24)
315 #define OMP_CLAUSE_DEVICE (1U << 25)
316 #define OMP_CLAUSE_MAP (1U << 26)
317 #define OMP_CLAUSE_TO (1U << 27)
318 #define OMP_CLAUSE_FROM (1U << 28)
319 #define OMP_CLAUSE_NUM_TEAMS (1U << 29)
320 #define OMP_CLAUSE_THREAD_LIMIT (1U << 30)
321 #define OMP_CLAUSE_DIST_SCHEDULE (1U << 31)
322
323 /* Match OpenMP directive clauses. MASK is a bitmask of
324 clauses that are allowed for a particular directive. */
325
326 static match
327 gfc_match_omp_clauses (gfc_omp_clauses **cp, unsigned int mask,
328 bool first = true, bool needs_space = true)
329 {
330 gfc_omp_clauses *c = gfc_get_omp_clauses ();
331 locus old_loc;
332
333 *cp = NULL;
334 while (1)
335 {
336 if ((first || gfc_match_char (',') != MATCH_YES)
337 && (needs_space && gfc_match_space () != MATCH_YES))
338 break;
339 needs_space = false;
340 first = false;
341 gfc_gobble_whitespace ();
342 if ((mask & OMP_CLAUSE_IF) && c->if_expr == NULL
343 && gfc_match ("if ( %e )", &c->if_expr) == MATCH_YES)
344 continue;
345 if ((mask & OMP_CLAUSE_FINAL) && c->final_expr == NULL
346 && gfc_match ("final ( %e )", &c->final_expr) == MATCH_YES)
347 continue;
348 if ((mask & OMP_CLAUSE_NUM_THREADS) && c->num_threads == NULL
349 && gfc_match ("num_threads ( %e )", &c->num_threads) == MATCH_YES)
350 continue;
351 if ((mask & OMP_CLAUSE_PRIVATE)
352 && gfc_match_omp_variable_list ("private (",
353 &c->lists[OMP_LIST_PRIVATE], true)
354 == MATCH_YES)
355 continue;
356 if ((mask & OMP_CLAUSE_FIRSTPRIVATE)
357 && gfc_match_omp_variable_list ("firstprivate (",
358 &c->lists[OMP_LIST_FIRSTPRIVATE],
359 true)
360 == MATCH_YES)
361 continue;
362 if ((mask & OMP_CLAUSE_LASTPRIVATE)
363 && gfc_match_omp_variable_list ("lastprivate (",
364 &c->lists[OMP_LIST_LASTPRIVATE],
365 true)
366 == MATCH_YES)
367 continue;
368 if ((mask & OMP_CLAUSE_COPYPRIVATE)
369 && gfc_match_omp_variable_list ("copyprivate (",
370 &c->lists[OMP_LIST_COPYPRIVATE],
371 true)
372 == MATCH_YES)
373 continue;
374 if ((mask & OMP_CLAUSE_SHARED)
375 && gfc_match_omp_variable_list ("shared (",
376 &c->lists[OMP_LIST_SHARED], true)
377 == MATCH_YES)
378 continue;
379 if ((mask & OMP_CLAUSE_COPYIN)
380 && gfc_match_omp_variable_list ("copyin (",
381 &c->lists[OMP_LIST_COPYIN], true)
382 == MATCH_YES)
383 continue;
384 old_loc = gfc_current_locus;
385 if ((mask & OMP_CLAUSE_REDUCTION)
386 && gfc_match ("reduction ( ") == MATCH_YES)
387 {
388 gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
389 char buffer[GFC_MAX_SYMBOL_LEN + 3];
390 if (gfc_match_char ('+') == MATCH_YES)
391 rop = OMP_REDUCTION_PLUS;
392 else if (gfc_match_char ('*') == MATCH_YES)
393 rop = OMP_REDUCTION_TIMES;
394 else if (gfc_match_char ('-') == MATCH_YES)
395 rop = OMP_REDUCTION_MINUS;
396 else if (gfc_match (".and.") == MATCH_YES)
397 rop = OMP_REDUCTION_AND;
398 else if (gfc_match (".or.") == MATCH_YES)
399 rop = OMP_REDUCTION_OR;
400 else if (gfc_match (".eqv.") == MATCH_YES)
401 rop = OMP_REDUCTION_EQV;
402 else if (gfc_match (".neqv.") == MATCH_YES)
403 rop = OMP_REDUCTION_NEQV;
404 if (rop != OMP_REDUCTION_NONE)
405 snprintf (buffer, sizeof buffer,
406 "operator %s", gfc_op2string ((gfc_intrinsic_op) rop));
407 else if (gfc_match_defined_op_name (buffer + 1, 1) == MATCH_YES)
408 {
409 buffer[0] = '.';
410 strcat (buffer, ".");
411 }
412 else if (gfc_match_name (buffer) == MATCH_YES)
413 {
414 gfc_symbol *sym;
415 const char *n = buffer;
416
417 gfc_find_symbol (buffer, NULL, 1, &sym);
418 if (sym != NULL)
419 {
420 if (sym->attr.intrinsic)
421 n = sym->name;
422 else if ((sym->attr.flavor != FL_UNKNOWN
423 && sym->attr.flavor != FL_PROCEDURE)
424 || sym->attr.external
425 || sym->attr.generic
426 || sym->attr.entry
427 || sym->attr.result
428 || sym->attr.dummy
429 || sym->attr.subroutine
430 || sym->attr.pointer
431 || sym->attr.target
432 || sym->attr.cray_pointer
433 || sym->attr.cray_pointee
434 || (sym->attr.proc != PROC_UNKNOWN
435 && sym->attr.proc != PROC_INTRINSIC)
436 || sym->attr.if_source != IFSRC_UNKNOWN
437 || sym == sym->ns->proc_name)
438 {
439 sym = NULL;
440 n = NULL;
441 }
442 else
443 n = sym->name;
444 }
445 if (n == NULL)
446 rop = OMP_REDUCTION_NONE;
447 else if (strcmp (n, "max") == 0)
448 rop = OMP_REDUCTION_MAX;
449 else if (strcmp (n, "min") == 0)
450 rop = OMP_REDUCTION_MIN;
451 else if (strcmp (n, "iand") == 0)
452 rop = OMP_REDUCTION_IAND;
453 else if (strcmp (n, "ior") == 0)
454 rop = OMP_REDUCTION_IOR;
455 else if (strcmp (n, "ieor") == 0)
456 rop = OMP_REDUCTION_IEOR;
457 if (rop != OMP_REDUCTION_NONE
458 && sym != NULL
459 && ! sym->attr.intrinsic
460 && ! sym->attr.use_assoc
461 && ((sym->attr.flavor == FL_UNKNOWN
462 && !gfc_add_flavor (&sym->attr, FL_PROCEDURE,
463 sym->name, NULL))
464 || !gfc_add_intrinsic (&sym->attr, NULL)))
465 rop = OMP_REDUCTION_NONE;
466 }
467 else
468 buffer[0] = '\0';
469 gfc_omp_udr *udr
470 = (buffer[0]
471 ? gfc_find_omp_udr (gfc_current_ns, buffer, NULL) : NULL);
472 gfc_omp_namelist **head = NULL;
473 if (rop == OMP_REDUCTION_NONE && udr)
474 rop = OMP_REDUCTION_USER;
475
476 if (gfc_match_omp_variable_list (" :",
477 &c->lists[OMP_LIST_REDUCTION],
478 false, NULL, &head) == MATCH_YES)
479 {
480 gfc_omp_namelist *n;
481 if (rop == OMP_REDUCTION_NONE)
482 {
483 n = *head;
484 *head = NULL;
485 gfc_error_now ("!$OMP DECLARE REDUCTION %s not found "
486 "at %L", buffer, &old_loc);
487 gfc_free_omp_namelist (n);
488 }
489 else
490 for (n = *head; n; n = n->next)
491 {
492 n->u.reduction_op = rop;
493 if (udr)
494 {
495 n->udr = gfc_get_omp_namelist_udr ();
496 n->udr->udr = udr;
497 }
498 }
499 continue;
500 }
501 else
502 gfc_current_locus = old_loc;
503 }
504 if ((mask & OMP_CLAUSE_DEFAULT)
505 && c->default_sharing == OMP_DEFAULT_UNKNOWN)
506 {
507 if (gfc_match ("default ( shared )") == MATCH_YES)
508 c->default_sharing = OMP_DEFAULT_SHARED;
509 else if (gfc_match ("default ( private )") == MATCH_YES)
510 c->default_sharing = OMP_DEFAULT_PRIVATE;
511 else if (gfc_match ("default ( none )") == MATCH_YES)
512 c->default_sharing = OMP_DEFAULT_NONE;
513 else if (gfc_match ("default ( firstprivate )") == MATCH_YES)
514 c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE;
515 if (c->default_sharing != OMP_DEFAULT_UNKNOWN)
516 continue;
517 }
518 old_loc = gfc_current_locus;
519 if ((mask & OMP_CLAUSE_SCHEDULE)
520 && c->sched_kind == OMP_SCHED_NONE
521 && gfc_match ("schedule ( ") == MATCH_YES)
522 {
523 if (gfc_match ("static") == MATCH_YES)
524 c->sched_kind = OMP_SCHED_STATIC;
525 else if (gfc_match ("dynamic") == MATCH_YES)
526 c->sched_kind = OMP_SCHED_DYNAMIC;
527 else if (gfc_match ("guided") == MATCH_YES)
528 c->sched_kind = OMP_SCHED_GUIDED;
529 else if (gfc_match ("runtime") == MATCH_YES)
530 c->sched_kind = OMP_SCHED_RUNTIME;
531 else if (gfc_match ("auto") == MATCH_YES)
532 c->sched_kind = OMP_SCHED_AUTO;
533 if (c->sched_kind != OMP_SCHED_NONE)
534 {
535 match m = MATCH_NO;
536 if (c->sched_kind != OMP_SCHED_RUNTIME
537 && c->sched_kind != OMP_SCHED_AUTO)
538 m = gfc_match (" , %e )", &c->chunk_size);
539 if (m != MATCH_YES)
540 m = gfc_match_char (')');
541 if (m != MATCH_YES)
542 c->sched_kind = OMP_SCHED_NONE;
543 }
544 if (c->sched_kind != OMP_SCHED_NONE)
545 continue;
546 else
547 gfc_current_locus = old_loc;
548 }
549 if ((mask & OMP_CLAUSE_ORDERED) && !c->ordered
550 && gfc_match ("ordered") == MATCH_YES)
551 {
552 c->ordered = needs_space = true;
553 continue;
554 }
555 if ((mask & OMP_CLAUSE_UNTIED) && !c->untied
556 && gfc_match ("untied") == MATCH_YES)
557 {
558 c->untied = needs_space = true;
559 continue;
560 }
561 if ((mask & OMP_CLAUSE_MERGEABLE) && !c->mergeable
562 && gfc_match ("mergeable") == MATCH_YES)
563 {
564 c->mergeable = needs_space = true;
565 continue;
566 }
567 if ((mask & OMP_CLAUSE_COLLAPSE) && !c->collapse)
568 {
569 gfc_expr *cexpr = NULL;
570 match m = gfc_match ("collapse ( %e )", &cexpr);
571
572 if (m == MATCH_YES)
573 {
574 int collapse;
575 const char *p = gfc_extract_int (cexpr, &collapse);
576 if (p)
577 {
578 gfc_error_now (p);
579 collapse = 1;
580 }
581 else if (collapse <= 0)
582 {
583 gfc_error_now ("COLLAPSE clause argument not"
584 " constant positive integer at %C");
585 collapse = 1;
586 }
587 c->collapse = collapse;
588 gfc_free_expr (cexpr);
589 continue;
590 }
591 }
592 if ((mask & OMP_CLAUSE_INBRANCH) && !c->inbranch && !c->notinbranch
593 && gfc_match ("inbranch") == MATCH_YES)
594 {
595 c->inbranch = needs_space = true;
596 continue;
597 }
598 if ((mask & OMP_CLAUSE_NOTINBRANCH) && !c->notinbranch && !c->inbranch
599 && gfc_match ("notinbranch") == MATCH_YES)
600 {
601 c->notinbranch = needs_space = true;
602 continue;
603 }
604 if ((mask & OMP_CLAUSE_PROC_BIND)
605 && c->proc_bind == OMP_PROC_BIND_UNKNOWN)
606 {
607 if (gfc_match ("proc_bind ( master )") == MATCH_YES)
608 c->proc_bind = OMP_PROC_BIND_MASTER;
609 else if (gfc_match ("proc_bind ( spread )") == MATCH_YES)
610 c->proc_bind = OMP_PROC_BIND_SPREAD;
611 else if (gfc_match ("proc_bind ( close )") == MATCH_YES)
612 c->proc_bind = OMP_PROC_BIND_CLOSE;
613 if (c->proc_bind != OMP_PROC_BIND_UNKNOWN)
614 continue;
615 }
616 if ((mask & OMP_CLAUSE_SAFELEN) && c->safelen_expr == NULL
617 && gfc_match ("safelen ( %e )", &c->safelen_expr) == MATCH_YES)
618 continue;
619 if ((mask & OMP_CLAUSE_SIMDLEN) && c->simdlen_expr == NULL
620 && gfc_match ("simdlen ( %e )", &c->simdlen_expr) == MATCH_YES)
621 continue;
622 if ((mask & OMP_CLAUSE_UNIFORM)
623 && gfc_match_omp_variable_list ("uniform (",
624 &c->lists[OMP_LIST_UNIFORM], false)
625 == MATCH_YES)
626 continue;
627 bool end_colon = false;
628 gfc_omp_namelist **head = NULL;
629 old_loc = gfc_current_locus;
630 if ((mask & OMP_CLAUSE_ALIGNED)
631 && gfc_match_omp_variable_list ("aligned (",
632 &c->lists[OMP_LIST_ALIGNED], false,
633 &end_colon, &head)
634 == MATCH_YES)
635 {
636 gfc_expr *alignment = NULL;
637 gfc_omp_namelist *n;
638
639 if (end_colon
640 && gfc_match (" %e )", &alignment) != MATCH_YES)
641 {
642 gfc_free_omp_namelist (*head);
643 gfc_current_locus = old_loc;
644 *head = NULL;
645 break;
646 }
647 for (n = *head; n; n = n->next)
648 if (n->next && alignment)
649 n->expr = gfc_copy_expr (alignment);
650 else
651 n->expr = alignment;
652 continue;
653 }
654 end_colon = false;
655 head = NULL;
656 old_loc = gfc_current_locus;
657 if ((mask & OMP_CLAUSE_LINEAR)
658 && gfc_match_omp_variable_list ("linear (",
659 &c->lists[OMP_LIST_LINEAR], false,
660 &end_colon, &head)
661 == MATCH_YES)
662 {
663 gfc_expr *step = NULL;
664
665 if (end_colon
666 && gfc_match (" %e )", &step) != MATCH_YES)
667 {
668 gfc_free_omp_namelist (*head);
669 gfc_current_locus = old_loc;
670 *head = NULL;
671 break;
672 }
673 else if (!end_colon)
674 {
675 step = gfc_get_constant_expr (BT_INTEGER,
676 gfc_default_integer_kind,
677 &old_loc);
678 mpz_set_si (step->value.integer, 1);
679 }
680 (*head)->expr = step;
681 continue;
682 }
683 if ((mask & OMP_CLAUSE_DEPEND)
684 && gfc_match ("depend ( ") == MATCH_YES)
685 {
686 match m = MATCH_YES;
687 gfc_omp_depend_op depend_op = OMP_DEPEND_OUT;
688 if (gfc_match ("inout") == MATCH_YES)
689 depend_op = OMP_DEPEND_INOUT;
690 else if (gfc_match ("in") == MATCH_YES)
691 depend_op = OMP_DEPEND_IN;
692 else if (gfc_match ("out") == MATCH_YES)
693 depend_op = OMP_DEPEND_OUT;
694 else
695 m = MATCH_NO;
696 head = NULL;
697 if (m == MATCH_YES
698 && gfc_match_omp_variable_list (" : ",
699 &c->lists[OMP_LIST_DEPEND],
700 false, NULL, &head, true)
701 == MATCH_YES)
702 {
703 gfc_omp_namelist *n;
704 for (n = *head; n; n = n->next)
705 n->u.depend_op = depend_op;
706 continue;
707 }
708 else
709 gfc_current_locus = old_loc;
710 }
711 if ((mask & OMP_CLAUSE_DIST_SCHEDULE)
712 && c->dist_sched_kind == OMP_SCHED_NONE
713 && gfc_match ("dist_schedule ( static") == MATCH_YES)
714 {
715 match m = MATCH_NO;
716 c->dist_sched_kind = OMP_SCHED_STATIC;
717 m = gfc_match (" , %e )", &c->dist_chunk_size);
718 if (m != MATCH_YES)
719 m = gfc_match_char (')');
720 if (m != MATCH_YES)
721 {
722 c->dist_sched_kind = OMP_SCHED_NONE;
723 gfc_current_locus = old_loc;
724 }
725 else
726 continue;
727 }
728 if ((mask & OMP_CLAUSE_NUM_TEAMS) && c->num_teams == NULL
729 && gfc_match ("num_teams ( %e )", &c->num_teams) == MATCH_YES)
730 continue;
731 if ((mask & OMP_CLAUSE_DEVICE) && c->device == NULL
732 && gfc_match ("device ( %e )", &c->device) == MATCH_YES)
733 continue;
734 if ((mask & OMP_CLAUSE_THREAD_LIMIT) && c->thread_limit == NULL
735 && gfc_match ("thread_limit ( %e )", &c->thread_limit) == MATCH_YES)
736 continue;
737 if ((mask & OMP_CLAUSE_MAP)
738 && gfc_match ("map ( ") == MATCH_YES)
739 {
740 gfc_omp_map_op map_op = OMP_MAP_TOFROM;
741 if (gfc_match ("alloc : ") == MATCH_YES)
742 map_op = OMP_MAP_ALLOC;
743 else if (gfc_match ("tofrom : ") == MATCH_YES)
744 map_op = OMP_MAP_TOFROM;
745 else if (gfc_match ("to : ") == MATCH_YES)
746 map_op = OMP_MAP_TO;
747 else if (gfc_match ("from : ") == MATCH_YES)
748 map_op = OMP_MAP_FROM;
749 head = NULL;
750 if (gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_MAP],
751 false, NULL, &head, true)
752 == MATCH_YES)
753 {
754 gfc_omp_namelist *n;
755 for (n = *head; n; n = n->next)
756 n->u.map_op = map_op;
757 continue;
758 }
759 else
760 gfc_current_locus = old_loc;
761 }
762 if ((mask & OMP_CLAUSE_TO)
763 && gfc_match_omp_variable_list ("to (",
764 &c->lists[OMP_LIST_TO], false,
765 NULL, &head, true)
766 == MATCH_YES)
767 continue;
768 if ((mask & OMP_CLAUSE_FROM)
769 && gfc_match_omp_variable_list ("from (",
770 &c->lists[OMP_LIST_FROM], false,
771 NULL, &head, true)
772 == MATCH_YES)
773 continue;
774
775 break;
776 }
777
778 if (gfc_match_omp_eos () != MATCH_YES)
779 {
780 gfc_free_omp_clauses (c);
781 return MATCH_ERROR;
782 }
783
784 *cp = c;
785 return MATCH_YES;
786 }
787
788 #define OMP_PARALLEL_CLAUSES \
789 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \
790 | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IF \
791 | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_PROC_BIND)
792 #define OMP_DECLARE_SIMD_CLAUSES \
793 (OMP_CLAUSE_SIMDLEN | OMP_CLAUSE_LINEAR | OMP_CLAUSE_UNIFORM \
794 | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_INBRANCH | OMP_CLAUSE_NOTINBRANCH)
795 #define OMP_DO_CLAUSES \
796 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
797 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
798 | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE)
799 #define OMP_SECTIONS_CLAUSES \
800 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
801 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
802 #define OMP_SIMD_CLAUSES \
803 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
804 | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_SAFELEN | OMP_CLAUSE_LINEAR \
805 | OMP_CLAUSE_ALIGNED)
806 #define OMP_TASK_CLAUSES \
807 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \
808 | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED \
809 | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE | OMP_CLAUSE_DEPEND)
810 #define OMP_TARGET_CLAUSES \
811 (OMP_CLAUSE_DEVICE | OMP_CLAUSE_MAP | OMP_CLAUSE_IF)
812 #define OMP_TARGET_DATA_CLAUSES \
813 (OMP_CLAUSE_DEVICE | OMP_CLAUSE_MAP | OMP_CLAUSE_IF)
814 #define OMP_TARGET_UPDATE_CLAUSES \
815 (OMP_CLAUSE_DEVICE | OMP_CLAUSE_IF | OMP_CLAUSE_TO | OMP_CLAUSE_FROM)
816 #define OMP_TEAMS_CLAUSES \
817 (OMP_CLAUSE_NUM_TEAMS | OMP_CLAUSE_THREAD_LIMIT | OMP_CLAUSE_DEFAULT \
818 | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \
819 | OMP_CLAUSE_REDUCTION)
820 #define OMP_DISTRIBUTE_CLAUSES \
821 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_COLLAPSE \
822 | OMP_CLAUSE_DIST_SCHEDULE)
823
824
825 static match
826 match_omp (gfc_exec_op op, unsigned int mask)
827 {
828 gfc_omp_clauses *c;
829 if (gfc_match_omp_clauses (&c, mask) != MATCH_YES)
830 return MATCH_ERROR;
831 new_st.op = op;
832 new_st.ext.omp_clauses = c;
833 return MATCH_YES;
834 }
835
836
837 match
838 gfc_match_omp_critical (void)
839 {
840 char n[GFC_MAX_SYMBOL_LEN+1];
841
842 if (gfc_match (" ( %n )", n) != MATCH_YES)
843 n[0] = '\0';
844 if (gfc_match_omp_eos () != MATCH_YES)
845 {
846 gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
847 return MATCH_ERROR;
848 }
849 new_st.op = EXEC_OMP_CRITICAL;
850 new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
851 return MATCH_YES;
852 }
853
854
855 match
856 gfc_match_omp_distribute (void)
857 {
858 return match_omp (EXEC_OMP_DISTRIBUTE, OMP_DISTRIBUTE_CLAUSES);
859 }
860
861
862 match
863 gfc_match_omp_distribute_parallel_do (void)
864 {
865 return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO,
866 OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
867 | OMP_DO_CLAUSES);
868 }
869
870
871 match
872 gfc_match_omp_distribute_parallel_do_simd (void)
873 {
874 return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD,
875 (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
876 | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
877 & ~OMP_CLAUSE_ORDERED);
878 }
879
880
881 match
882 gfc_match_omp_distribute_simd (void)
883 {
884 return match_omp (EXEC_OMP_DISTRIBUTE_SIMD,
885 OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
886 }
887
888
889 match
890 gfc_match_omp_do (void)
891 {
892 return match_omp (EXEC_OMP_DO, OMP_DO_CLAUSES);
893 }
894
895
896 match
897 gfc_match_omp_do_simd (void)
898 {
899 return match_omp (EXEC_OMP_DO_SIMD, ((OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
900 & ~OMP_CLAUSE_ORDERED));
901 }
902
903
904 match
905 gfc_match_omp_flush (void)
906 {
907 gfc_omp_namelist *list = NULL;
908 gfc_match_omp_variable_list (" (", &list, true);
909 if (gfc_match_omp_eos () != MATCH_YES)
910 {
911 gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
912 gfc_free_omp_namelist (list);
913 return MATCH_ERROR;
914 }
915 new_st.op = EXEC_OMP_FLUSH;
916 new_st.ext.omp_namelist = list;
917 return MATCH_YES;
918 }
919
920
921 match
922 gfc_match_omp_declare_simd (void)
923 {
924 locus where = gfc_current_locus;
925 gfc_symbol *proc_name;
926 gfc_omp_clauses *c;
927 gfc_omp_declare_simd *ods;
928
929 if (gfc_match (" ( %s ) ", &proc_name) != MATCH_YES)
930 return MATCH_ERROR;
931
932 if (gfc_match_omp_clauses (&c, OMP_DECLARE_SIMD_CLAUSES, true,
933 false) != MATCH_YES)
934 return MATCH_ERROR;
935
936 ods = gfc_get_omp_declare_simd ();
937 ods->where = where;
938 ods->proc_name = proc_name;
939 ods->clauses = c;
940 ods->next = gfc_current_ns->omp_declare_simd;
941 gfc_current_ns->omp_declare_simd = ods;
942 return MATCH_YES;
943 }
944
945
946 static bool
947 match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2)
948 {
949 match m;
950 locus old_loc = gfc_current_locus;
951 char sname[GFC_MAX_SYMBOL_LEN + 1];
952 gfc_symbol *sym;
953 gfc_namespace *ns = gfc_current_ns;
954 gfc_expr *lvalue = NULL, *rvalue = NULL;
955 gfc_symtree *st;
956 gfc_actual_arglist *arglist;
957
958 m = gfc_match (" %v =", &lvalue);
959 if (m != MATCH_YES)
960 gfc_current_locus = old_loc;
961 else
962 {
963 m = gfc_match (" %e )", &rvalue);
964 if (m == MATCH_YES)
965 {
966 ns->code = gfc_get_code (EXEC_ASSIGN);
967 ns->code->expr1 = lvalue;
968 ns->code->expr2 = rvalue;
969 ns->code->loc = old_loc;
970 return true;
971 }
972
973 gfc_current_locus = old_loc;
974 gfc_free_expr (lvalue);
975 }
976
977 m = gfc_match (" %n", sname);
978 if (m != MATCH_YES)
979 return false;
980
981 if (strcmp (sname, omp_sym1->name) == 0
982 || strcmp (sname, omp_sym2->name) == 0)
983 return false;
984
985 gfc_current_ns = ns->parent;
986 if (gfc_get_ha_sym_tree (sname, &st))
987 return false;
988
989 sym = st->n.sym;
990 if (sym->attr.flavor != FL_PROCEDURE
991 && sym->attr.flavor != FL_UNKNOWN)
992 return false;
993
994 if (!sym->attr.generic
995 && !sym->attr.subroutine
996 && !sym->attr.function)
997 {
998 if (!(sym->attr.external && !sym->attr.referenced))
999 {
1000 /* ...create a symbol in this scope... */
1001 if (sym->ns != gfc_current_ns
1002 && gfc_get_sym_tree (sname, NULL, &st, false) == 1)
1003 return false;
1004
1005 if (sym != st->n.sym)
1006 sym = st->n.sym;
1007 }
1008
1009 /* ...and then to try to make the symbol into a subroutine. */
1010 if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
1011 return false;
1012 }
1013
1014 gfc_set_sym_referenced (sym);
1015 gfc_gobble_whitespace ();
1016 if (gfc_peek_ascii_char () != '(')
1017 return false;
1018
1019 gfc_current_ns = ns;
1020 m = gfc_match_actual_arglist (1, &arglist);
1021 if (m != MATCH_YES)
1022 return false;
1023
1024 if (gfc_match_char (')') != MATCH_YES)
1025 return false;
1026
1027 ns->code = gfc_get_code (EXEC_CALL);
1028 ns->code->symtree = st;
1029 ns->code->ext.actual = arglist;
1030 ns->code->loc = old_loc;
1031 return true;
1032 }
1033
1034 static bool
1035 gfc_omp_udr_predef (gfc_omp_reduction_op rop, const char *name,
1036 gfc_typespec *ts, const char **n)
1037 {
1038 if (!gfc_numeric_ts (ts) && ts->type != BT_LOGICAL)
1039 return false;
1040
1041 switch (rop)
1042 {
1043 case OMP_REDUCTION_PLUS:
1044 case OMP_REDUCTION_MINUS:
1045 case OMP_REDUCTION_TIMES:
1046 return ts->type != BT_LOGICAL;
1047 case OMP_REDUCTION_AND:
1048 case OMP_REDUCTION_OR:
1049 case OMP_REDUCTION_EQV:
1050 case OMP_REDUCTION_NEQV:
1051 return ts->type == BT_LOGICAL;
1052 case OMP_REDUCTION_USER:
1053 if (name[0] != '.' && (ts->type == BT_INTEGER || ts->type == BT_REAL))
1054 {
1055 gfc_symbol *sym;
1056
1057 gfc_find_symbol (name, NULL, 1, &sym);
1058 if (sym != NULL)
1059 {
1060 if (sym->attr.intrinsic)
1061 *n = sym->name;
1062 else if ((sym->attr.flavor != FL_UNKNOWN
1063 && sym->attr.flavor != FL_PROCEDURE)
1064 || sym->attr.external
1065 || sym->attr.generic
1066 || sym->attr.entry
1067 || sym->attr.result
1068 || sym->attr.dummy
1069 || sym->attr.subroutine
1070 || sym->attr.pointer
1071 || sym->attr.target
1072 || sym->attr.cray_pointer
1073 || sym->attr.cray_pointee
1074 || (sym->attr.proc != PROC_UNKNOWN
1075 && sym->attr.proc != PROC_INTRINSIC)
1076 || sym->attr.if_source != IFSRC_UNKNOWN
1077 || sym == sym->ns->proc_name)
1078 *n = NULL;
1079 else
1080 *n = sym->name;
1081 }
1082 else
1083 *n = name;
1084 if (*n
1085 && (strcmp (*n, "max") == 0 || strcmp (*n, "min") == 0))
1086 return true;
1087 else if (*n
1088 && ts->type == BT_INTEGER
1089 && (strcmp (*n, "iand") == 0
1090 || strcmp (*n, "ior") == 0
1091 || strcmp (*n, "ieor") == 0))
1092 return true;
1093 }
1094 break;
1095 default:
1096 break;
1097 }
1098 return false;
1099 }
1100
1101 gfc_omp_udr *
1102 gfc_omp_udr_find (gfc_symtree *st, gfc_typespec *ts)
1103 {
1104 gfc_omp_udr *omp_udr;
1105
1106 if (st == NULL)
1107 return NULL;
1108
1109 for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
1110 if (omp_udr->ts.type == ts->type
1111 || ((omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
1112 && (ts->type == BT_DERIVED && ts->type == BT_CLASS)))
1113 {
1114 if (omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
1115 {
1116 if (strcmp (omp_udr->ts.u.derived->name, ts->u.derived->name) == 0)
1117 return omp_udr;
1118 }
1119 else if (omp_udr->ts.kind == ts->kind)
1120 {
1121 if (omp_udr->ts.type == BT_CHARACTER)
1122 {
1123 if (omp_udr->ts.u.cl->length == NULL
1124 || ts->u.cl->length == NULL)
1125 return omp_udr;
1126 if (omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
1127 return omp_udr;
1128 if (ts->u.cl->length->expr_type != EXPR_CONSTANT)
1129 return omp_udr;
1130 if (omp_udr->ts.u.cl->length->ts.type != BT_INTEGER)
1131 return omp_udr;
1132 if (ts->u.cl->length->ts.type != BT_INTEGER)
1133 return omp_udr;
1134 if (gfc_compare_expr (omp_udr->ts.u.cl->length,
1135 ts->u.cl->length, INTRINSIC_EQ) != 0)
1136 continue;
1137 }
1138 return omp_udr;
1139 }
1140 }
1141 return NULL;
1142 }
1143
1144 match
1145 gfc_match_omp_declare_reduction (void)
1146 {
1147 match m;
1148 gfc_intrinsic_op op;
1149 char name[GFC_MAX_SYMBOL_LEN + 3];
1150 auto_vec<gfc_typespec, 5> tss;
1151 gfc_typespec ts;
1152 unsigned int i;
1153 gfc_symtree *st;
1154 locus where = gfc_current_locus;
1155 locus end_loc = gfc_current_locus;
1156 bool end_loc_set = false;
1157 gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
1158
1159 if (gfc_match_char ('(') != MATCH_YES)
1160 return MATCH_ERROR;
1161
1162 m = gfc_match (" %o : ", &op);
1163 if (m == MATCH_ERROR)
1164 return MATCH_ERROR;
1165 if (m == MATCH_YES)
1166 {
1167 snprintf (name, sizeof name, "operator %s", gfc_op2string (op));
1168 rop = (gfc_omp_reduction_op) op;
1169 }
1170 else
1171 {
1172 m = gfc_match_defined_op_name (name + 1, 1);
1173 if (m == MATCH_ERROR)
1174 return MATCH_ERROR;
1175 if (m == MATCH_YES)
1176 {
1177 name[0] = '.';
1178 strcat (name, ".");
1179 if (gfc_match (" : ") != MATCH_YES)
1180 return MATCH_ERROR;
1181 }
1182 else
1183 {
1184 if (gfc_match (" %n : ", name) != MATCH_YES)
1185 return MATCH_ERROR;
1186 }
1187 rop = OMP_REDUCTION_USER;
1188 }
1189
1190 m = gfc_match_type_spec (&ts);
1191 if (m != MATCH_YES)
1192 return MATCH_ERROR;
1193 /* Treat len=: the same as len=*. */
1194 if (ts.type == BT_CHARACTER)
1195 ts.deferred = false;
1196 tss.safe_push (ts);
1197
1198 while (gfc_match_char (',') == MATCH_YES)
1199 {
1200 m = gfc_match_type_spec (&ts);
1201 if (m != MATCH_YES)
1202 return MATCH_ERROR;
1203 tss.safe_push (ts);
1204 }
1205 if (gfc_match_char (':') != MATCH_YES)
1206 return MATCH_ERROR;
1207
1208 st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
1209 for (i = 0; i < tss.length (); i++)
1210 {
1211 gfc_symtree *omp_out, *omp_in;
1212 gfc_symtree *omp_priv = NULL, *omp_orig = NULL;
1213 gfc_namespace *combiner_ns, *initializer_ns = NULL;
1214 gfc_omp_udr *prev_udr, *omp_udr;
1215 const char *predef_name = NULL;
1216
1217 omp_udr = gfc_get_omp_udr ();
1218 omp_udr->name = gfc_get_string (name);
1219 omp_udr->rop = rop;
1220 omp_udr->ts = tss[i];
1221 omp_udr->where = where;
1222
1223 gfc_current_ns = combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
1224 combiner_ns->proc_name = combiner_ns->parent->proc_name;
1225
1226 gfc_get_sym_tree ("omp_out", combiner_ns, &omp_out, false);
1227 gfc_get_sym_tree ("omp_in", combiner_ns, &omp_in, false);
1228 combiner_ns->omp_udr_ns = 1;
1229 omp_out->n.sym->ts = tss[i];
1230 omp_in->n.sym->ts = tss[i];
1231 omp_out->n.sym->attr.omp_udr_artificial_var = 1;
1232 omp_in->n.sym->attr.omp_udr_artificial_var = 1;
1233 omp_out->n.sym->attr.flavor = FL_VARIABLE;
1234 omp_in->n.sym->attr.flavor = FL_VARIABLE;
1235 gfc_commit_symbols ();
1236 omp_udr->combiner_ns = combiner_ns;
1237 omp_udr->omp_out = omp_out->n.sym;
1238 omp_udr->omp_in = omp_in->n.sym;
1239
1240 locus old_loc = gfc_current_locus;
1241
1242 if (!match_udr_expr (omp_out, omp_in))
1243 {
1244 syntax:
1245 gfc_current_locus = old_loc;
1246 gfc_current_ns = combiner_ns->parent;
1247 gfc_undo_symbols ();
1248 gfc_free_omp_udr (omp_udr);
1249 return MATCH_ERROR;
1250 }
1251
1252 if (gfc_match (" initializer ( ") == MATCH_YES)
1253 {
1254 gfc_current_ns = combiner_ns->parent;
1255 initializer_ns = gfc_get_namespace (gfc_current_ns, 1);
1256 gfc_current_ns = initializer_ns;
1257 initializer_ns->proc_name = initializer_ns->parent->proc_name;
1258
1259 gfc_get_sym_tree ("omp_priv", initializer_ns, &omp_priv, false);
1260 gfc_get_sym_tree ("omp_orig", initializer_ns, &omp_orig, false);
1261 initializer_ns->omp_udr_ns = 1;
1262 omp_priv->n.sym->ts = tss[i];
1263 omp_orig->n.sym->ts = tss[i];
1264 omp_priv->n.sym->attr.omp_udr_artificial_var = 1;
1265 omp_orig->n.sym->attr.omp_udr_artificial_var = 1;
1266 omp_priv->n.sym->attr.flavor = FL_VARIABLE;
1267 omp_orig->n.sym->attr.flavor = FL_VARIABLE;
1268 gfc_commit_symbols ();
1269 omp_udr->initializer_ns = initializer_ns;
1270 omp_udr->omp_priv = omp_priv->n.sym;
1271 omp_udr->omp_orig = omp_orig->n.sym;
1272
1273 if (!match_udr_expr (omp_priv, omp_orig))
1274 goto syntax;
1275 }
1276
1277 gfc_current_ns = combiner_ns->parent;
1278 if (!end_loc_set)
1279 {
1280 end_loc_set = true;
1281 end_loc = gfc_current_locus;
1282 }
1283 gfc_current_locus = old_loc;
1284
1285 prev_udr = gfc_omp_udr_find (st, &tss[i]);
1286 if (gfc_omp_udr_predef (rop, name, &tss[i], &predef_name)
1287 /* Don't error on !$omp declare reduction (min : integer : ...)
1288 just yet, there could be integer :: min afterwards,
1289 making it valid. When the UDR is resolved, we'll get
1290 to it again. */
1291 && (rop != OMP_REDUCTION_USER || name[0] == '.'))
1292 {
1293 if (predef_name)
1294 gfc_error_now ("Redefinition of predefined %s "
1295 "!$OMP DECLARE REDUCTION at %L",
1296 predef_name, &where);
1297 else
1298 gfc_error_now ("Redefinition of predefined "
1299 "!$OMP DECLARE REDUCTION at %L", &where);
1300 }
1301 else if (prev_udr)
1302 {
1303 gfc_error_now ("Redefinition of !$OMP DECLARE REDUCTION at %L",
1304 &where);
1305 gfc_error_now ("Previous !$OMP DECLARE REDUCTION at %L",
1306 &prev_udr->where);
1307 }
1308 else if (st)
1309 {
1310 omp_udr->next = st->n.omp_udr;
1311 st->n.omp_udr = omp_udr;
1312 }
1313 else
1314 {
1315 st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name);
1316 st->n.omp_udr = omp_udr;
1317 }
1318 }
1319
1320 if (end_loc_set)
1321 {
1322 gfc_current_locus = end_loc;
1323 if (gfc_match_omp_eos () != MATCH_YES)
1324 {
1325 gfc_error ("Unexpected junk after !$OMP DECLARE REDUCTION at %C");
1326 gfc_current_locus = where;
1327 return MATCH_ERROR;
1328 }
1329
1330 return MATCH_YES;
1331 }
1332 gfc_clear_error ();
1333 return MATCH_ERROR;
1334 }
1335
1336
1337 match
1338 gfc_match_omp_declare_target (void)
1339 {
1340 locus old_loc;
1341 char n[GFC_MAX_SYMBOL_LEN+1];
1342 gfc_symbol *sym;
1343 match m;
1344 gfc_symtree *st;
1345
1346 old_loc = gfc_current_locus;
1347
1348 m = gfc_match (" (");
1349
1350 if (gfc_current_ns->proc_name
1351 && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
1352 && m == MATCH_YES)
1353 {
1354 gfc_error ("Only the !$OMP DECLARE TARGET form without "
1355 "list is allowed in interface block at %C");
1356 goto cleanup;
1357 }
1358
1359 if (m == MATCH_NO
1360 && gfc_current_ns->proc_name
1361 && gfc_match_omp_eos () == MATCH_YES)
1362 {
1363 if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
1364 gfc_current_ns->proc_name->name,
1365 &old_loc))
1366 goto cleanup;
1367 return MATCH_YES;
1368 }
1369
1370 if (m != MATCH_YES)
1371 return m;
1372
1373 for (;;)
1374 {
1375 m = gfc_match_symbol (&sym, 0);
1376 switch (m)
1377 {
1378 case MATCH_YES:
1379 if (sym->attr.in_common)
1380 gfc_error_now ("OMP DECLARE TARGET on a variable at %C is an "
1381 "element of a COMMON block");
1382 else if (!gfc_add_omp_declare_target (&sym->attr, sym->name,
1383 &sym->declared_at))
1384 goto cleanup;
1385 goto next_item;
1386 case MATCH_NO:
1387 break;
1388 case MATCH_ERROR:
1389 goto cleanup;
1390 }
1391
1392 m = gfc_match (" / %n /", n);
1393 if (m == MATCH_ERROR)
1394 goto cleanup;
1395 if (m == MATCH_NO || n[0] == '\0')
1396 goto syntax;
1397
1398 st = gfc_find_symtree (gfc_current_ns->common_root, n);
1399 if (st == NULL)
1400 {
1401 gfc_error ("COMMON block /%s/ not found at %C", n);
1402 goto cleanup;
1403 }
1404 st->n.common->omp_declare_target = 1;
1405 for (sym = st->n.common->head; sym; sym = sym->common_next)
1406 if (!gfc_add_omp_declare_target (&sym->attr, sym->name,
1407 &sym->declared_at))
1408 goto cleanup;
1409
1410 next_item:
1411 if (gfc_match_char (')') == MATCH_YES)
1412 break;
1413 if (gfc_match_char (',') != MATCH_YES)
1414 goto syntax;
1415 }
1416
1417 if (gfc_match_omp_eos () != MATCH_YES)
1418 {
1419 gfc_error ("Unexpected junk after !$OMP DECLARE TARGET at %C");
1420 goto cleanup;
1421 }
1422 return MATCH_YES;
1423
1424 syntax:
1425 gfc_error ("Syntax error in !$OMP DECLARE TARGET list at %C");
1426
1427 cleanup:
1428 gfc_current_locus = old_loc;
1429 return MATCH_ERROR;
1430 }
1431
1432
1433 match
1434 gfc_match_omp_threadprivate (void)
1435 {
1436 locus old_loc;
1437 char n[GFC_MAX_SYMBOL_LEN+1];
1438 gfc_symbol *sym;
1439 match m;
1440 gfc_symtree *st;
1441
1442 old_loc = gfc_current_locus;
1443
1444 m = gfc_match (" (");
1445 if (m != MATCH_YES)
1446 return m;
1447
1448 for (;;)
1449 {
1450 m = gfc_match_symbol (&sym, 0);
1451 switch (m)
1452 {
1453 case MATCH_YES:
1454 if (sym->attr.in_common)
1455 gfc_error_now ("Threadprivate variable at %C is an element of "
1456 "a COMMON block");
1457 else if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at))
1458 goto cleanup;
1459 goto next_item;
1460 case MATCH_NO:
1461 break;
1462 case MATCH_ERROR:
1463 goto cleanup;
1464 }
1465
1466 m = gfc_match (" / %n /", n);
1467 if (m == MATCH_ERROR)
1468 goto cleanup;
1469 if (m == MATCH_NO || n[0] == '\0')
1470 goto syntax;
1471
1472 st = gfc_find_symtree (gfc_current_ns->common_root, n);
1473 if (st == NULL)
1474 {
1475 gfc_error ("COMMON block /%s/ not found at %C", n);
1476 goto cleanup;
1477 }
1478 st->n.common->threadprivate = 1;
1479 for (sym = st->n.common->head; sym; sym = sym->common_next)
1480 if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at))
1481 goto cleanup;
1482
1483 next_item:
1484 if (gfc_match_char (')') == MATCH_YES)
1485 break;
1486 if (gfc_match_char (',') != MATCH_YES)
1487 goto syntax;
1488 }
1489
1490 if (gfc_match_omp_eos () != MATCH_YES)
1491 {
1492 gfc_error ("Unexpected junk after OMP THREADPRIVATE at %C");
1493 goto cleanup;
1494 }
1495
1496 return MATCH_YES;
1497
1498 syntax:
1499 gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C");
1500
1501 cleanup:
1502 gfc_current_locus = old_loc;
1503 return MATCH_ERROR;
1504 }
1505
1506
1507 match
1508 gfc_match_omp_parallel (void)
1509 {
1510 return match_omp (EXEC_OMP_PARALLEL, OMP_PARALLEL_CLAUSES);
1511 }
1512
1513
1514 match
1515 gfc_match_omp_parallel_do (void)
1516 {
1517 return match_omp (EXEC_OMP_PARALLEL_DO,
1518 OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES);
1519 }
1520
1521
1522 match
1523 gfc_match_omp_parallel_do_simd (void)
1524 {
1525 return match_omp (EXEC_OMP_PARALLEL_DO_SIMD,
1526 (OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
1527 & ~OMP_CLAUSE_ORDERED);
1528 }
1529
1530
1531 match
1532 gfc_match_omp_parallel_sections (void)
1533 {
1534 return match_omp (EXEC_OMP_PARALLEL_SECTIONS,
1535 OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES);
1536 }
1537
1538
1539 match
1540 gfc_match_omp_parallel_workshare (void)
1541 {
1542 return match_omp (EXEC_OMP_PARALLEL_WORKSHARE, OMP_PARALLEL_CLAUSES);
1543 }
1544
1545
1546 match
1547 gfc_match_omp_sections (void)
1548 {
1549 return match_omp (EXEC_OMP_SECTIONS, OMP_SECTIONS_CLAUSES);
1550 }
1551
1552
1553 match
1554 gfc_match_omp_simd (void)
1555 {
1556 return match_omp (EXEC_OMP_SIMD, OMP_SIMD_CLAUSES);
1557 }
1558
1559
1560 match
1561 gfc_match_omp_single (void)
1562 {
1563 return match_omp (EXEC_OMP_SINGLE,
1564 OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE);
1565 }
1566
1567
1568 match
1569 gfc_match_omp_task (void)
1570 {
1571 return match_omp (EXEC_OMP_TASK, OMP_TASK_CLAUSES);
1572 }
1573
1574
1575 match
1576 gfc_match_omp_taskwait (void)
1577 {
1578 if (gfc_match_omp_eos () != MATCH_YES)
1579 {
1580 gfc_error ("Unexpected junk after TASKWAIT clause at %C");
1581 return MATCH_ERROR;
1582 }
1583 new_st.op = EXEC_OMP_TASKWAIT;
1584 new_st.ext.omp_clauses = NULL;
1585 return MATCH_YES;
1586 }
1587
1588
1589 match
1590 gfc_match_omp_taskyield (void)
1591 {
1592 if (gfc_match_omp_eos () != MATCH_YES)
1593 {
1594 gfc_error ("Unexpected junk after TASKYIELD clause at %C");
1595 return MATCH_ERROR;
1596 }
1597 new_st.op = EXEC_OMP_TASKYIELD;
1598 new_st.ext.omp_clauses = NULL;
1599 return MATCH_YES;
1600 }
1601
1602
1603 match
1604 gfc_match_omp_target (void)
1605 {
1606 return match_omp (EXEC_OMP_TARGET, OMP_TARGET_CLAUSES);
1607 }
1608
1609
1610 match
1611 gfc_match_omp_target_data (void)
1612 {
1613 return match_omp (EXEC_OMP_TARGET_DATA, OMP_TARGET_DATA_CLAUSES);
1614 }
1615
1616
1617 match
1618 gfc_match_omp_target_teams (void)
1619 {
1620 return match_omp (EXEC_OMP_TARGET_TEAMS,
1621 OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES);
1622 }
1623
1624
1625 match
1626 gfc_match_omp_target_teams_distribute (void)
1627 {
1628 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE,
1629 OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
1630 | OMP_DISTRIBUTE_CLAUSES);
1631 }
1632
1633
1634 match
1635 gfc_match_omp_target_teams_distribute_parallel_do (void)
1636 {
1637 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO,
1638 OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
1639 | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
1640 | OMP_DO_CLAUSES);
1641 }
1642
1643
1644 match
1645 gfc_match_omp_target_teams_distribute_parallel_do_simd (void)
1646 {
1647 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
1648 (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
1649 | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
1650 | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
1651 & ~OMP_CLAUSE_ORDERED);
1652 }
1653
1654
1655 match
1656 gfc_match_omp_target_teams_distribute_simd (void)
1657 {
1658 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD,
1659 OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
1660 | OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
1661 }
1662
1663
1664 match
1665 gfc_match_omp_target_update (void)
1666 {
1667 return match_omp (EXEC_OMP_TARGET_UPDATE, OMP_TARGET_UPDATE_CLAUSES);
1668 }
1669
1670
1671 match
1672 gfc_match_omp_teams (void)
1673 {
1674 return match_omp (EXEC_OMP_TEAMS, OMP_TEAMS_CLAUSES);
1675 }
1676
1677
1678 match
1679 gfc_match_omp_teams_distribute (void)
1680 {
1681 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE,
1682 OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES);
1683 }
1684
1685
1686 match
1687 gfc_match_omp_teams_distribute_parallel_do (void)
1688 {
1689 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO,
1690 OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
1691 | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES);
1692 }
1693
1694
1695 match
1696 gfc_match_omp_teams_distribute_parallel_do_simd (void)
1697 {
1698 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
1699 (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
1700 | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
1701 | OMP_SIMD_CLAUSES) & ~OMP_CLAUSE_ORDERED);
1702 }
1703
1704
1705 match
1706 gfc_match_omp_teams_distribute_simd (void)
1707 {
1708 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_SIMD,
1709 OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
1710 | OMP_SIMD_CLAUSES);
1711 }
1712
1713
1714 match
1715 gfc_match_omp_workshare (void)
1716 {
1717 if (gfc_match_omp_eos () != MATCH_YES)
1718 {
1719 gfc_error ("Unexpected junk after $OMP WORKSHARE statement at %C");
1720 return MATCH_ERROR;
1721 }
1722 new_st.op = EXEC_OMP_WORKSHARE;
1723 new_st.ext.omp_clauses = gfc_get_omp_clauses ();
1724 return MATCH_YES;
1725 }
1726
1727
1728 match
1729 gfc_match_omp_master (void)
1730 {
1731 if (gfc_match_omp_eos () != MATCH_YES)
1732 {
1733 gfc_error ("Unexpected junk after $OMP MASTER statement at %C");
1734 return MATCH_ERROR;
1735 }
1736 new_st.op = EXEC_OMP_MASTER;
1737 new_st.ext.omp_clauses = NULL;
1738 return MATCH_YES;
1739 }
1740
1741
1742 match
1743 gfc_match_omp_ordered (void)
1744 {
1745 if (gfc_match_omp_eos () != MATCH_YES)
1746 {
1747 gfc_error ("Unexpected junk after $OMP ORDERED statement at %C");
1748 return MATCH_ERROR;
1749 }
1750 new_st.op = EXEC_OMP_ORDERED;
1751 new_st.ext.omp_clauses = NULL;
1752 return MATCH_YES;
1753 }
1754
1755
1756 match
1757 gfc_match_omp_atomic (void)
1758 {
1759 gfc_omp_atomic_op op = GFC_OMP_ATOMIC_UPDATE;
1760 int seq_cst = 0;
1761 if (gfc_match ("% seq_cst") == MATCH_YES)
1762 seq_cst = 1;
1763 locus old_loc = gfc_current_locus;
1764 if (seq_cst && gfc_match_char (',') == MATCH_YES)
1765 seq_cst = 2;
1766 if (seq_cst == 2
1767 || gfc_match_space () == MATCH_YES)
1768 {
1769 gfc_gobble_whitespace ();
1770 if (gfc_match ("update") == MATCH_YES)
1771 op = GFC_OMP_ATOMIC_UPDATE;
1772 else if (gfc_match ("read") == MATCH_YES)
1773 op = GFC_OMP_ATOMIC_READ;
1774 else if (gfc_match ("write") == MATCH_YES)
1775 op = GFC_OMP_ATOMIC_WRITE;
1776 else if (gfc_match ("capture") == MATCH_YES)
1777 op = GFC_OMP_ATOMIC_CAPTURE;
1778 else
1779 {
1780 if (seq_cst == 2)
1781 gfc_current_locus = old_loc;
1782 goto finish;
1783 }
1784 if (!seq_cst
1785 && (gfc_match (", seq_cst") == MATCH_YES
1786 || gfc_match ("% seq_cst") == MATCH_YES))
1787 seq_cst = 1;
1788 }
1789 finish:
1790 if (gfc_match_omp_eos () != MATCH_YES)
1791 {
1792 gfc_error ("Unexpected junk after $OMP ATOMIC statement at %C");
1793 return MATCH_ERROR;
1794 }
1795 new_st.op = EXEC_OMP_ATOMIC;
1796 if (seq_cst)
1797 op = (gfc_omp_atomic_op) (op | GFC_OMP_ATOMIC_SEQ_CST);
1798 new_st.ext.omp_atomic = op;
1799 return MATCH_YES;
1800 }
1801
1802
1803 match
1804 gfc_match_omp_barrier (void)
1805 {
1806 if (gfc_match_omp_eos () != MATCH_YES)
1807 {
1808 gfc_error ("Unexpected junk after $OMP BARRIER statement at %C");
1809 return MATCH_ERROR;
1810 }
1811 new_st.op = EXEC_OMP_BARRIER;
1812 new_st.ext.omp_clauses = NULL;
1813 return MATCH_YES;
1814 }
1815
1816
1817 match
1818 gfc_match_omp_taskgroup (void)
1819 {
1820 if (gfc_match_omp_eos () != MATCH_YES)
1821 {
1822 gfc_error ("Unexpected junk after $OMP TASKGROUP statement at %C");
1823 return MATCH_ERROR;
1824 }
1825 new_st.op = EXEC_OMP_TASKGROUP;
1826 return MATCH_YES;
1827 }
1828
1829
1830 static enum gfc_omp_cancel_kind
1831 gfc_match_omp_cancel_kind (void)
1832 {
1833 if (gfc_match_space () != MATCH_YES)
1834 return OMP_CANCEL_UNKNOWN;
1835 if (gfc_match ("parallel") == MATCH_YES)
1836 return OMP_CANCEL_PARALLEL;
1837 if (gfc_match ("sections") == MATCH_YES)
1838 return OMP_CANCEL_SECTIONS;
1839 if (gfc_match ("do") == MATCH_YES)
1840 return OMP_CANCEL_DO;
1841 if (gfc_match ("taskgroup") == MATCH_YES)
1842 return OMP_CANCEL_TASKGROUP;
1843 return OMP_CANCEL_UNKNOWN;
1844 }
1845
1846
1847 match
1848 gfc_match_omp_cancel (void)
1849 {
1850 gfc_omp_clauses *c;
1851 enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
1852 if (kind == OMP_CANCEL_UNKNOWN)
1853 return MATCH_ERROR;
1854 if (gfc_match_omp_clauses (&c, OMP_CLAUSE_IF, false) != MATCH_YES)
1855 return MATCH_ERROR;
1856 c->cancel = kind;
1857 new_st.op = EXEC_OMP_CANCEL;
1858 new_st.ext.omp_clauses = c;
1859 return MATCH_YES;
1860 }
1861
1862
1863 match
1864 gfc_match_omp_cancellation_point (void)
1865 {
1866 gfc_omp_clauses *c;
1867 enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
1868 if (kind == OMP_CANCEL_UNKNOWN)
1869 return MATCH_ERROR;
1870 if (gfc_match_omp_eos () != MATCH_YES)
1871 {
1872 gfc_error ("Unexpected junk after $OMP CANCELLATION POINT statement "
1873 "at %C");
1874 return MATCH_ERROR;
1875 }
1876 c = gfc_get_omp_clauses ();
1877 c->cancel = kind;
1878 new_st.op = EXEC_OMP_CANCELLATION_POINT;
1879 new_st.ext.omp_clauses = c;
1880 return MATCH_YES;
1881 }
1882
1883
1884 match
1885 gfc_match_omp_end_nowait (void)
1886 {
1887 bool nowait = false;
1888 if (gfc_match ("% nowait") == MATCH_YES)
1889 nowait = true;
1890 if (gfc_match_omp_eos () != MATCH_YES)
1891 {
1892 gfc_error ("Unexpected junk after NOWAIT clause at %C");
1893 return MATCH_ERROR;
1894 }
1895 new_st.op = EXEC_OMP_END_NOWAIT;
1896 new_st.ext.omp_bool = nowait;
1897 return MATCH_YES;
1898 }
1899
1900
1901 match
1902 gfc_match_omp_end_single (void)
1903 {
1904 gfc_omp_clauses *c;
1905 if (gfc_match ("% nowait") == MATCH_YES)
1906 {
1907 new_st.op = EXEC_OMP_END_NOWAIT;
1908 new_st.ext.omp_bool = true;
1909 return MATCH_YES;
1910 }
1911 if (gfc_match_omp_clauses (&c, OMP_CLAUSE_COPYPRIVATE) != MATCH_YES)
1912 return MATCH_ERROR;
1913 new_st.op = EXEC_OMP_END_SINGLE;
1914 new_st.ext.omp_clauses = c;
1915 return MATCH_YES;
1916 }
1917
1918
1919 struct resolve_omp_udr_callback_data
1920 {
1921 gfc_symbol *sym1, *sym2;
1922 };
1923
1924
1925 static int
1926 resolve_omp_udr_callback (gfc_expr **e, int *, void *data)
1927 {
1928 struct resolve_omp_udr_callback_data *rcd
1929 = (struct resolve_omp_udr_callback_data *) data;
1930 if ((*e)->expr_type == EXPR_VARIABLE
1931 && ((*e)->symtree->n.sym == rcd->sym1
1932 || (*e)->symtree->n.sym == rcd->sym2))
1933 {
1934 gfc_ref *ref = gfc_get_ref ();
1935 ref->type = REF_ARRAY;
1936 ref->u.ar.where = (*e)->where;
1937 ref->u.ar.as = (*e)->symtree->n.sym->as;
1938 ref->u.ar.type = AR_FULL;
1939 ref->u.ar.dimen = 0;
1940 ref->next = (*e)->ref;
1941 (*e)->ref = ref;
1942 }
1943 return 0;
1944 }
1945
1946
1947 static int
1948 resolve_omp_udr_callback2 (gfc_expr **e, int *, void *)
1949 {
1950 if ((*e)->expr_type == EXPR_FUNCTION
1951 && (*e)->value.function.isym == NULL)
1952 {
1953 gfc_symbol *sym = (*e)->symtree->n.sym;
1954 if (!sym->attr.intrinsic
1955 && sym->attr.if_source == IFSRC_UNKNOWN)
1956 gfc_error ("Implicitly declared function %s used in "
1957 "!$OMP DECLARE REDUCTION at %L ", sym->name, &(*e)->where);
1958 }
1959 return 0;
1960 }
1961
1962
1963 static gfc_code *
1964 resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns,
1965 gfc_symbol *sym1, gfc_symbol *sym2)
1966 {
1967 gfc_code *copy;
1968 gfc_symbol sym1_copy, sym2_copy;
1969
1970 if (ns->code->op == EXEC_ASSIGN)
1971 {
1972 copy = gfc_get_code (EXEC_ASSIGN);
1973 copy->expr1 = gfc_copy_expr (ns->code->expr1);
1974 copy->expr2 = gfc_copy_expr (ns->code->expr2);
1975 }
1976 else
1977 {
1978 copy = gfc_get_code (EXEC_CALL);
1979 copy->symtree = ns->code->symtree;
1980 copy->ext.actual = gfc_copy_actual_arglist (ns->code->ext.actual);
1981 }
1982 copy->loc = ns->code->loc;
1983 sym1_copy = *sym1;
1984 sym2_copy = *sym2;
1985 *sym1 = *n->sym;
1986 *sym2 = *n->sym;
1987 sym1->name = sym1_copy.name;
1988 sym2->name = sym2_copy.name;
1989 ns->proc_name = ns->parent->proc_name;
1990 if (n->sym->attr.dimension)
1991 {
1992 struct resolve_omp_udr_callback_data rcd;
1993 rcd.sym1 = sym1;
1994 rcd.sym2 = sym2;
1995 gfc_code_walker (&copy, gfc_dummy_code_callback,
1996 resolve_omp_udr_callback, &rcd);
1997 }
1998 gfc_resolve_code (copy, gfc_current_ns);
1999 if (copy->op == EXEC_CALL && copy->resolved_isym == NULL)
2000 {
2001 gfc_symbol *sym = copy->resolved_sym;
2002 if (sym
2003 && !sym->attr.intrinsic
2004 && sym->attr.if_source == IFSRC_UNKNOWN)
2005 gfc_error ("Implicitly declared subroutine %s used in "
2006 "!$OMP DECLARE REDUCTION at %L ", sym->name,
2007 &copy->loc);
2008 }
2009 gfc_code_walker (&copy, gfc_dummy_code_callback,
2010 resolve_omp_udr_callback2, NULL);
2011 *sym1 = sym1_copy;
2012 *sym2 = sym2_copy;
2013 return copy;
2014 }
2015
2016
2017 /* OpenMP directive resolving routines. */
2018
2019 static void
2020 resolve_omp_clauses (gfc_code *code, locus *where,
2021 gfc_omp_clauses *omp_clauses, gfc_namespace *ns)
2022 {
2023 gfc_omp_namelist *n;
2024 int list;
2025 static const char *clause_names[]
2026 = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
2027 "COPYIN", "UNIFORM", "ALIGNED", "LINEAR", "DEPEND", "MAP",
2028 "TO", "FROM", "REDUCTION" };
2029
2030 if (omp_clauses == NULL)
2031 return;
2032
2033 if (omp_clauses->if_expr)
2034 {
2035 gfc_expr *expr = omp_clauses->if_expr;
2036 if (!gfc_resolve_expr (expr)
2037 || expr->ts.type != BT_LOGICAL || expr->rank != 0)
2038 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
2039 &expr->where);
2040 }
2041 if (omp_clauses->final_expr)
2042 {
2043 gfc_expr *expr = omp_clauses->final_expr;
2044 if (!gfc_resolve_expr (expr)
2045 || expr->ts.type != BT_LOGICAL || expr->rank != 0)
2046 gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression",
2047 &expr->where);
2048 }
2049 if (omp_clauses->num_threads)
2050 {
2051 gfc_expr *expr = omp_clauses->num_threads;
2052 if (!gfc_resolve_expr (expr)
2053 || expr->ts.type != BT_INTEGER || expr->rank != 0)
2054 gfc_error ("NUM_THREADS clause at %L requires a scalar "
2055 "INTEGER expression", &expr->where);
2056 }
2057 if (omp_clauses->chunk_size)
2058 {
2059 gfc_expr *expr = omp_clauses->chunk_size;
2060 if (!gfc_resolve_expr (expr)
2061 || expr->ts.type != BT_INTEGER || expr->rank != 0)
2062 gfc_error ("SCHEDULE clause's chunk_size at %L requires "
2063 "a scalar INTEGER expression", &expr->where);
2064 }
2065
2066 /* Check that no symbol appears on multiple clauses, except that
2067 a symbol can appear on both firstprivate and lastprivate. */
2068 for (list = 0; list < OMP_LIST_NUM; list++)
2069 for (n = omp_clauses->lists[list]; n; n = n->next)
2070 {
2071 n->sym->mark = 0;
2072 if (n->sym->attr.flavor == FL_VARIABLE
2073 || n->sym->attr.proc_pointer
2074 || (!code && (!n->sym->attr.dummy || n->sym->ns != ns)))
2075 {
2076 if (!code && (!n->sym->attr.dummy || n->sym->ns != ns))
2077 gfc_error ("Variable '%s' is not a dummy argument at %L",
2078 n->sym->name, where);
2079 continue;
2080 }
2081 if (n->sym->attr.flavor == FL_PROCEDURE
2082 && n->sym->result == n->sym
2083 && n->sym->attr.function)
2084 {
2085 if (gfc_current_ns->proc_name == n->sym
2086 || (gfc_current_ns->parent
2087 && gfc_current_ns->parent->proc_name == n->sym))
2088 continue;
2089 if (gfc_current_ns->proc_name->attr.entry_master)
2090 {
2091 gfc_entry_list *el = gfc_current_ns->entries;
2092 for (; el; el = el->next)
2093 if (el->sym == n->sym)
2094 break;
2095 if (el)
2096 continue;
2097 }
2098 if (gfc_current_ns->parent
2099 && gfc_current_ns->parent->proc_name->attr.entry_master)
2100 {
2101 gfc_entry_list *el = gfc_current_ns->parent->entries;
2102 for (; el; el = el->next)
2103 if (el->sym == n->sym)
2104 break;
2105 if (el)
2106 continue;
2107 }
2108 }
2109 gfc_error ("Object '%s' is not a variable at %L", n->sym->name,
2110 where);
2111 }
2112
2113 for (list = 0; list < OMP_LIST_NUM; list++)
2114 if (list != OMP_LIST_FIRSTPRIVATE
2115 && list != OMP_LIST_LASTPRIVATE
2116 && list != OMP_LIST_ALIGNED
2117 && list != OMP_LIST_DEPEND
2118 && list != OMP_LIST_MAP
2119 && list != OMP_LIST_FROM
2120 && list != OMP_LIST_TO)
2121 for (n = omp_clauses->lists[list]; n; n = n->next)
2122 {
2123 if (n->sym->mark)
2124 gfc_error ("Symbol '%s' present on multiple clauses at %L",
2125 n->sym->name, where);
2126 else
2127 n->sym->mark = 1;
2128 }
2129
2130 gcc_assert (OMP_LIST_LASTPRIVATE == OMP_LIST_FIRSTPRIVATE + 1);
2131 for (list = OMP_LIST_FIRSTPRIVATE; list <= OMP_LIST_LASTPRIVATE; list++)
2132 for (n = omp_clauses->lists[list]; n; n = n->next)
2133 if (n->sym->mark)
2134 {
2135 gfc_error ("Symbol '%s' present on multiple clauses at %L",
2136 n->sym->name, where);
2137 n->sym->mark = 0;
2138 }
2139
2140 for (n = omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; n; n = n->next)
2141 {
2142 if (n->sym->mark)
2143 gfc_error ("Symbol '%s' present on multiple clauses at %L",
2144 n->sym->name, where);
2145 else
2146 n->sym->mark = 1;
2147 }
2148 for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
2149 n->sym->mark = 0;
2150
2151 for (n = omp_clauses->lists[OMP_LIST_LASTPRIVATE]; n; n = n->next)
2152 {
2153 if (n->sym->mark)
2154 gfc_error ("Symbol '%s' present on multiple clauses at %L",
2155 n->sym->name, where);
2156 else
2157 n->sym->mark = 1;
2158 }
2159
2160 for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
2161 n->sym->mark = 0;
2162
2163 for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
2164 {
2165 if (n->sym->mark)
2166 gfc_error ("Symbol '%s' present on multiple clauses at %L",
2167 n->sym->name, where);
2168 else
2169 n->sym->mark = 1;
2170 }
2171
2172 for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
2173 n->sym->mark = 0;
2174 for (n = omp_clauses->lists[OMP_LIST_FROM]; n; n = n->next)
2175 if (n->expr == NULL)
2176 n->sym->mark = 1;
2177 for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
2178 {
2179 if (n->expr == NULL && n->sym->mark)
2180 gfc_error ("Symbol '%s' present on both FROM and TO clauses at %L",
2181 n->sym->name, where);
2182 else
2183 n->sym->mark = 1;
2184 }
2185
2186 for (list = 0; list < OMP_LIST_NUM; list++)
2187 if ((n = omp_clauses->lists[list]) != NULL)
2188 {
2189 const char *name;
2190
2191 if (list < OMP_LIST_NUM)
2192 name = clause_names[list];
2193 else
2194 gcc_unreachable ();
2195
2196 switch (list)
2197 {
2198 case OMP_LIST_COPYIN:
2199 for (; n != NULL; n = n->next)
2200 {
2201 if (!n->sym->attr.threadprivate)
2202 gfc_error ("Non-THREADPRIVATE object '%s' in COPYIN clause"
2203 " at %L", n->sym->name, where);
2204 }
2205 break;
2206 case OMP_LIST_COPYPRIVATE:
2207 for (; n != NULL; n = n->next)
2208 {
2209 if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
2210 gfc_error ("Assumed size array '%s' in COPYPRIVATE clause "
2211 "at %L", n->sym->name, where);
2212 if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
2213 gfc_error ("INTENT(IN) POINTER '%s' in COPYPRIVATE clause "
2214 "at %L", n->sym->name, where);
2215 }
2216 break;
2217 case OMP_LIST_SHARED:
2218 for (; n != NULL; n = n->next)
2219 {
2220 if (n->sym->attr.threadprivate)
2221 gfc_error ("THREADPRIVATE object '%s' in SHARED clause at "
2222 "%L", n->sym->name, where);
2223 if (n->sym->attr.cray_pointee)
2224 gfc_error ("Cray pointee '%s' in SHARED clause at %L",
2225 n->sym->name, where);
2226 if (n->sym->attr.associate_var)
2227 gfc_error ("ASSOCIATE name '%s' in SHARED clause at %L",
2228 n->sym->name, where);
2229 }
2230 break;
2231 case OMP_LIST_ALIGNED:
2232 for (; n != NULL; n = n->next)
2233 {
2234 if (!n->sym->attr.pointer
2235 && !n->sym->attr.allocatable
2236 && !n->sym->attr.cray_pointer
2237 && (n->sym->ts.type != BT_DERIVED
2238 || (n->sym->ts.u.derived->from_intmod
2239 != INTMOD_ISO_C_BINDING)
2240 || (n->sym->ts.u.derived->intmod_sym_id
2241 != ISOCBINDING_PTR)))
2242 gfc_error ("'%s' in ALIGNED clause must be POINTER, "
2243 "ALLOCATABLE, Cray pointer or C_PTR at %L",
2244 n->sym->name, where);
2245 else if (n->expr)
2246 {
2247 gfc_expr *expr = n->expr;
2248 int alignment = 0;
2249 if (!gfc_resolve_expr (expr)
2250 || expr->ts.type != BT_INTEGER
2251 || expr->rank != 0
2252 || gfc_extract_int (expr, &alignment)
2253 || alignment <= 0)
2254 gfc_error ("'%s' in ALIGNED clause at %L requires a scalar "
2255 "positive constant integer alignment "
2256 "expression", n->sym->name, where);
2257 }
2258 }
2259 break;
2260 case OMP_LIST_DEPEND:
2261 case OMP_LIST_MAP:
2262 case OMP_LIST_TO:
2263 case OMP_LIST_FROM:
2264 for (; n != NULL; n = n->next)
2265 if (n->expr)
2266 {
2267 if (!gfc_resolve_expr (n->expr)
2268 || n->expr->expr_type != EXPR_VARIABLE
2269 || n->expr->ref == NULL
2270 || n->expr->ref->next
2271 || n->expr->ref->type != REF_ARRAY)
2272 gfc_error ("'%s' in %s clause at %L is not a proper "
2273 "array section", n->sym->name, name, where);
2274 else if (n->expr->ref->u.ar.codimen)
2275 gfc_error ("Coarrays not supported in %s clause at %L",
2276 name, where);
2277 else
2278 {
2279 int i;
2280 gfc_array_ref *ar = &n->expr->ref->u.ar;
2281 for (i = 0; i < ar->dimen; i++)
2282 if (ar->stride[i])
2283 {
2284 gfc_error ("Stride should not be specified for "
2285 "array section in %s clause at %L",
2286 name, where);
2287 break;
2288 }
2289 else if (ar->dimen_type[i] != DIMEN_ELEMENT
2290 && ar->dimen_type[i] != DIMEN_RANGE)
2291 {
2292 gfc_error ("'%s' in %s clause at %L is not a "
2293 "proper array section",
2294 n->sym->name, name, where);
2295 break;
2296 }
2297 else if (list == OMP_LIST_DEPEND
2298 && ar->start[i]
2299 && ar->start[i]->expr_type == EXPR_CONSTANT
2300 && ar->end[i]
2301 && ar->end[i]->expr_type == EXPR_CONSTANT
2302 && mpz_cmp (ar->start[i]->value.integer,
2303 ar->end[i]->value.integer) > 0)
2304 {
2305 gfc_error ("'%s' in DEPEND clause at %L is a zero "
2306 "size array section", n->sym->name,
2307 where);
2308 break;
2309 }
2310 }
2311 }
2312 if (list != OMP_LIST_DEPEND)
2313 for (n = omp_clauses->lists[list]; n != NULL; n = n->next)
2314 {
2315 n->sym->attr.referenced = 1;
2316 if (n->sym->attr.threadprivate)
2317 gfc_error ("THREADPRIVATE object '%s' in %s clause at %L",
2318 n->sym->name, name, where);
2319 if (n->sym->attr.cray_pointee)
2320 gfc_error ("Cray pointee '%s' in %s clause at %L",
2321 n->sym->name, name, where);
2322 }
2323 break;
2324 default:
2325 for (; n != NULL; n = n->next)
2326 {
2327 bool bad = false;
2328 if (n->sym->attr.threadprivate)
2329 gfc_error ("THREADPRIVATE object '%s' in %s clause at %L",
2330 n->sym->name, name, where);
2331 if (n->sym->attr.cray_pointee)
2332 gfc_error ("Cray pointee '%s' in %s clause at %L",
2333 n->sym->name, name, where);
2334 if (n->sym->attr.associate_var)
2335 gfc_error ("ASSOCIATE name '%s' in %s clause at %L",
2336 n->sym->name, name, where);
2337 if (list != OMP_LIST_PRIVATE)
2338 {
2339 if (n->sym->attr.proc_pointer && list == OMP_LIST_REDUCTION)
2340 gfc_error ("Procedure pointer '%s' in %s clause at %L",
2341 n->sym->name, name, where);
2342 if (n->sym->attr.pointer && list == OMP_LIST_REDUCTION)
2343 gfc_error ("POINTER object '%s' in %s clause at %L",
2344 n->sym->name, name, where);
2345 if (n->sym->attr.cray_pointer && list == OMP_LIST_REDUCTION)
2346 gfc_error ("Cray pointer '%s' in %s clause at %L",
2347 n->sym->name, name, where);
2348 }
2349 if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
2350 gfc_error ("Assumed size array '%s' in %s clause at %L",
2351 n->sym->name, name, where);
2352 if (n->sym->attr.in_namelist && list != OMP_LIST_REDUCTION)
2353 gfc_error ("Variable '%s' in %s clause is used in "
2354 "NAMELIST statement at %L",
2355 n->sym->name, name, where);
2356 if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
2357 switch (list)
2358 {
2359 case OMP_LIST_PRIVATE:
2360 case OMP_LIST_LASTPRIVATE:
2361 case OMP_LIST_LINEAR:
2362 /* case OMP_LIST_REDUCTION: */
2363 gfc_error ("INTENT(IN) POINTER '%s' in %s clause at %L",
2364 n->sym->name, name, where);
2365 break;
2366 default:
2367 break;
2368 }
2369 switch (list)
2370 {
2371 case OMP_LIST_REDUCTION:
2372 switch (n->u.reduction_op)
2373 {
2374 case OMP_REDUCTION_PLUS:
2375 case OMP_REDUCTION_TIMES:
2376 case OMP_REDUCTION_MINUS:
2377 if (!gfc_numeric_ts (&n->sym->ts))
2378 bad = true;
2379 break;
2380 case OMP_REDUCTION_AND:
2381 case OMP_REDUCTION_OR:
2382 case OMP_REDUCTION_EQV:
2383 case OMP_REDUCTION_NEQV:
2384 if (n->sym->ts.type != BT_LOGICAL)
2385 bad = true;
2386 break;
2387 case OMP_REDUCTION_MAX:
2388 case OMP_REDUCTION_MIN:
2389 if (n->sym->ts.type != BT_INTEGER
2390 && n->sym->ts.type != BT_REAL)
2391 bad = true;
2392 break;
2393 case OMP_REDUCTION_IAND:
2394 case OMP_REDUCTION_IOR:
2395 case OMP_REDUCTION_IEOR:
2396 if (n->sym->ts.type != BT_INTEGER)
2397 bad = true;
2398 break;
2399 case OMP_REDUCTION_USER:
2400 bad = true;
2401 break;
2402 default:
2403 break;
2404 }
2405 if (!bad)
2406 n->udr = NULL;
2407 else
2408 {
2409 const char *udr_name = NULL;
2410 if (n->udr)
2411 {
2412 udr_name = n->udr->udr->name;
2413 n->udr->udr
2414 = gfc_find_omp_udr (NULL, udr_name,
2415 &n->sym->ts);
2416 if (n->udr->udr == NULL)
2417 {
2418 free (n->udr);
2419 n->udr = NULL;
2420 }
2421 }
2422 if (n->udr == NULL)
2423 {
2424 if (udr_name == NULL)
2425 switch (n->u.reduction_op)
2426 {
2427 case OMP_REDUCTION_PLUS:
2428 case OMP_REDUCTION_TIMES:
2429 case OMP_REDUCTION_MINUS:
2430 case OMP_REDUCTION_AND:
2431 case OMP_REDUCTION_OR:
2432 case OMP_REDUCTION_EQV:
2433 case OMP_REDUCTION_NEQV:
2434 udr_name = gfc_op2string ((gfc_intrinsic_op)
2435 n->u.reduction_op);
2436 break;
2437 case OMP_REDUCTION_MAX:
2438 udr_name = "max";
2439 break;
2440 case OMP_REDUCTION_MIN:
2441 udr_name = "min";
2442 break;
2443 case OMP_REDUCTION_IAND:
2444 udr_name = "iand";
2445 break;
2446 case OMP_REDUCTION_IOR:
2447 udr_name = "ior";
2448 break;
2449 case OMP_REDUCTION_IEOR:
2450 udr_name = "ieor";
2451 break;
2452 default:
2453 gcc_unreachable ();
2454 }
2455 gfc_error ("!$OMP DECLARE REDUCTION %s not found "
2456 "for type %s at %L", udr_name,
2457 gfc_typename (&n->sym->ts), where);
2458 }
2459 else
2460 {
2461 gfc_omp_udr *udr = n->udr->udr;
2462 n->u.reduction_op = OMP_REDUCTION_USER;
2463 n->udr->combiner
2464 = resolve_omp_udr_clause (n, udr->combiner_ns,
2465 udr->omp_out,
2466 udr->omp_in);
2467 if (udr->initializer_ns)
2468 n->udr->initializer
2469 = resolve_omp_udr_clause (n,
2470 udr->initializer_ns,
2471 udr->omp_priv,
2472 udr->omp_orig);
2473 }
2474 }
2475 break;
2476 case OMP_LIST_LINEAR:
2477 if (n->sym->ts.type != BT_INTEGER)
2478 gfc_error ("LINEAR variable '%s' must be INTEGER "
2479 "at %L", n->sym->name, where);
2480 else if (!code && !n->sym->attr.value)
2481 gfc_error ("LINEAR dummy argument '%s' must have VALUE "
2482 "attribute at %L", n->sym->name, where);
2483 else if (n->expr)
2484 {
2485 gfc_expr *expr = n->expr;
2486 if (!gfc_resolve_expr (expr)
2487 || expr->ts.type != BT_INTEGER
2488 || expr->rank != 0)
2489 gfc_error ("'%s' in LINEAR clause at %L requires "
2490 "a scalar integer linear-step expression",
2491 n->sym->name, where);
2492 else if (!code && expr->expr_type != EXPR_CONSTANT)
2493 gfc_error ("'%s' in LINEAR clause at %L requires "
2494 "a constant integer linear-step expression",
2495 n->sym->name, where);
2496 }
2497 break;
2498 /* Workaround for PR middle-end/26316, nothing really needs
2499 to be done here for OMP_LIST_PRIVATE. */
2500 case OMP_LIST_PRIVATE:
2501 gcc_assert (code && code->op != EXEC_NOP);
2502 default:
2503 break;
2504 }
2505 }
2506 break;
2507 }
2508 }
2509 if (omp_clauses->safelen_expr)
2510 {
2511 gfc_expr *expr = omp_clauses->safelen_expr;
2512 if (!gfc_resolve_expr (expr)
2513 || expr->ts.type != BT_INTEGER || expr->rank != 0)
2514 gfc_error ("SAFELEN clause at %L requires a scalar "
2515 "INTEGER expression", &expr->where);
2516 }
2517 if (omp_clauses->simdlen_expr)
2518 {
2519 gfc_expr *expr = omp_clauses->simdlen_expr;
2520 if (!gfc_resolve_expr (expr)
2521 || expr->ts.type != BT_INTEGER || expr->rank != 0)
2522 gfc_error ("SIMDLEN clause at %L requires a scalar "
2523 "INTEGER expression", &expr->where);
2524 }
2525 if (omp_clauses->num_teams)
2526 {
2527 gfc_expr *expr = omp_clauses->num_teams;
2528 if (!gfc_resolve_expr (expr)
2529 || expr->ts.type != BT_INTEGER || expr->rank != 0)
2530 gfc_error ("NUM_TEAMS clause at %L requires a scalar "
2531 "INTEGER expression", &expr->where);
2532 }
2533 if (omp_clauses->device)
2534 {
2535 gfc_expr *expr = omp_clauses->device;
2536 if (!gfc_resolve_expr (expr)
2537 || expr->ts.type != BT_INTEGER || expr->rank != 0)
2538 gfc_error ("DEVICE clause at %L requires a scalar "
2539 "INTEGER expression", &expr->where);
2540 }
2541 if (omp_clauses->dist_chunk_size)
2542 {
2543 gfc_expr *expr = omp_clauses->dist_chunk_size;
2544 if (!gfc_resolve_expr (expr)
2545 || expr->ts.type != BT_INTEGER || expr->rank != 0)
2546 gfc_error ("DIST_SCHEDULE clause's chunk_size at %L requires "
2547 "a scalar INTEGER expression", &expr->where);
2548 }
2549 if (omp_clauses->thread_limit)
2550 {
2551 gfc_expr *expr = omp_clauses->thread_limit;
2552 if (!gfc_resolve_expr (expr)
2553 || expr->ts.type != BT_INTEGER || expr->rank != 0)
2554 gfc_error ("THREAD_LIMIT clause at %L requires a scalar "
2555 "INTEGER expression", &expr->where);
2556 }
2557 }
2558
2559
2560 /* Return true if SYM is ever referenced in EXPR except in the SE node. */
2561
2562 static bool
2563 expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
2564 {
2565 gfc_actual_arglist *arg;
2566 if (e == NULL || e == se)
2567 return false;
2568 switch (e->expr_type)
2569 {
2570 case EXPR_CONSTANT:
2571 case EXPR_NULL:
2572 case EXPR_VARIABLE:
2573 case EXPR_STRUCTURE:
2574 case EXPR_ARRAY:
2575 if (e->symtree != NULL
2576 && e->symtree->n.sym == s)
2577 return true;
2578 return false;
2579 case EXPR_SUBSTRING:
2580 if (e->ref != NULL
2581 && (expr_references_sym (e->ref->u.ss.start, s, se)
2582 || expr_references_sym (e->ref->u.ss.end, s, se)))
2583 return true;
2584 return false;
2585 case EXPR_OP:
2586 if (expr_references_sym (e->value.op.op2, s, se))
2587 return true;
2588 return expr_references_sym (e->value.op.op1, s, se);
2589 case EXPR_FUNCTION:
2590 for (arg = e->value.function.actual; arg; arg = arg->next)
2591 if (expr_references_sym (arg->expr, s, se))
2592 return true;
2593 return false;
2594 default:
2595 gcc_unreachable ();
2596 }
2597 }
2598
2599
2600 /* If EXPR is a conversion function that widens the type
2601 if WIDENING is true or narrows the type if WIDENING is false,
2602 return the inner expression, otherwise return NULL. */
2603
2604 static gfc_expr *
2605 is_conversion (gfc_expr *expr, bool widening)
2606 {
2607 gfc_typespec *ts1, *ts2;
2608
2609 if (expr->expr_type != EXPR_FUNCTION
2610 || expr->value.function.isym == NULL
2611 || expr->value.function.esym != NULL
2612 || expr->value.function.isym->id != GFC_ISYM_CONVERSION)
2613 return NULL;
2614
2615 if (widening)
2616 {
2617 ts1 = &expr->ts;
2618 ts2 = &expr->value.function.actual->expr->ts;
2619 }
2620 else
2621 {
2622 ts1 = &expr->value.function.actual->expr->ts;
2623 ts2 = &expr->ts;
2624 }
2625
2626 if (ts1->type > ts2->type
2627 || (ts1->type == ts2->type && ts1->kind > ts2->kind))
2628 return expr->value.function.actual->expr;
2629
2630 return NULL;
2631 }
2632
2633
2634 static void
2635 resolve_omp_atomic (gfc_code *code)
2636 {
2637 gfc_code *atomic_code = code;
2638 gfc_symbol *var;
2639 gfc_expr *expr2, *expr2_tmp;
2640 gfc_omp_atomic_op aop
2641 = (gfc_omp_atomic_op) (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK);
2642
2643 code = code->block->next;
2644 gcc_assert (code->op == EXEC_ASSIGN);
2645 gcc_assert (((aop != GFC_OMP_ATOMIC_CAPTURE) && code->next == NULL)
2646 || ((aop == GFC_OMP_ATOMIC_CAPTURE)
2647 && code->next != NULL
2648 && code->next->op == EXEC_ASSIGN
2649 && code->next->next == NULL));
2650
2651 if (code->expr1->expr_type != EXPR_VARIABLE
2652 || code->expr1->symtree == NULL
2653 || code->expr1->rank != 0
2654 || (code->expr1->ts.type != BT_INTEGER
2655 && code->expr1->ts.type != BT_REAL
2656 && code->expr1->ts.type != BT_COMPLEX
2657 && code->expr1->ts.type != BT_LOGICAL))
2658 {
2659 gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
2660 "intrinsic type at %L", &code->loc);
2661 return;
2662 }
2663
2664 var = code->expr1->symtree->n.sym;
2665 expr2 = is_conversion (code->expr2, false);
2666 if (expr2 == NULL)
2667 {
2668 if (aop == GFC_OMP_ATOMIC_READ || aop == GFC_OMP_ATOMIC_WRITE)
2669 expr2 = is_conversion (code->expr2, true);
2670 if (expr2 == NULL)
2671 expr2 = code->expr2;
2672 }
2673
2674 switch (aop)
2675 {
2676 case GFC_OMP_ATOMIC_READ:
2677 if (expr2->expr_type != EXPR_VARIABLE
2678 || expr2->symtree == NULL
2679 || expr2->rank != 0
2680 || (expr2->ts.type != BT_INTEGER
2681 && expr2->ts.type != BT_REAL
2682 && expr2->ts.type != BT_COMPLEX
2683 && expr2->ts.type != BT_LOGICAL))
2684 gfc_error ("!$OMP ATOMIC READ statement must read from a scalar "
2685 "variable of intrinsic type at %L", &expr2->where);
2686 return;
2687 case GFC_OMP_ATOMIC_WRITE:
2688 if (expr2->rank != 0 || expr_references_sym (code->expr2, var, NULL))
2689 gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr "
2690 "must be scalar and cannot reference var at %L",
2691 &expr2->where);
2692 return;
2693 case GFC_OMP_ATOMIC_CAPTURE:
2694 expr2_tmp = expr2;
2695 if (expr2 == code->expr2)
2696 {
2697 expr2_tmp = is_conversion (code->expr2, true);
2698 if (expr2_tmp == NULL)
2699 expr2_tmp = expr2;
2700 }
2701 if (expr2_tmp->expr_type == EXPR_VARIABLE)
2702 {
2703 if (expr2_tmp->symtree == NULL
2704 || expr2_tmp->rank != 0
2705 || (expr2_tmp->ts.type != BT_INTEGER
2706 && expr2_tmp->ts.type != BT_REAL
2707 && expr2_tmp->ts.type != BT_COMPLEX
2708 && expr2_tmp->ts.type != BT_LOGICAL)
2709 || expr2_tmp->symtree->n.sym == var)
2710 {
2711 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read from "
2712 "a scalar variable of intrinsic type at %L",
2713 &expr2_tmp->where);
2714 return;
2715 }
2716 var = expr2_tmp->symtree->n.sym;
2717 code = code->next;
2718 if (code->expr1->expr_type != EXPR_VARIABLE
2719 || code->expr1->symtree == NULL
2720 || code->expr1->rank != 0
2721 || (code->expr1->ts.type != BT_INTEGER
2722 && code->expr1->ts.type != BT_REAL
2723 && code->expr1->ts.type != BT_COMPLEX
2724 && code->expr1->ts.type != BT_LOGICAL))
2725 {
2726 gfc_error ("!$OMP ATOMIC CAPTURE update statement must set "
2727 "a scalar variable of intrinsic type at %L",
2728 &code->expr1->where);
2729 return;
2730 }
2731 if (code->expr1->symtree->n.sym != var)
2732 {
2733 gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
2734 "different variable than update statement writes "
2735 "into at %L", &code->expr1->where);
2736 return;
2737 }
2738 expr2 = is_conversion (code->expr2, false);
2739 if (expr2 == NULL)
2740 expr2 = code->expr2;
2741 }
2742 break;
2743 default:
2744 break;
2745 }
2746
2747 if (gfc_expr_attr (code->expr1).allocatable)
2748 {
2749 gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L",
2750 &code->loc);
2751 return;
2752 }
2753
2754 if (aop == GFC_OMP_ATOMIC_CAPTURE
2755 && code->next == NULL
2756 && code->expr2->rank == 0
2757 && !expr_references_sym (code->expr2, var, NULL))
2758 atomic_code->ext.omp_atomic
2759 = (gfc_omp_atomic_op) (atomic_code->ext.omp_atomic
2760 | GFC_OMP_ATOMIC_SWAP);
2761 else if (expr2->expr_type == EXPR_OP)
2762 {
2763 gfc_expr *v = NULL, *e, *c;
2764 gfc_intrinsic_op op = expr2->value.op.op;
2765 gfc_intrinsic_op alt_op = INTRINSIC_NONE;
2766
2767 switch (op)
2768 {
2769 case INTRINSIC_PLUS:
2770 alt_op = INTRINSIC_MINUS;
2771 break;
2772 case INTRINSIC_TIMES:
2773 alt_op = INTRINSIC_DIVIDE;
2774 break;
2775 case INTRINSIC_MINUS:
2776 alt_op = INTRINSIC_PLUS;
2777 break;
2778 case INTRINSIC_DIVIDE:
2779 alt_op = INTRINSIC_TIMES;
2780 break;
2781 case INTRINSIC_AND:
2782 case INTRINSIC_OR:
2783 break;
2784 case INTRINSIC_EQV:
2785 alt_op = INTRINSIC_NEQV;
2786 break;
2787 case INTRINSIC_NEQV:
2788 alt_op = INTRINSIC_EQV;
2789 break;
2790 default:
2791 gfc_error ("!$OMP ATOMIC assignment operator must be binary "
2792 "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
2793 &expr2->where);
2794 return;
2795 }
2796
2797 /* Check for var = var op expr resp. var = expr op var where
2798 expr doesn't reference var and var op expr is mathematically
2799 equivalent to var op (expr) resp. expr op var equivalent to
2800 (expr) op var. We rely here on the fact that the matcher
2801 for x op1 y op2 z where op1 and op2 have equal precedence
2802 returns (x op1 y) op2 z. */
2803 e = expr2->value.op.op2;
2804 if (e->expr_type == EXPR_VARIABLE
2805 && e->symtree != NULL
2806 && e->symtree->n.sym == var)
2807 v = e;
2808 else if ((c = is_conversion (e, true)) != NULL
2809 && c->expr_type == EXPR_VARIABLE
2810 && c->symtree != NULL
2811 && c->symtree->n.sym == var)
2812 v = c;
2813 else
2814 {
2815 gfc_expr **p = NULL, **q;
2816 for (q = &expr2->value.op.op1; (e = *q) != NULL; )
2817 if (e->expr_type == EXPR_VARIABLE
2818 && e->symtree != NULL
2819 && e->symtree->n.sym == var)
2820 {
2821 v = e;
2822 break;
2823 }
2824 else if ((c = is_conversion (e, true)) != NULL)
2825 q = &e->value.function.actual->expr;
2826 else if (e->expr_type != EXPR_OP
2827 || (e->value.op.op != op
2828 && e->value.op.op != alt_op)
2829 || e->rank != 0)
2830 break;
2831 else
2832 {
2833 p = q;
2834 q = &e->value.op.op1;
2835 }
2836
2837 if (v == NULL)
2838 {
2839 gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
2840 "or var = expr op var at %L", &expr2->where);
2841 return;
2842 }
2843
2844 if (p != NULL)
2845 {
2846 e = *p;
2847 switch (e->value.op.op)
2848 {
2849 case INTRINSIC_MINUS:
2850 case INTRINSIC_DIVIDE:
2851 case INTRINSIC_EQV:
2852 case INTRINSIC_NEQV:
2853 gfc_error ("!$OMP ATOMIC var = var op expr not "
2854 "mathematically equivalent to var = var op "
2855 "(expr) at %L", &expr2->where);
2856 break;
2857 default:
2858 break;
2859 }
2860
2861 /* Canonicalize into var = var op (expr). */
2862 *p = e->value.op.op2;
2863 e->value.op.op2 = expr2;
2864 e->ts = expr2->ts;
2865 if (code->expr2 == expr2)
2866 code->expr2 = expr2 = e;
2867 else
2868 code->expr2->value.function.actual->expr = expr2 = e;
2869
2870 if (!gfc_compare_types (&expr2->value.op.op1->ts, &expr2->ts))
2871 {
2872 for (p = &expr2->value.op.op1; *p != v;
2873 p = &(*p)->value.function.actual->expr)
2874 ;
2875 *p = NULL;
2876 gfc_free_expr (expr2->value.op.op1);
2877 expr2->value.op.op1 = v;
2878 gfc_convert_type (v, &expr2->ts, 2);
2879 }
2880 }
2881 }
2882
2883 if (e->rank != 0 || expr_references_sym (code->expr2, var, v))
2884 {
2885 gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
2886 "must be scalar and cannot reference var at %L",
2887 &expr2->where);
2888 return;
2889 }
2890 }
2891 else if (expr2->expr_type == EXPR_FUNCTION
2892 && expr2->value.function.isym != NULL
2893 && expr2->value.function.esym == NULL
2894 && expr2->value.function.actual != NULL
2895 && expr2->value.function.actual->next != NULL)
2896 {
2897 gfc_actual_arglist *arg, *var_arg;
2898
2899 switch (expr2->value.function.isym->id)
2900 {
2901 case GFC_ISYM_MIN:
2902 case GFC_ISYM_MAX:
2903 break;
2904 case GFC_ISYM_IAND:
2905 case GFC_ISYM_IOR:
2906 case GFC_ISYM_IEOR:
2907 if (expr2->value.function.actual->next->next != NULL)
2908 {
2909 gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
2910 "or IEOR must have two arguments at %L",
2911 &expr2->where);
2912 return;
2913 }
2914 break;
2915 default:
2916 gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
2917 "MIN, MAX, IAND, IOR or IEOR at %L",
2918 &expr2->where);
2919 return;
2920 }
2921
2922 var_arg = NULL;
2923 for (arg = expr2->value.function.actual; arg; arg = arg->next)
2924 {
2925 if ((arg == expr2->value.function.actual
2926 || (var_arg == NULL && arg->next == NULL))
2927 && arg->expr->expr_type == EXPR_VARIABLE
2928 && arg->expr->symtree != NULL
2929 && arg->expr->symtree->n.sym == var)
2930 var_arg = arg;
2931 else if (expr_references_sym (arg->expr, var, NULL))
2932 {
2933 gfc_error ("!$OMP ATOMIC intrinsic arguments except one must "
2934 "not reference '%s' at %L",
2935 var->name, &arg->expr->where);
2936 return;
2937 }
2938 if (arg->expr->rank != 0)
2939 {
2940 gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
2941 "at %L", &arg->expr->where);
2942 return;
2943 }
2944 }
2945
2946 if (var_arg == NULL)
2947 {
2948 gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
2949 "be '%s' at %L", var->name, &expr2->where);
2950 return;
2951 }
2952
2953 if (var_arg != expr2->value.function.actual)
2954 {
2955 /* Canonicalize, so that var comes first. */
2956 gcc_assert (var_arg->next == NULL);
2957 for (arg = expr2->value.function.actual;
2958 arg->next != var_arg; arg = arg->next)
2959 ;
2960 var_arg->next = expr2->value.function.actual;
2961 expr2->value.function.actual = var_arg;
2962 arg->next = NULL;
2963 }
2964 }
2965 else
2966 gfc_error ("!$OMP ATOMIC assignment must have an operator or "
2967 "intrinsic on right hand side at %L", &expr2->where);
2968
2969 if (aop == GFC_OMP_ATOMIC_CAPTURE && code->next)
2970 {
2971 code = code->next;
2972 if (code->expr1->expr_type != EXPR_VARIABLE
2973 || code->expr1->symtree == NULL
2974 || code->expr1->rank != 0
2975 || (code->expr1->ts.type != BT_INTEGER
2976 && code->expr1->ts.type != BT_REAL
2977 && code->expr1->ts.type != BT_COMPLEX
2978 && code->expr1->ts.type != BT_LOGICAL))
2979 {
2980 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must set "
2981 "a scalar variable of intrinsic type at %L",
2982 &code->expr1->where);
2983 return;
2984 }
2985
2986 expr2 = is_conversion (code->expr2, false);
2987 if (expr2 == NULL)
2988 {
2989 expr2 = is_conversion (code->expr2, true);
2990 if (expr2 == NULL)
2991 expr2 = code->expr2;
2992 }
2993
2994 if (expr2->expr_type != EXPR_VARIABLE
2995 || expr2->symtree == NULL
2996 || expr2->rank != 0
2997 || (expr2->ts.type != BT_INTEGER
2998 && expr2->ts.type != BT_REAL
2999 && expr2->ts.type != BT_COMPLEX
3000 && expr2->ts.type != BT_LOGICAL))
3001 {
3002 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read "
3003 "from a scalar variable of intrinsic type at %L",
3004 &expr2->where);
3005 return;
3006 }
3007 if (expr2->symtree->n.sym != var)
3008 {
3009 gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
3010 "different variable than update statement writes "
3011 "into at %L", &expr2->where);
3012 return;
3013 }
3014 }
3015 }
3016
3017
3018 struct fortran_omp_context
3019 {
3020 gfc_code *code;
3021 hash_set<gfc_symbol *> *sharing_clauses;
3022 hash_set<gfc_symbol *> *private_iterators;
3023 struct fortran_omp_context *previous;
3024 } *omp_current_ctx;
3025 static gfc_code *omp_current_do_code;
3026 static int omp_current_do_collapse;
3027
3028 void
3029 gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
3030 {
3031 if (code->block->next && code->block->next->op == EXEC_DO)
3032 {
3033 int i;
3034 gfc_code *c;
3035
3036 omp_current_do_code = code->block->next;
3037 omp_current_do_collapse = code->ext.omp_clauses->collapse;
3038 for (i = 1, c = omp_current_do_code; i < omp_current_do_collapse; i++)
3039 {
3040 c = c->block;
3041 if (c->op != EXEC_DO || c->next == NULL)
3042 break;
3043 c = c->next;
3044 if (c->op != EXEC_DO)
3045 break;
3046 }
3047 if (i < omp_current_do_collapse || omp_current_do_collapse <= 0)
3048 omp_current_do_collapse = 1;
3049 }
3050 gfc_resolve_blocks (code->block, ns);
3051 omp_current_do_collapse = 0;
3052 omp_current_do_code = NULL;
3053 }
3054
3055
3056 void
3057 gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
3058 {
3059 struct fortran_omp_context ctx;
3060 gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
3061 gfc_omp_namelist *n;
3062 int list;
3063
3064 ctx.code = code;
3065 ctx.sharing_clauses = new hash_set<gfc_symbol *>;
3066 ctx.private_iterators = new hash_set<gfc_symbol *>;
3067 ctx.previous = omp_current_ctx;
3068 omp_current_ctx = &ctx;
3069
3070 for (list = 0; list < OMP_LIST_NUM; list++)
3071 switch (list)
3072 {
3073 case OMP_LIST_SHARED:
3074 case OMP_LIST_PRIVATE:
3075 case OMP_LIST_FIRSTPRIVATE:
3076 case OMP_LIST_LASTPRIVATE:
3077 case OMP_LIST_REDUCTION:
3078 case OMP_LIST_LINEAR:
3079 for (n = omp_clauses->lists[list]; n; n = n->next)
3080 ctx.sharing_clauses->add (n->sym);
3081 break;
3082 default:
3083 break;
3084 }
3085
3086 switch (code->op)
3087 {
3088 case EXEC_OMP_PARALLEL_DO:
3089 case EXEC_OMP_PARALLEL_DO_SIMD:
3090 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
3091 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
3092 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
3093 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
3094 case EXEC_OMP_TEAMS_DISTRIBUTE:
3095 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
3096 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
3097 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
3098 gfc_resolve_omp_do_blocks (code, ns);
3099 break;
3100 default:
3101 gfc_resolve_blocks (code->block, ns);
3102 }
3103
3104 omp_current_ctx = ctx.previous;
3105 delete ctx.sharing_clauses;
3106 delete ctx.private_iterators;
3107 }
3108
3109
3110 /* Save and clear openmp.c private state. */
3111
3112 void
3113 gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *state)
3114 {
3115 state->ptrs[0] = omp_current_ctx;
3116 state->ptrs[1] = omp_current_do_code;
3117 state->ints[0] = omp_current_do_collapse;
3118 omp_current_ctx = NULL;
3119 omp_current_do_code = NULL;
3120 omp_current_do_collapse = 0;
3121 }
3122
3123
3124 /* Restore openmp.c private state from the saved state. */
3125
3126 void
3127 gfc_omp_restore_state (struct gfc_omp_saved_state *state)
3128 {
3129 omp_current_ctx = (struct fortran_omp_context *) state->ptrs[0];
3130 omp_current_do_code = (gfc_code *) state->ptrs[1];
3131 omp_current_do_collapse = state->ints[0];
3132 }
3133
3134
3135 /* Note a DO iterator variable. This is special in !$omp parallel
3136 construct, where they are predetermined private. */
3137
3138 void
3139 gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym)
3140 {
3141 int i = omp_current_do_collapse;
3142 gfc_code *c = omp_current_do_code;
3143
3144 if (sym->attr.threadprivate)
3145 return;
3146
3147 /* !$omp do and !$omp parallel do iteration variable is predetermined
3148 private just in the !$omp do resp. !$omp parallel do construct,
3149 with no implications for the outer parallel constructs. */
3150
3151 while (i-- >= 1)
3152 {
3153 if (code == c)
3154 return;
3155
3156 c = c->block->next;
3157 }
3158
3159 if (omp_current_ctx == NULL)
3160 return;
3161
3162 if (omp_current_ctx->sharing_clauses->contains (sym))
3163 return;
3164
3165 if (! omp_current_ctx->private_iterators->add (sym))
3166 {
3167 gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses;
3168 gfc_omp_namelist *p;
3169
3170 p = gfc_get_omp_namelist ();
3171 p->sym = sym;
3172 p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
3173 omp_clauses->lists[OMP_LIST_PRIVATE] = p;
3174 }
3175 }
3176
3177
3178 static void
3179 resolve_omp_do (gfc_code *code)
3180 {
3181 gfc_code *do_code, *c;
3182 int list, i, collapse;
3183 gfc_omp_namelist *n;
3184 gfc_symbol *dovar;
3185 const char *name;
3186 bool is_simd = false;
3187
3188 switch (code->op)
3189 {
3190 case EXEC_OMP_DISTRIBUTE: name = "!$OMP DISTRIBUTE"; break;
3191 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
3192 name = "!$OMP DISTRIBUTE PARALLEL DO";
3193 break;
3194 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
3195 name = "!$OMP DISTRIBUTE PARALLEL DO SIMD";
3196 is_simd = true;
3197 break;
3198 case EXEC_OMP_DISTRIBUTE_SIMD:
3199 name = "!$OMP DISTRIBUTE SIMD";
3200 is_simd = true;
3201 break;
3202 case EXEC_OMP_DO: name = "!$OMP DO"; break;
3203 case EXEC_OMP_DO_SIMD: name = "!$OMP DO SIMD"; is_simd = true; break;
3204 case EXEC_OMP_PARALLEL_DO: name = "!$OMP PARALLEL DO"; break;
3205 case EXEC_OMP_PARALLEL_DO_SIMD:
3206 name = "!$OMP PARALLEL DO SIMD";
3207 is_simd = true;
3208 break;
3209 case EXEC_OMP_SIMD: name = "!$OMP SIMD"; is_simd = true; break;
3210 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
3211 name = "!$OMP TARGET TEAMS_DISTRIBUTE";
3212 break;
3213 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
3214 name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
3215 break;
3216 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
3217 name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
3218 is_simd = true;
3219 break;
3220 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
3221 name = "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
3222 is_simd = true;
3223 break;
3224 case EXEC_OMP_TEAMS_DISTRIBUTE: name = "!$OMP TEAMS_DISTRIBUTE"; break;
3225 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
3226 name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
3227 break;
3228 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
3229 name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
3230 is_simd = true;
3231 break;
3232 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
3233 name = "!$OMP TEAMS DISTRIBUTE SIMD";
3234 is_simd = true;
3235 break;
3236 default: gcc_unreachable ();
3237 }
3238
3239 if (code->ext.omp_clauses)
3240 resolve_omp_clauses (code, &code->loc, code->ext.omp_clauses, NULL);
3241
3242 do_code = code->block->next;
3243 collapse = code->ext.omp_clauses->collapse;
3244 if (collapse <= 0)
3245 collapse = 1;
3246 for (i = 1; i <= collapse; i++)
3247 {
3248 if (do_code->op == EXEC_DO_WHILE)
3249 {
3250 gfc_error ("%s cannot be a DO WHILE or DO without loop control "
3251 "at %L", name, &do_code->loc);
3252 break;
3253 }
3254 if (do_code->op == EXEC_DO_CONCURRENT)
3255 {
3256 gfc_error ("%s cannot be a DO CONCURRENT loop at %L", name,
3257 &do_code->loc);
3258 break;
3259 }
3260 gcc_assert (do_code->op == EXEC_DO);
3261 if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
3262 gfc_error ("%s iteration variable must be of type integer at %L",
3263 name, &do_code->loc);
3264 dovar = do_code->ext.iterator->var->symtree->n.sym;
3265 if (dovar->attr.threadprivate)
3266 gfc_error ("%s iteration variable must not be THREADPRIVATE "
3267 "at %L", name, &do_code->loc);
3268 if (code->ext.omp_clauses)
3269 for (list = 0; list < OMP_LIST_NUM; list++)
3270 if (!is_simd
3271 ? (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE)
3272 : code->ext.omp_clauses->collapse > 1
3273 ? (list != OMP_LIST_LASTPRIVATE)
3274 : (list != OMP_LIST_LINEAR))
3275 for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
3276 if (dovar == n->sym)
3277 {
3278 if (!is_simd)
3279 gfc_error ("%s iteration variable present on clause "
3280 "other than PRIVATE or LASTPRIVATE at %L",
3281 name, &do_code->loc);
3282 else if (code->ext.omp_clauses->collapse > 1)
3283 gfc_error ("%s iteration variable present on clause "
3284 "other than LASTPRIVATE at %L",
3285 name, &do_code->loc);
3286 else
3287 gfc_error ("%s iteration variable present on clause "
3288 "other than LINEAR at %L",
3289 name, &do_code->loc);
3290 break;
3291 }
3292 if (i > 1)
3293 {
3294 gfc_code *do_code2 = code->block->next;
3295 int j;
3296
3297 for (j = 1; j < i; j++)
3298 {
3299 gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
3300 if (dovar == ivar
3301 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
3302 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
3303 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
3304 {
3305 gfc_error ("%s collapsed loops don't form rectangular "
3306 "iteration space at %L", name, &do_code->loc);
3307 break;
3308 }
3309 if (j < i)
3310 break;
3311 do_code2 = do_code2->block->next;
3312 }
3313 }
3314 if (i == collapse)
3315 break;
3316 for (c = do_code->next; c; c = c->next)
3317 if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
3318 {
3319 gfc_error ("collapsed %s loops not perfectly nested at %L",
3320 name, &c->loc);
3321 break;
3322 }
3323 if (c)
3324 break;
3325 do_code = do_code->block;
3326 if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE)
3327 {
3328 gfc_error ("not enough DO loops for collapsed %s at %L",
3329 name, &code->loc);
3330 break;
3331 }
3332 do_code = do_code->next;
3333 if (do_code == NULL
3334 || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE))
3335 {
3336 gfc_error ("not enough DO loops for collapsed %s at %L",
3337 name, &code->loc);
3338 break;
3339 }
3340 }
3341 }
3342
3343
3344 /* Resolve OpenMP directive clauses and check various requirements
3345 of each directive. */
3346
3347 void
3348 gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
3349 {
3350 if (code->op != EXEC_OMP_ATOMIC)
3351 gfc_maybe_initialize_eh ();
3352
3353 switch (code->op)
3354 {
3355 case EXEC_OMP_DISTRIBUTE:
3356 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
3357 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
3358 case EXEC_OMP_DISTRIBUTE_SIMD:
3359 case EXEC_OMP_DO:
3360 case EXEC_OMP_DO_SIMD:
3361 case EXEC_OMP_PARALLEL_DO:
3362 case EXEC_OMP_PARALLEL_DO_SIMD:
3363 case EXEC_OMP_SIMD:
3364 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
3365 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
3366 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
3367 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
3368 case EXEC_OMP_TEAMS_DISTRIBUTE:
3369 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
3370 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
3371 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
3372 resolve_omp_do (code);
3373 break;
3374 case EXEC_OMP_CANCEL:
3375 case EXEC_OMP_PARALLEL_WORKSHARE:
3376 case EXEC_OMP_PARALLEL:
3377 case EXEC_OMP_PARALLEL_SECTIONS:
3378 case EXEC_OMP_SECTIONS:
3379 case EXEC_OMP_SINGLE:
3380 case EXEC_OMP_TARGET:
3381 case EXEC_OMP_TARGET_DATA:
3382 case EXEC_OMP_TARGET_TEAMS:
3383 case EXEC_OMP_TASK:
3384 case EXEC_OMP_TEAMS:
3385 case EXEC_OMP_WORKSHARE:
3386 if (code->ext.omp_clauses)
3387 resolve_omp_clauses (code, &code->loc, code->ext.omp_clauses, NULL);
3388 break;
3389 case EXEC_OMP_TARGET_UPDATE:
3390 if (code->ext.omp_clauses)
3391 resolve_omp_clauses (code, &code->loc, code->ext.omp_clauses, NULL);
3392 if (code->ext.omp_clauses == NULL
3393 || (code->ext.omp_clauses->lists[OMP_LIST_TO] == NULL
3394 && code->ext.omp_clauses->lists[OMP_LIST_FROM] == NULL))
3395 gfc_error ("OMP TARGET UPDATE at %L requires at least one TO or "
3396 "FROM clause", &code->loc);
3397 break;
3398 case EXEC_OMP_ATOMIC:
3399 resolve_omp_atomic (code);
3400 break;
3401 default:
3402 break;
3403 }
3404 }
3405
3406 /* Resolve !$omp declare simd constructs in NS. */
3407
3408 void
3409 gfc_resolve_omp_declare_simd (gfc_namespace *ns)
3410 {
3411 gfc_omp_declare_simd *ods;
3412
3413 for (ods = ns->omp_declare_simd; ods; ods = ods->next)
3414 {
3415 if (ods->proc_name != ns->proc_name)
3416 gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure "
3417 "'%s' at %L", ns->proc_name->name, &ods->where);
3418 if (ods->clauses)
3419 resolve_omp_clauses (NULL, &ods->where, ods->clauses, ns);
3420 }
3421 }
3422
3423 struct omp_udr_callback_data
3424 {
3425 gfc_omp_udr *omp_udr;
3426 bool is_initializer;
3427 };
3428
3429 static int
3430 omp_udr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
3431 void *data)
3432 {
3433 struct omp_udr_callback_data *cd = (struct omp_udr_callback_data *) data;
3434 if ((*e)->expr_type == EXPR_VARIABLE)
3435 {
3436 if (cd->is_initializer)
3437 {
3438 if ((*e)->symtree->n.sym != cd->omp_udr->omp_priv
3439 && (*e)->symtree->n.sym != cd->omp_udr->omp_orig)
3440 gfc_error ("Variable other than OMP_PRIV or OMP_ORIG used in "
3441 "INITIALIZER clause of !$OMP DECLARE REDUCTION at %L",
3442 &(*e)->where);
3443 }
3444 else
3445 {
3446 if ((*e)->symtree->n.sym != cd->omp_udr->omp_out
3447 && (*e)->symtree->n.sym != cd->omp_udr->omp_in)
3448 gfc_error ("Variable other than OMP_OUT or OMP_IN used in "
3449 "combiner of !$OMP DECLARE REDUCTION at %L",
3450 &(*e)->where);
3451 }
3452 }
3453 return 0;
3454 }
3455
3456 /* Resolve !$omp declare reduction constructs. */
3457
3458 static void
3459 gfc_resolve_omp_udr (gfc_omp_udr *omp_udr)
3460 {
3461 gfc_actual_arglist *a;
3462 const char *predef_name = NULL;
3463
3464 switch (omp_udr->rop)
3465 {
3466 case OMP_REDUCTION_PLUS:
3467 case OMP_REDUCTION_TIMES:
3468 case OMP_REDUCTION_MINUS:
3469 case OMP_REDUCTION_AND:
3470 case OMP_REDUCTION_OR:
3471 case OMP_REDUCTION_EQV:
3472 case OMP_REDUCTION_NEQV:
3473 case OMP_REDUCTION_MAX:
3474 case OMP_REDUCTION_USER:
3475 break;
3476 default:
3477 gfc_error ("Invalid operator for !$OMP DECLARE REDUCTION %s at %L",
3478 omp_udr->name, &omp_udr->where);
3479 return;
3480 }
3481
3482 if (gfc_omp_udr_predef (omp_udr->rop, omp_udr->name,
3483 &omp_udr->ts, &predef_name))
3484 {
3485 if (predef_name)
3486 gfc_error_now ("Redefinition of predefined %s "
3487 "!$OMP DECLARE REDUCTION at %L",
3488 predef_name, &omp_udr->where);
3489 else
3490 gfc_error_now ("Redefinition of predefined "
3491 "!$OMP DECLARE REDUCTION at %L", &omp_udr->where);
3492 return;
3493 }
3494
3495 if (omp_udr->ts.type == BT_CHARACTER
3496 && omp_udr->ts.u.cl->length
3497 && omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
3498 {
3499 gfc_error ("CHARACTER length in !$OMP DECLARE REDUCTION %s not "
3500 "constant at %L", omp_udr->name, &omp_udr->where);
3501 return;
3502 }
3503
3504 struct omp_udr_callback_data cd;
3505 cd.omp_udr = omp_udr;
3506 cd.is_initializer = false;
3507 gfc_code_walker (&omp_udr->combiner_ns->code, gfc_dummy_code_callback,
3508 omp_udr_callback, &cd);
3509 if (omp_udr->combiner_ns->code->op == EXEC_CALL)
3510 {
3511 for (a = omp_udr->combiner_ns->code->ext.actual; a; a = a->next)
3512 if (a->expr == NULL)
3513 break;
3514 if (a)
3515 gfc_error ("Subroutine call with alternate returns in combiner "
3516 "of !$OMP DECLARE REDUCTION at %L",
3517 &omp_udr->combiner_ns->code->loc);
3518 }
3519 if (omp_udr->initializer_ns)
3520 {
3521 cd.is_initializer = true;
3522 gfc_code_walker (&omp_udr->initializer_ns->code, gfc_dummy_code_callback,
3523 omp_udr_callback, &cd);
3524 if (omp_udr->initializer_ns->code->op == EXEC_CALL)
3525 {
3526 for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
3527 if (a->expr == NULL)
3528 break;
3529 if (a)
3530 gfc_error ("Subroutine call with alternate returns in "
3531 "INITIALIZER clause of !$OMP DECLARE REDUCTION "
3532 "at %L", &omp_udr->initializer_ns->code->loc);
3533 for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
3534 if (a->expr
3535 && a->expr->expr_type == EXPR_VARIABLE
3536 && a->expr->symtree->n.sym == omp_udr->omp_priv
3537 && a->expr->ref == NULL)
3538 break;
3539 if (a == NULL)
3540 gfc_error ("One of actual subroutine arguments in INITIALIZER "
3541 "clause of !$OMP DECLARE REDUCTION must be OMP_PRIV "
3542 "at %L", &omp_udr->initializer_ns->code->loc);
3543 }
3544 }
3545 else if (omp_udr->ts.type == BT_DERIVED
3546 && !gfc_has_default_initializer (omp_udr->ts.u.derived))
3547 {
3548 gfc_error ("Missing INITIALIZER clause for !$OMP DECLARE REDUCTION "
3549 "of derived type without default initializer at %L",
3550 &omp_udr->where);
3551 return;
3552 }
3553 }
3554
3555 void
3556 gfc_resolve_omp_udrs (gfc_symtree *st)
3557 {
3558 gfc_omp_udr *omp_udr;
3559
3560 if (st == NULL)
3561 return;
3562 gfc_resolve_omp_udrs (st->left);
3563 gfc_resolve_omp_udrs (st->right);
3564 for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
3565 gfc_resolve_omp_udr (omp_udr);
3566 }