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