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