?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* de.po: Update.
[official-gcc.git] / gcc / fortran / openmp.c
blob3ca23493251f281c31726219a9b96a7da44078de
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->collapse && omp_clauses->tile_list)
4758 gfc_error ("Incompatible use of TILE and COLLAPSE at %L", &code->loc);
4759 if (omp_clauses->depend_source && code->op != EXEC_OMP_ORDERED)
4760 gfc_error ("SOURCE dependence type only allowed "
4761 "on ORDERED directive at %L", &code->loc);
4762 if (!openacc && code && omp_clauses->lists[OMP_LIST_MAP] == NULL)
4763 {
4764 const char *p = NULL;
4765 switch (code->op)
4766 {
4767 case EXEC_OMP_TARGET_DATA: p = "TARGET DATA"; break;
4768 case EXEC_OMP_TARGET_ENTER_DATA: p = "TARGET ENTER DATA"; break;
4769 case EXEC_OMP_TARGET_EXIT_DATA: p = "TARGET EXIT DATA"; break;
4770 default: break;
4771 }
4772 if (p)
4773 gfc_error ("%s must contain at least one MAP clause at %L",
4774 p, &code->loc);
4775 }
4776 }
4777
4778
4779 /* Return true if SYM is ever referenced in EXPR except in the SE node. */
4780
4781 static bool
4782 expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
4783 {
4784 gfc_actual_arglist *arg;
4785 if (e == NULL || e == se)
4786 return false;
4787 switch (e->expr_type)
4788 {
4789 case EXPR_CONSTANT:
4790 case EXPR_NULL:
4791 case EXPR_VARIABLE:
4792 case EXPR_STRUCTURE:
4793 case EXPR_ARRAY:
4794 if (e->symtree != NULL
4795 && e->symtree->n.sym == s)
4796 return true;
4797 return false;
4798 case EXPR_SUBSTRING:
4799 if (e->ref != NULL
4800 && (expr_references_sym (e->ref->u.ss.start, s, se)
4801 || expr_references_sym (e->ref->u.ss.end, s, se)))
4802 return true;
4803 return false;
4804 case EXPR_OP:
4805 if (expr_references_sym (e->value.op.op2, s, se))
4806 return true;
4807 return expr_references_sym (e->value.op.op1, s, se);
4808 case EXPR_FUNCTION:
4809 for (arg = e->value.function.actual; arg; arg = arg->next)
4810 if (expr_references_sym (arg->expr, s, se))
4811 return true;
4812 return false;
4813 default:
4814 gcc_unreachable ();
4815 }
4816 }
4817
4818
4819 /* If EXPR is a conversion function that widens the type
4820 if WIDENING is true or narrows the type if WIDENING is false,
4821 return the inner expression, otherwise return NULL. */
4822
4823 static gfc_expr *
4824 is_conversion (gfc_expr *expr, bool widening)
4825 {
4826 gfc_typespec *ts1, *ts2;
4827
4828 if (expr->expr_type != EXPR_FUNCTION
4829 || expr->value.function.isym == NULL
4830 || expr->value.function.esym != NULL
4831 || expr->value.function.isym->id != GFC_ISYM_CONVERSION)
4832 return NULL;
4833
4834 if (widening)
4835 {
4836 ts1 = &expr->ts;
4837 ts2 = &expr->value.function.actual->expr->ts;
4838 }
4839 else
4840 {
4841 ts1 = &expr->value.function.actual->expr->ts;
4842 ts2 = &expr->ts;
4843 }
4844
4845 if (ts1->type > ts2->type
4846 || (ts1->type == ts2->type && ts1->kind > ts2->kind))
4847 return expr->value.function.actual->expr;
4848
4849 return NULL;
4850 }
4851
4852
4853 static void
4854 resolve_omp_atomic (gfc_code *code)
4855 {
4856 gfc_code *atomic_code = code;
4857 gfc_symbol *var;
4858 gfc_expr *expr2, *expr2_tmp;
4859 gfc_omp_atomic_op aop
4860 = (gfc_omp_atomic_op) (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK);
4861
4862 code = code->block->next;
4863 /* resolve_blocks asserts this is initially EXEC_ASSIGN.
4864 If it changed to EXEC_NOP, assume an error has been emitted already. */
4865 if (code->op == EXEC_NOP)
4866 return;
4867 if (code->op != EXEC_ASSIGN)
4868 {
4869 unexpected:
4870 gfc_error ("unexpected !$OMP ATOMIC expression at %L", &code->loc);
4871 return;
4872 }
4873 if (aop != GFC_OMP_ATOMIC_CAPTURE)
4874 {
4875 if (code->next != NULL)
4876 goto unexpected;
4877 }
4878 else
4879 {
4880 if (code->next == NULL)
4881 goto unexpected;
4882 if (code->next->op == EXEC_NOP)
4883 return;
4884 if (code->next->op != EXEC_ASSIGN || code->next->next)
4885 {
4886 code = code->next;
4887 goto unexpected;
4888 }
4889 }
4890
4891 if (code->expr1->expr_type != EXPR_VARIABLE
4892 || code->expr1->symtree == NULL
4893 || code->expr1->rank != 0
4894 || (code->expr1->ts.type != BT_INTEGER
4895 && code->expr1->ts.type != BT_REAL
4896 && code->expr1->ts.type != BT_COMPLEX
4897 && code->expr1->ts.type != BT_LOGICAL))
4898 {
4899 gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
4900 "intrinsic type at %L", &code->loc);
4901 return;
4902 }
4903
4904 var = code->expr1->symtree->n.sym;
4905 expr2 = is_conversion (code->expr2, false);
4906 if (expr2 == NULL)
4907 {
4908 if (aop == GFC_OMP_ATOMIC_READ || aop == GFC_OMP_ATOMIC_WRITE)
4909 expr2 = is_conversion (code->expr2, true);
4910 if (expr2 == NULL)
4911 expr2 = code->expr2;
4912 }
4913
4914 switch (aop)
4915 {
4916 case GFC_OMP_ATOMIC_READ:
4917 if (expr2->expr_type != EXPR_VARIABLE
4918 || expr2->symtree == NULL
4919 || expr2->rank != 0
4920 || (expr2->ts.type != BT_INTEGER
4921 && expr2->ts.type != BT_REAL
4922 && expr2->ts.type != BT_COMPLEX
4923 && expr2->ts.type != BT_LOGICAL))
4924 gfc_error ("!$OMP ATOMIC READ statement must read from a scalar "
4925 "variable of intrinsic type at %L", &expr2->where);
4926 return;
4927 case GFC_OMP_ATOMIC_WRITE:
4928 if (expr2->rank != 0 || expr_references_sym (code->expr2, var, NULL))
4929 gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr "
4930 "must be scalar and cannot reference var at %L",
4931 &expr2->where);
4932 return;
4933 case GFC_OMP_ATOMIC_CAPTURE:
4934 expr2_tmp = expr2;
4935 if (expr2 == code->expr2)
4936 {
4937 expr2_tmp = is_conversion (code->expr2, true);
4938 if (expr2_tmp == NULL)
4939 expr2_tmp = expr2;
4940 }
4941 if (expr2_tmp->expr_type == EXPR_VARIABLE)
4942 {
4943 if (expr2_tmp->symtree == NULL
4944 || expr2_tmp->rank != 0
4945 || (expr2_tmp->ts.type != BT_INTEGER
4946 && expr2_tmp->ts.type != BT_REAL
4947 && expr2_tmp->ts.type != BT_COMPLEX
4948 && expr2_tmp->ts.type != BT_LOGICAL)
4949 || expr2_tmp->symtree->n.sym == var)
4950 {
4951 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read from "
4952 "a scalar variable of intrinsic type at %L",
4953 &expr2_tmp->where);
4954 return;
4955 }
4956 var = expr2_tmp->symtree->n.sym;
4957 code = code->next;
4958 if (code->expr1->expr_type != EXPR_VARIABLE
4959 || code->expr1->symtree == NULL
4960 || code->expr1->rank != 0
4961 || (code->expr1->ts.type != BT_INTEGER
4962 && code->expr1->ts.type != BT_REAL
4963 && code->expr1->ts.type != BT_COMPLEX
4964 && code->expr1->ts.type != BT_LOGICAL))
4965 {
4966 gfc_error ("!$OMP ATOMIC CAPTURE update statement must set "
4967 "a scalar variable of intrinsic type at %L",
4968 &code->expr1->where);
4969 return;
4970 }
4971 if (code->expr1->symtree->n.sym != var)
4972 {
4973 gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
4974 "different variable than update statement writes "
4975 "into at %L", &code->expr1->where);
4976 return;
4977 }
4978 expr2 = is_conversion (code->expr2, false);
4979 if (expr2 == NULL)
4980 expr2 = code->expr2;
4981 }
4982 break;
4983 default:
4984 break;
4985 }
4986
4987 if (gfc_expr_attr (code->expr1).allocatable)
4988 {
4989 gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L",
4990 &code->loc);
4991 return;
4992 }
4993
4994 if (aop == GFC_OMP_ATOMIC_CAPTURE
4995 && code->next == NULL
4996 && code->expr2->rank == 0
4997 && !expr_references_sym (code->expr2, var, NULL))
4998 atomic_code->ext.omp_atomic
4999 = (gfc_omp_atomic_op) (atomic_code->ext.omp_atomic
5000 | GFC_OMP_ATOMIC_SWAP);
5001 else if (expr2->expr_type == EXPR_OP)
5002 {
5003 gfc_expr *v = NULL, *e, *c;
5004 gfc_intrinsic_op op = expr2->value.op.op;
5005 gfc_intrinsic_op alt_op = INTRINSIC_NONE;
5006
5007 switch (op)
5008 {
5009 case INTRINSIC_PLUS:
5010 alt_op = INTRINSIC_MINUS;
5011 break;
5012 case INTRINSIC_TIMES:
5013 alt_op = INTRINSIC_DIVIDE;
5014 break;
5015 case INTRINSIC_MINUS:
5016 alt_op = INTRINSIC_PLUS;
5017 break;
5018 case INTRINSIC_DIVIDE:
5019 alt_op = INTRINSIC_TIMES;
5020 break;
5021 case INTRINSIC_AND:
5022 case INTRINSIC_OR:
5023 break;
5024 case INTRINSIC_EQV:
5025 alt_op = INTRINSIC_NEQV;
5026 break;
5027 case INTRINSIC_NEQV:
5028 alt_op = INTRINSIC_EQV;
5029 break;
5030 default:
5031 gfc_error ("!$OMP ATOMIC assignment operator must be binary "
5032 "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
5033 &expr2->where);
5034 return;
5035 }
5036
5037 /* Check for var = var op expr resp. var = expr op var where
5038 expr doesn't reference var and var op expr is mathematically
5039 equivalent to var op (expr) resp. expr op var equivalent to
5040 (expr) op var. We rely here on the fact that the matcher
5041 for x op1 y op2 z where op1 and op2 have equal precedence
5042 returns (x op1 y) op2 z. */
5043 e = expr2->value.op.op2;
5044 if (e->expr_type == EXPR_VARIABLE
5045 && e->symtree != NULL
5046 && e->symtree->n.sym == var)
5047 v = e;
5048 else if ((c = is_conversion (e, true)) != NULL
5049 && c->expr_type == EXPR_VARIABLE
5050 && c->symtree != NULL
5051 && c->symtree->n.sym == var)
5052 v = c;
5053 else
5054 {
5055 gfc_expr **p = NULL, **q;
5056 for (q = &expr2->value.op.op1; (e = *q) != NULL; )
5057 if (e->expr_type == EXPR_VARIABLE
5058 && e->symtree != NULL
5059 && e->symtree->n.sym == var)
5060 {
5061 v = e;
5062 break;
5063 }
5064 else if ((c = is_conversion (e, true)) != NULL)
5065 q = &e->value.function.actual->expr;
5066 else if (e->expr_type != EXPR_OP
5067 || (e->value.op.op != op
5068 && e->value.op.op != alt_op)
5069 || e->rank != 0)
5070 break;
5071 else
5072 {
5073 p = q;
5074 q = &e->value.op.op1;
5075 }
5076
5077 if (v == NULL)
5078 {
5079 gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
5080 "or var = expr op var at %L", &expr2->where);
5081 return;
5082 }
5083
5084 if (p != NULL)
5085 {
5086 e = *p;
5087 switch (e->value.op.op)
5088 {
5089 case INTRINSIC_MINUS:
5090 case INTRINSIC_DIVIDE:
5091 case INTRINSIC_EQV:
5092 case INTRINSIC_NEQV:
5093 gfc_error ("!$OMP ATOMIC var = var op expr not "
5094 "mathematically equivalent to var = var op "
5095 "(expr) at %L", &expr2->where);
5096 break;
5097 default:
5098 break;
5099 }
5100
5101 /* Canonicalize into var = var op (expr). */
5102 *p = e->value.op.op2;
5103 e->value.op.op2 = expr2;
5104 e->ts = expr2->ts;
5105 if (code->expr2 == expr2)
5106 code->expr2 = expr2 = e;
5107 else
5108 code->expr2->value.function.actual->expr = expr2 = e;
5109
5110 if (!gfc_compare_types (&expr2->value.op.op1->ts, &expr2->ts))
5111 {
5112 for (p = &expr2->value.op.op1; *p != v;
5113 p = &(*p)->value.function.actual->expr)
5114 ;
5115 *p = NULL;
5116 gfc_free_expr (expr2->value.op.op1);
5117 expr2->value.op.op1 = v;
5118 gfc_convert_type (v, &expr2->ts, 2);
5119 }
5120 }
5121 }
5122
5123 if (e->rank != 0 || expr_references_sym (code->expr2, var, v))
5124 {
5125 gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
5126 "must be scalar and cannot reference var at %L",
5127 &expr2->where);
5128 return;
5129 }
5130 }
5131 else if (expr2->expr_type == EXPR_FUNCTION
5132 && expr2->value.function.isym != NULL
5133 && expr2->value.function.esym == NULL
5134 && expr2->value.function.actual != NULL
5135 && expr2->value.function.actual->next != NULL)
5136 {
5137 gfc_actual_arglist *arg, *var_arg;
5138
5139 switch (expr2->value.function.isym->id)
5140 {
5141 case GFC_ISYM_MIN:
5142 case GFC_ISYM_MAX:
5143 break;
5144 case GFC_ISYM_IAND:
5145 case GFC_ISYM_IOR:
5146 case GFC_ISYM_IEOR:
5147 if (expr2->value.function.actual->next->next != NULL)
5148 {
5149 gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
5150 "or IEOR must have two arguments at %L",
5151 &expr2->where);
5152 return;
5153 }
5154 break;
5155 default:
5156 gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
5157 "MIN, MAX, IAND, IOR or IEOR at %L",
5158 &expr2->where);
5159 return;
5160 }
5161
5162 var_arg = NULL;
5163 for (arg = expr2->value.function.actual; arg; arg = arg->next)
5164 {
5165 if ((arg == expr2->value.function.actual
5166 || (var_arg == NULL && arg->next == NULL))
5167 && arg->expr->expr_type == EXPR_VARIABLE
5168 && arg->expr->symtree != NULL
5169 && arg->expr->symtree->n.sym == var)
5170 var_arg = arg;
5171 else if (expr_references_sym (arg->expr, var, NULL))
5172 {
5173 gfc_error ("!$OMP ATOMIC intrinsic arguments except one must "
5174 "not reference %qs at %L",
5175 var->name, &arg->expr->where);
5176 return;
5177 }
5178 if (arg->expr->rank != 0)
5179 {
5180 gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
5181 "at %L", &arg->expr->where);
5182 return;
5183 }
5184 }
5185
5186 if (var_arg == NULL)
5187 {
5188 gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
5189 "be %qs at %L", var->name, &expr2->where);
5190 return;
5191 }
5192
5193 if (var_arg != expr2->value.function.actual)
5194 {
5195 /* Canonicalize, so that var comes first. */
5196 gcc_assert (var_arg->next == NULL);
5197 for (arg = expr2->value.function.actual;
5198 arg->next != var_arg; arg = arg->next)
5199 ;
5200 var_arg->next = expr2->value.function.actual;
5201 expr2->value.function.actual = var_arg;
5202 arg->next = NULL;
5203 }
5204 }
5205 else
5206 gfc_error ("!$OMP ATOMIC assignment must have an operator or "
5207 "intrinsic on right hand side at %L", &expr2->where);
5208
5209 if (aop == GFC_OMP_ATOMIC_CAPTURE && code->next)
5210 {
5211 code = code->next;
5212 if (code->expr1->expr_type != EXPR_VARIABLE
5213 || code->expr1->symtree == NULL
5214 || code->expr1->rank != 0
5215 || (code->expr1->ts.type != BT_INTEGER
5216 && code->expr1->ts.type != BT_REAL
5217 && code->expr1->ts.type != BT_COMPLEX
5218 && code->expr1->ts.type != BT_LOGICAL))
5219 {
5220 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must set "
5221 "a scalar variable of intrinsic type at %L",
5222 &code->expr1->where);
5223 return;
5224 }
5225
5226 expr2 = is_conversion (code->expr2, false);
5227 if (expr2 == NULL)
5228 {
5229 expr2 = is_conversion (code->expr2, true);
5230 if (expr2 == NULL)
5231 expr2 = code->expr2;
5232 }
5233
5234 if (expr2->expr_type != EXPR_VARIABLE
5235 || expr2->symtree == NULL
5236 || expr2->rank != 0
5237 || (expr2->ts.type != BT_INTEGER
5238 && expr2->ts.type != BT_REAL
5239 && expr2->ts.type != BT_COMPLEX
5240 && expr2->ts.type != BT_LOGICAL))
5241 {
5242 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read "
5243 "from a scalar variable of intrinsic type at %L",
5244 &expr2->where);
5245 return;
5246 }
5247 if (expr2->symtree->n.sym != var)
5248 {
5249 gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
5250 "different variable than update statement writes "
5251 "into at %L", &expr2->where);
5252 return;
5253 }
5254 }
5255 }
5256
5257
5258 struct fortran_omp_context
5259 {
5260 gfc_code *code;
5261 hash_set<gfc_symbol *> *sharing_clauses;
5262 hash_set<gfc_symbol *> *private_iterators;
5263 struct fortran_omp_context *previous;
5264 bool is_openmp;
5265 } *omp_current_ctx;
5266 static gfc_code *omp_current_do_code;
5267 static int omp_current_do_collapse;
5268
5269 void
5270 gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
5271 {
5272 if (code->block->next && code->block->next->op == EXEC_DO)
5273 {
5274 int i;
5275 gfc_code *c;
5276
5277 omp_current_do_code = code->block->next;
5278 if (code->ext.omp_clauses->orderedc)
5279 omp_current_do_collapse = code->ext.omp_clauses->orderedc;
5280 else
5281 omp_current_do_collapse = code->ext.omp_clauses->collapse;
5282 for (i = 1, c = omp_current_do_code; i < omp_current_do_collapse; i++)
5283 {
5284 c = c->block;
5285 if (c->op != EXEC_DO || c->next == NULL)
5286 break;
5287 c = c->next;
5288 if (c->op != EXEC_DO)
5289 break;
5290 }
5291 if (i < omp_current_do_collapse || omp_current_do_collapse <= 0)
5292 omp_current_do_collapse = 1;
5293 }
5294 gfc_resolve_blocks (code->block, ns);
5295 omp_current_do_collapse = 0;
5296 omp_current_do_code = NULL;
5297 }
5298
5299
5300 void
5301 gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns)
5302 {
5303 struct fortran_omp_context ctx;
5304 gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
5305 gfc_omp_namelist *n;
5306 int list;
5307
5308 ctx.code = code;
5309 ctx.sharing_clauses = new hash_set<gfc_symbol *>;
5310 ctx.private_iterators = new hash_set<gfc_symbol *>;
5311 ctx.previous = omp_current_ctx;
5312 ctx.is_openmp = true;
5313 omp_current_ctx = &ctx;
5314
5315 for (list = 0; list < OMP_LIST_NUM; list++)
5316 switch (list)
5317 {
5318 case OMP_LIST_SHARED:
5319 case OMP_LIST_PRIVATE:
5320 case OMP_LIST_FIRSTPRIVATE:
5321 case OMP_LIST_LASTPRIVATE:
5322 case OMP_LIST_REDUCTION:
5323 case OMP_LIST_LINEAR:
5324 for (n = omp_clauses->lists[list]; n; n = n->next)
5325 ctx.sharing_clauses->add (n->sym);
5326 break;
5327 default:
5328 break;
5329 }
5330
5331 switch (code->op)
5332 {
5333 case EXEC_OMP_PARALLEL_DO:
5334 case EXEC_OMP_PARALLEL_DO_SIMD:
5335 case EXEC_OMP_TARGET_PARALLEL_DO:
5336 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
5337 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
5338 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
5339 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5340 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
5341 case EXEC_OMP_TEAMS_DISTRIBUTE:
5342 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
5343 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5344 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
5345 gfc_resolve_omp_do_blocks (code, ns);
5346 break;
5347 default:
5348 gfc_resolve_blocks (code->block, ns);
5349 }
5350
5351 omp_current_ctx = ctx.previous;
5352 delete ctx.sharing_clauses;
5353 delete ctx.private_iterators;
5354 }
5355
5356
5357 /* Save and clear openmp.c private state. */
5358
5359 void
5360 gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *state)
5361 {
5362 state->ptrs[0] = omp_current_ctx;
5363 state->ptrs[1] = omp_current_do_code;
5364 state->ints[0] = omp_current_do_collapse;
5365 omp_current_ctx = NULL;
5366 omp_current_do_code = NULL;
5367 omp_current_do_collapse = 0;
5368 }
5369
5370
5371 /* Restore openmp.c private state from the saved state. */
5372
5373 void
5374 gfc_omp_restore_state (struct gfc_omp_saved_state *state)
5375 {
5376 omp_current_ctx = (struct fortran_omp_context *) state->ptrs[0];
5377 omp_current_do_code = (gfc_code *) state->ptrs[1];
5378 omp_current_do_collapse = state->ints[0];
5379 }
5380
5381
5382 /* Note a DO iterator variable. This is special in !$omp parallel
5383 construct, where they are predetermined private. */
5384
5385 void
5386 gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym)
5387 {
5388 int i = omp_current_do_collapse;
5389 gfc_code *c = omp_current_do_code;
5390
5391 if (sym->attr.threadprivate)
5392 return;
5393
5394 /* !$omp do and !$omp parallel do iteration variable is predetermined
5395 private just in the !$omp do resp. !$omp parallel do construct,
5396 with no implications for the outer parallel constructs. */
5397
5398 while (i-- >= 1)
5399 {
5400 if (code == c)
5401 return;
5402
5403 c = c->block->next;
5404 }
5405
5406 if (omp_current_ctx == NULL)
5407 return;
5408
5409 /* An openacc context may represent a data clause. Abort if so. */
5410 if (!omp_current_ctx->is_openmp && !oacc_is_loop (omp_current_ctx->code))
5411 return;
5412
5413 if (omp_current_ctx->is_openmp
5414 && omp_current_ctx->sharing_clauses->contains (sym))
5415 return;
5416
5417 if (! omp_current_ctx->private_iterators->add (sym))
5418 {
5419 gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses;
5420 gfc_omp_namelist *p;
5421
5422 p = gfc_get_omp_namelist ();
5423 p->sym = sym;
5424 p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
5425 omp_clauses->lists[OMP_LIST_PRIVATE] = p;
5426 }
5427 }
5428
5429
5430 static void
5431 resolve_omp_do (gfc_code *code)
5432 {
5433 gfc_code *do_code, *c;
5434 int list, i, collapse;
5435 gfc_omp_namelist *n;
5436 gfc_symbol *dovar;
5437 const char *name;
5438 bool is_simd = false;
5439
5440 switch (code->op)
5441 {
5442 case EXEC_OMP_DISTRIBUTE: name = "!$OMP DISTRIBUTE"; break;
5443 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
5444 name = "!$OMP DISTRIBUTE PARALLEL DO";
5445 break;
5446 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
5447 name = "!$OMP DISTRIBUTE PARALLEL DO SIMD";
5448 is_simd = true;
5449 break;
5450 case EXEC_OMP_DISTRIBUTE_SIMD:
5451 name = "!$OMP DISTRIBUTE SIMD";
5452 is_simd = true;
5453 break;
5454 case EXEC_OMP_DO: name = "!$OMP DO"; break;
5455 case EXEC_OMP_DO_SIMD: name = "!$OMP DO SIMD"; is_simd = true; break;
5456 case EXEC_OMP_PARALLEL_DO: name = "!$OMP PARALLEL DO"; break;
5457 case EXEC_OMP_PARALLEL_DO_SIMD:
5458 name = "!$OMP PARALLEL DO SIMD";
5459 is_simd = true;
5460 break;
5461 case EXEC_OMP_SIMD: name = "!$OMP SIMD"; is_simd = true; break;
5462 case EXEC_OMP_TARGET_PARALLEL_DO: name = "!$OMP TARGET PARALLEL DO"; break;
5463 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
5464 name = "!$OMP TARGET PARALLEL DO SIMD";
5465 is_simd = true;
5466 break;
5467 case EXEC_OMP_TARGET_SIMD:
5468 name = "!$OMP TARGET SIMD";
5469 is_simd = true;
5470 break;
5471 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
5472 name = "!$OMP TARGET TEAMS DISTRIBUTE";
5473 break;
5474 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
5475 name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
5476 break;
5477 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5478 name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
5479 is_simd = true;
5480 break;
5481 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
5482 name = "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
5483 is_simd = true;
5484 break;
5485 case EXEC_OMP_TASKLOOP: name = "!$OMP TASKLOOP"; break;
5486 case EXEC_OMP_TASKLOOP_SIMD:
5487 name = "!$OMP TASKLOOP SIMD";
5488 is_simd = true;
5489 break;
5490 case EXEC_OMP_TEAMS_DISTRIBUTE: name = "!$OMP TEAMS DISTRIBUTE"; break;
5491 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
5492 name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
5493 break;
5494 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5495 name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
5496 is_simd = true;
5497 break;
5498 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
5499 name = "!$OMP TEAMS DISTRIBUTE SIMD";
5500 is_simd = true;
5501 break;
5502 default: gcc_unreachable ();
5503 }
5504
5505 if (code->ext.omp_clauses)
5506 resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
5507
5508 do_code = code->block->next;
5509 if (code->ext.omp_clauses->orderedc)
5510 collapse = code->ext.omp_clauses->orderedc;
5511 else
5512 {
5513 collapse = code->ext.omp_clauses->collapse;
5514 if (collapse <= 0)
5515 collapse = 1;
5516 }
5517 for (i = 1; i <= collapse; i++)
5518 {
5519 if (do_code->op == EXEC_DO_WHILE)
5520 {
5521 gfc_error ("%s cannot be a DO WHILE or DO without loop control "
5522 "at %L", name, &do_code->loc);
5523 break;
5524 }
5525 if (do_code->op == EXEC_DO_CONCURRENT)
5526 {
5527 gfc_error ("%s cannot be a DO CONCURRENT loop at %L", name,
5528 &do_code->loc);
5529 break;
5530 }
5531 gcc_assert (do_code->op == EXEC_DO);
5532 if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
5533 gfc_error ("%s iteration variable must be of type integer at %L",
5534 name, &do_code->loc);
5535 dovar = do_code->ext.iterator->var->symtree->n.sym;
5536 if (dovar->attr.threadprivate)
5537 gfc_error ("%s iteration variable must not be THREADPRIVATE "
5538 "at %L", name, &do_code->loc);
5539 if (code->ext.omp_clauses)
5540 for (list = 0; list < OMP_LIST_NUM; list++)
5541 if (!is_simd
5542 ? (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE)
5543 : code->ext.omp_clauses->collapse > 1
5544 ? (list != OMP_LIST_LASTPRIVATE)
5545 : (list != OMP_LIST_LINEAR))
5546 for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
5547 if (dovar == n->sym)
5548 {
5549 if (!is_simd)
5550 gfc_error ("%s iteration variable present on clause "
5551 "other than PRIVATE or LASTPRIVATE at %L",
5552 name, &do_code->loc);
5553 else if (code->ext.omp_clauses->collapse > 1)
5554 gfc_error ("%s iteration variable present on clause "
5555 "other than LASTPRIVATE at %L",
5556 name, &do_code->loc);
5557 else
5558 gfc_error ("%s iteration variable present on clause "
5559 "other than LINEAR at %L",
5560 name, &do_code->loc);
5561 break;
5562 }
5563 if (i > 1)
5564 {
5565 gfc_code *do_code2 = code->block->next;
5566 int j;
5567
5568 for (j = 1; j < i; j++)
5569 {
5570 gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
5571 if (dovar == ivar
5572 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
5573 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
5574 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
5575 {
5576 gfc_error ("%s collapsed loops don't form rectangular "
5577 "iteration space at %L", name, &do_code->loc);
5578 break;
5579 }
5580 if (j < i)
5581 break;
5582 do_code2 = do_code2->block->next;
5583 }
5584 }
5585 if (i == collapse)
5586 break;
5587 for (c = do_code->next; c; c = c->next)
5588 if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
5589 {
5590 gfc_error ("collapsed %s loops not perfectly nested at %L",
5591 name, &c->loc);
5592 break;
5593 }
5594 if (c)
5595 break;
5596 do_code = do_code->block;
5597 if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE)
5598 {
5599 gfc_error ("not enough DO loops for collapsed %s at %L",
5600 name, &code->loc);
5601 break;
5602 }
5603 do_code = do_code->next;
5604 if (do_code == NULL
5605 || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE))
5606 {
5607 gfc_error ("not enough DO loops for collapsed %s at %L",
5608 name, &code->loc);
5609 break;
5610 }
5611 }
5612 }
5613
5614 static bool
5615 oacc_is_parallel (gfc_code *code)
5616 {
5617 return code->op == EXEC_OACC_PARALLEL || code->op == EXEC_OACC_PARALLEL_LOOP;
5618 }
5619
5620 static bool
5621 oacc_is_kernels (gfc_code *code)
5622 {
5623 return code->op == EXEC_OACC_KERNELS || code->op == EXEC_OACC_KERNELS_LOOP;
5624 }
5625
5626 static gfc_statement
5627 omp_code_to_statement (gfc_code *code)
5628 {
5629 switch (code->op)
5630 {
5631 case EXEC_OMP_PARALLEL:
5632 return ST_OMP_PARALLEL;
5633 case EXEC_OMP_PARALLEL_SECTIONS:
5634 return ST_OMP_PARALLEL_SECTIONS;
5635 case EXEC_OMP_SECTIONS:
5636 return ST_OMP_SECTIONS;
5637 case EXEC_OMP_ORDERED:
5638 return ST_OMP_ORDERED;
5639 case EXEC_OMP_CRITICAL:
5640 return ST_OMP_CRITICAL;
5641 case EXEC_OMP_MASTER:
5642 return ST_OMP_MASTER;
5643 case EXEC_OMP_SINGLE:
5644 return ST_OMP_SINGLE;
5645 case EXEC_OMP_TASK:
5646 return ST_OMP_TASK;
5647 case EXEC_OMP_WORKSHARE:
5648 return ST_OMP_WORKSHARE;
5649 case EXEC_OMP_PARALLEL_WORKSHARE:
5650 return ST_OMP_PARALLEL_WORKSHARE;
5651 case EXEC_OMP_DO:
5652 return ST_OMP_DO;
5653 default:
5654 gcc_unreachable ();
5655 }
5656 }
5657
5658 static gfc_statement
5659 oacc_code_to_statement (gfc_code *code)
5660 {
5661 switch (code->op)
5662 {
5663 case EXEC_OACC_PARALLEL:
5664 return ST_OACC_PARALLEL;
5665 case EXEC_OACC_KERNELS:
5666 return ST_OACC_KERNELS;
5667 case EXEC_OACC_DATA:
5668 return ST_OACC_DATA;
5669 case EXEC_OACC_HOST_DATA:
5670 return ST_OACC_HOST_DATA;
5671 case EXEC_OACC_PARALLEL_LOOP:
5672 return ST_OACC_PARALLEL_LOOP;
5673 case EXEC_OACC_KERNELS_LOOP:
5674 return ST_OACC_KERNELS_LOOP;
5675 case EXEC_OACC_LOOP:
5676 return ST_OACC_LOOP;
5677 case EXEC_OACC_ATOMIC:
5678 return ST_OACC_ATOMIC;
5679 default:
5680 gcc_unreachable ();
5681 }
5682 }
5683
5684 static void
5685 resolve_oacc_directive_inside_omp_region (gfc_code *code)
5686 {
5687 if (omp_current_ctx != NULL && omp_current_ctx->is_openmp)
5688 {
5689 gfc_statement st = omp_code_to_statement (omp_current_ctx->code);
5690 gfc_statement oacc_st = oacc_code_to_statement (code);
5691 gfc_error ("The %s directive cannot be specified within "
5692 "a %s region at %L", gfc_ascii_statement (oacc_st),
5693 gfc_ascii_statement (st), &code->loc);
5694 }
5695 }
5696
5697 static void
5698 resolve_omp_directive_inside_oacc_region (gfc_code *code)
5699 {
5700 if (omp_current_ctx != NULL && !omp_current_ctx->is_openmp)
5701 {
5702 gfc_statement st = oacc_code_to_statement (omp_current_ctx->code);
5703 gfc_statement omp_st = omp_code_to_statement (code);
5704 gfc_error ("The %s directive cannot be specified within "
5705 "a %s region at %L", gfc_ascii_statement (omp_st),
5706 gfc_ascii_statement (st), &code->loc);
5707 }
5708 }
5709
5710
5711 static void
5712 resolve_oacc_nested_loops (gfc_code *code, gfc_code* do_code, int collapse,
5713 const char *clause)
5714 {
5715 gfc_symbol *dovar;
5716 gfc_code *c;
5717 int i;
5718
5719 for (i = 1; i <= collapse; i++)
5720 {
5721 if (do_code->op == EXEC_DO_WHILE)
5722 {
5723 gfc_error ("!$ACC LOOP cannot be a DO WHILE or DO without loop control "
5724 "at %L", &do_code->loc);
5725 break;
5726 }
5727 gcc_assert (do_code->op == EXEC_DO || do_code->op == EXEC_DO_CONCURRENT);
5728 if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
5729 gfc_error ("!$ACC LOOP iteration variable must be of type integer at %L",
5730 &do_code->loc);
5731 dovar = do_code->ext.iterator->var->symtree->n.sym;
5732 if (i > 1)
5733 {
5734 gfc_code *do_code2 = code->block->next;
5735 int j;
5736
5737 for (j = 1; j < i; j++)
5738 {
5739 gfc_symbol *ivar = do_code2->ext.iterator->var->symtree->n.sym;
5740 if (dovar == ivar
5741 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->start)
5742 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
5743 || gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
5744 {
5745 gfc_error ("!$ACC LOOP %s loops don't form rectangular iteration space at %L",
5746 clause, &do_code->loc);
5747 break;
5748 }
5749 if (j < i)
5750 break;
5751 do_code2 = do_code2->block->next;
5752 }
5753 }
5754 if (i == collapse)
5755 break;
5756 for (c = do_code->next; c; c = c->next)
5757 if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
5758 {
5759 gfc_error ("%s !$ACC LOOP loops not perfectly nested at %L",
5760 clause, &c->loc);
5761 break;
5762 }
5763 if (c)
5764 break;
5765 do_code = do_code->block;
5766 if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
5767 && do_code->op != EXEC_DO_CONCURRENT)
5768 {
5769 gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
5770 clause, &code->loc);
5771 break;
5772 }
5773 do_code = do_code->next;
5774 if (do_code == NULL
5775 || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE
5776 && do_code->op != EXEC_DO_CONCURRENT))
5777 {
5778 gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
5779 clause, &code->loc);
5780 break;
5781 }
5782 }
5783 }
5784
5785
5786 static void
5787 resolve_oacc_params_in_parallel (gfc_code *code, const char *clause,
5788 const char *arg)
5789 {
5790 fortran_omp_context *c;
5791
5792 if (oacc_is_parallel (code))
5793 gfc_error ("!$ACC LOOP %s in PARALLEL region doesn't allow "
5794 "%s arguments at %L", clause, arg, &code->loc);
5795 for (c = omp_current_ctx; c; c = c->previous)
5796 {
5797 if (oacc_is_loop (c->code))
5798 break;
5799 if (oacc_is_parallel (c->code))
5800 gfc_error ("!$ACC LOOP %s in PARALLEL region doesn't allow "
5801 "%s arguments at %L", clause, arg, &code->loc);
5802 }
5803 }
5804
5805
5806 static void
5807 resolve_oacc_loop_blocks (gfc_code *code)
5808 {
5809 fortran_omp_context *c;
5810
5811 if (!oacc_is_loop (code))
5812 return;
5813
5814 if (code->op == EXEC_OACC_LOOP)
5815 for (c = omp_current_ctx; c; c = c->previous)
5816 {
5817 if (oacc_is_loop (c->code))
5818 {
5819 if (code->ext.omp_clauses->gang)
5820 {
5821 if (c->code->ext.omp_clauses->gang)
5822 gfc_error ("Loop parallelized across gangs is not allowed "
5823 "inside another loop parallelized across gangs at %L",
5824 &code->loc);
5825 if (c->code->ext.omp_clauses->worker)
5826 gfc_error ("Loop parallelized across gangs is not allowed "
5827 "inside loop parallelized across workers at %L",
5828 &code->loc);
5829 if (c->code->ext.omp_clauses->vector)
5830 gfc_error ("Loop parallelized across gangs is not allowed "
5831 "inside loop parallelized across workers at %L",
5832 &code->loc);
5833 }
5834 if (code->ext.omp_clauses->worker)
5835 {
5836 if (c->code->ext.omp_clauses->worker)
5837 gfc_error ("Loop parallelized across workers is not allowed "
5838 "inside another loop parallelized across workers at %L",
5839 &code->loc);
5840 if (c->code->ext.omp_clauses->vector)
5841 gfc_error ("Loop parallelized across workers is not allowed "
5842 "inside another loop parallelized across vectors at %L",
5843 &code->loc);
5844 }
5845 if (code->ext.omp_clauses->vector)
5846 if (c->code->ext.omp_clauses->vector)
5847 gfc_error ("Loop parallelized across vectors is not allowed "
5848 "inside another loop parallelized across vectors at %L",
5849 &code->loc);
5850 }
5851
5852 if (oacc_is_parallel (c->code) || oacc_is_kernels (c->code))
5853 break;
5854 }
5855
5856 if (code->ext.omp_clauses->seq)
5857 {
5858 if (code->ext.omp_clauses->independent)
5859 gfc_error ("Clause SEQ conflicts with INDEPENDENT at %L", &code->loc);
5860 if (code->ext.omp_clauses->gang)
5861 gfc_error ("Clause SEQ conflicts with GANG at %L", &code->loc);
5862 if (code->ext.omp_clauses->worker)
5863 gfc_error ("Clause SEQ conflicts with WORKER at %L", &code->loc);
5864 if (code->ext.omp_clauses->vector)
5865 gfc_error ("Clause SEQ conflicts with VECTOR at %L", &code->loc);
5866 if (code->ext.omp_clauses->par_auto)
5867 gfc_error ("Clause SEQ conflicts with AUTO at %L", &code->loc);
5868 }
5869 if (code->ext.omp_clauses->par_auto)
5870 {
5871 if (code->ext.omp_clauses->gang)
5872 gfc_error ("Clause AUTO conflicts with GANG at %L", &code->loc);
5873 if (code->ext.omp_clauses->worker)
5874 gfc_error ("Clause AUTO conflicts with WORKER at %L", &code->loc);
5875 if (code->ext.omp_clauses->vector)
5876 gfc_error ("Clause AUTO conflicts with VECTOR at %L", &code->loc);
5877 }
5878 if (code->ext.omp_clauses->tile_list && code->ext.omp_clauses->gang
5879 && code->ext.omp_clauses->worker && code->ext.omp_clauses->vector)
5880 gfc_error ("Tiled loop cannot be parallelized across gangs, workers and "
5881 "vectors at the same time at %L", &code->loc);
5882
5883 if (code->ext.omp_clauses->gang
5884 && code->ext.omp_clauses->gang_num_expr)
5885 resolve_oacc_params_in_parallel (code, "GANG", "num");
5886
5887 if (code->ext.omp_clauses->worker
5888 && code->ext.omp_clauses->worker_expr)
5889 resolve_oacc_params_in_parallel (code, "WORKER", "num");
5890
5891 if (code->ext.omp_clauses->vector
5892 && code->ext.omp_clauses->vector_expr)
5893 resolve_oacc_params_in_parallel (code, "VECTOR", "length");
5894
5895 if (code->ext.omp_clauses->tile_list)
5896 {
5897 gfc_expr_list *el;
5898 int num = 0;
5899 for (el = code->ext.omp_clauses->tile_list; el; el = el->next)
5900 {
5901 num++;
5902 if (el->expr == NULL)
5903 {
5904 /* NULL expressions are used to represent '*' arguments.
5905 Convert those to a 0 expressions. */
5906 el->expr = gfc_get_constant_expr (BT_INTEGER,
5907 gfc_default_integer_kind,
5908 &code->loc);
5909 mpz_set_si (el->expr->value.integer, 0);
5910 }
5911 else
5912 {
5913 resolve_positive_int_expr (el->expr, "TILE");
5914 if (el->expr->expr_type != EXPR_CONSTANT)
5915 gfc_error ("TILE requires constant expression at %L",
5916 &code->loc);
5917 }
5918 }
5919 resolve_oacc_nested_loops (code, code->block->next, num, "tiled");
5920 }
5921 }
5922
5923
5924 void
5925 gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns)
5926 {
5927 fortran_omp_context ctx;
5928
5929 resolve_oacc_loop_blocks (code);
5930
5931 ctx.code = code;
5932 ctx.sharing_clauses = NULL;
5933 ctx.private_iterators = new hash_set<gfc_symbol *>;
5934 ctx.previous = omp_current_ctx;
5935 ctx.is_openmp = false;
5936 omp_current_ctx = &ctx;
5937
5938 gfc_resolve_blocks (code->block, ns);
5939
5940 omp_current_ctx = ctx.previous;
5941 delete ctx.private_iterators;
5942 }
5943
5944
5945 static void
5946 resolve_oacc_loop (gfc_code *code)
5947 {
5948 gfc_code *do_code;
5949 int collapse;
5950
5951 if (code->ext.omp_clauses)
5952 resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
5953
5954 do_code = code->block->next;
5955 collapse = code->ext.omp_clauses->collapse;
5956
5957 if (collapse <= 0)
5958 collapse = 1;
5959 resolve_oacc_nested_loops (code, do_code, collapse, "collapsed");
5960 }
5961
5962 void
5963 gfc_resolve_oacc_declare (gfc_namespace *ns)
5964 {
5965 int list;
5966 gfc_omp_namelist *n;
5967 gfc_oacc_declare *oc;
5968
5969 if (ns->oacc_declare == NULL)
5970 return;
5971
5972 for (oc = ns->oacc_declare; oc; oc = oc->next)
5973 {
5974 for (list = 0; list < OMP_LIST_NUM; list++)
5975 for (n = oc->clauses->lists[list]; n; n = n->next)
5976 {
5977 n->sym->mark = 0;
5978 if (n->sym->attr.flavor == FL_PARAMETER)
5979 {
5980 gfc_error ("PARAMETER object %qs is not allowed at %L",
5981 n->sym->name, &oc->loc);
5982 continue;
5983 }
5984
5985 if (n->expr && n->expr->ref->type == REF_ARRAY)
5986 {
5987 gfc_error ("Array sections: %qs not allowed in"
5988 " $!ACC DECLARE at %L", n->sym->name, &oc->loc);
5989 continue;
5990 }
5991 }
5992
5993 for (n = oc->clauses->lists[OMP_LIST_DEVICE_RESIDENT]; n; n = n->next)
5994 check_array_not_assumed (n->sym, oc->loc, "DEVICE_RESIDENT");
5995 }
5996
5997 for (oc = ns->oacc_declare; oc; oc = oc->next)
5998 {
5999 for (list = 0; list < OMP_LIST_NUM; list++)
6000 for (n = oc->clauses->lists[list]; n; n = n->next)
6001 {
6002 if (n->sym->mark)
6003 {
6004 gfc_error ("Symbol %qs present on multiple clauses at %L",
6005 n->sym->name, &oc->loc);
6006 continue;
6007 }
6008 else
6009 n->sym->mark = 1;
6010 }
6011 }
6012
6013 for (oc = ns->oacc_declare; oc; oc = oc->next)
6014 {
6015 for (list = 0; list < OMP_LIST_NUM; list++)
6016 for (n = oc->clauses->lists[list]; n; n = n->next)
6017 n->sym->mark = 0;
6018 }
6019 }
6020
6021 void
6022 gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
6023 {
6024 resolve_oacc_directive_inside_omp_region (code);
6025
6026 switch (code->op)
6027 {
6028 case EXEC_OACC_PARALLEL:
6029 case EXEC_OACC_KERNELS:
6030 case EXEC_OACC_DATA:
6031 case EXEC_OACC_HOST_DATA:
6032 case EXEC_OACC_UPDATE:
6033 case EXEC_OACC_ENTER_DATA:
6034 case EXEC_OACC_EXIT_DATA:
6035 case EXEC_OACC_WAIT:
6036 case EXEC_OACC_CACHE:
6037 resolve_omp_clauses (code, code->ext.omp_clauses, NULL, true);
6038 break;
6039 case EXEC_OACC_PARALLEL_LOOP:
6040 case EXEC_OACC_KERNELS_LOOP:
6041 case EXEC_OACC_LOOP:
6042 resolve_oacc_loop (code);
6043 break;
6044 case EXEC_OACC_ATOMIC:
6045 resolve_omp_atomic (code);
6046 break;
6047 default:
6048 break;
6049 }
6050 }
6051
6052
6053 /* Resolve OpenMP directive clauses and check various requirements
6054 of each directive. */
6055
6056 void
6057 gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
6058 {
6059 resolve_omp_directive_inside_oacc_region (code);
6060
6061 if (code->op != EXEC_OMP_ATOMIC)
6062 gfc_maybe_initialize_eh ();
6063
6064 switch (code->op)
6065 {
6066 case EXEC_OMP_DISTRIBUTE:
6067 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
6068 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
6069 case EXEC_OMP_DISTRIBUTE_SIMD:
6070 case EXEC_OMP_DO:
6071 case EXEC_OMP_DO_SIMD:
6072 case EXEC_OMP_PARALLEL_DO:
6073 case EXEC_OMP_PARALLEL_DO_SIMD:
6074 case EXEC_OMP_SIMD:
6075 case EXEC_OMP_TARGET_PARALLEL_DO:
6076 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
6077 case EXEC_OMP_TARGET_SIMD:
6078 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
6079 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
6080 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
6081 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
6082 case EXEC_OMP_TASKLOOP:
6083 case EXEC_OMP_TASKLOOP_SIMD:
6084 case EXEC_OMP_TEAMS_DISTRIBUTE:
6085 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
6086 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
6087 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
6088 resolve_omp_do (code);
6089 break;
6090 case EXEC_OMP_CANCEL:
6091 case EXEC_OMP_PARALLEL_WORKSHARE:
6092 case EXEC_OMP_PARALLEL:
6093 case EXEC_OMP_PARALLEL_SECTIONS:
6094 case EXEC_OMP_SECTIONS:
6095 case EXEC_OMP_SINGLE:
6096 case EXEC_OMP_TARGET:
6097 case EXEC_OMP_TARGET_DATA:
6098 case EXEC_OMP_TARGET_ENTER_DATA:
6099 case EXEC_OMP_TARGET_EXIT_DATA:
6100 case EXEC_OMP_TARGET_PARALLEL:
6101 case EXEC_OMP_TARGET_TEAMS:
6102 case EXEC_OMP_TASK:
6103 case EXEC_OMP_TEAMS:
6104 case EXEC_OMP_WORKSHARE:
6105 if (code->ext.omp_clauses)
6106 resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
6107 break;
6108 case EXEC_OMP_TARGET_UPDATE:
6109 if (code->ext.omp_clauses)
6110 resolve_omp_clauses (code, code->ext.omp_clauses, NULL);
6111 if (code->ext.omp_clauses == NULL
6112 || (code->ext.omp_clauses->lists[OMP_LIST_TO] == NULL
6113 && code->ext.omp_clauses->lists[OMP_LIST_FROM] == NULL))
6114 gfc_error ("OMP TARGET UPDATE at %L requires at least one TO or "
6115 "FROM clause", &code->loc);
6116 break;
6117 case EXEC_OMP_ATOMIC:
6118 resolve_omp_atomic (code);
6119 break;
6120 default:
6121 break;
6122 }
6123 }
6124
6125 /* Resolve !$omp declare simd constructs in NS. */
6126
6127 void
6128 gfc_resolve_omp_declare_simd (gfc_namespace *ns)
6129 {
6130 gfc_omp_declare_simd *ods;
6131
6132 for (ods = ns->omp_declare_simd; ods; ods = ods->next)
6133 {
6134 if (ods->proc_name != NULL
6135 && ods->proc_name != ns->proc_name)
6136 gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure "
6137 "%qs at %L", ns->proc_name->name, &ods->where);
6138 if (ods->clauses)
6139 resolve_omp_clauses (NULL, ods->clauses, ns);
6140 }
6141 }
6142
6143 struct omp_udr_callback_data
6144 {
6145 gfc_omp_udr *omp_udr;
6146 bool is_initializer;
6147 };
6148
6149 static int
6150 omp_udr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
6151 void *data)
6152 {
6153 struct omp_udr_callback_data *cd = (struct omp_udr_callback_data *) data;
6154 if ((*e)->expr_type == EXPR_VARIABLE)
6155 {
6156 if (cd->is_initializer)
6157 {
6158 if ((*e)->symtree->n.sym != cd->omp_udr->omp_priv
6159 && (*e)->symtree->n.sym != cd->omp_udr->omp_orig)
6160 gfc_error ("Variable other than OMP_PRIV or OMP_ORIG used in "
6161 "INITIALIZER clause of !$OMP DECLARE REDUCTION at %L",
6162 &(*e)->where);
6163 }
6164 else
6165 {
6166 if ((*e)->symtree->n.sym != cd->omp_udr->omp_out
6167 && (*e)->symtree->n.sym != cd->omp_udr->omp_in)
6168 gfc_error ("Variable other than OMP_OUT or OMP_IN used in "
6169 "combiner of !$OMP DECLARE REDUCTION at %L",
6170 &(*e)->where);
6171 }
6172 }
6173 return 0;
6174 }
6175
6176 /* Resolve !$omp declare reduction constructs. */
6177
6178 static void
6179 gfc_resolve_omp_udr (gfc_omp_udr *omp_udr)
6180 {
6181 gfc_actual_arglist *a;
6182 const char *predef_name = NULL;
6183
6184 switch (omp_udr->rop)
6185 {
6186 case OMP_REDUCTION_PLUS:
6187 case OMP_REDUCTION_TIMES:
6188 case OMP_REDUCTION_MINUS:
6189 case OMP_REDUCTION_AND:
6190 case OMP_REDUCTION_OR:
6191 case OMP_REDUCTION_EQV:
6192 case OMP_REDUCTION_NEQV:
6193 case OMP_REDUCTION_MAX:
6194 case OMP_REDUCTION_USER:
6195 break;
6196 default:
6197 gfc_error ("Invalid operator for !$OMP DECLARE REDUCTION %s at %L",
6198 omp_udr->name, &omp_udr->where);
6199 return;
6200 }
6201
6202 if (gfc_omp_udr_predef (omp_udr->rop, omp_udr->name,
6203 &omp_udr->ts, &predef_name))
6204 {
6205 if (predef_name)
6206 gfc_error_now ("Redefinition of predefined %s "
6207 "!$OMP DECLARE REDUCTION at %L",
6208 predef_name, &omp_udr->where);
6209 else
6210 gfc_error_now ("Redefinition of predefined "
6211 "!$OMP DECLARE REDUCTION at %L", &omp_udr->where);
6212 return;
6213 }
6214
6215 if (omp_udr->ts.type == BT_CHARACTER
6216 && omp_udr->ts.u.cl->length
6217 && omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
6218 {
6219 gfc_error ("CHARACTER length in !$OMP DECLARE REDUCTION %s not "
6220 "constant at %L", omp_udr->name, &omp_udr->where);
6221 return;
6222 }
6223
6224 struct omp_udr_callback_data cd;
6225 cd.omp_udr = omp_udr;
6226 cd.is_initializer = false;
6227 gfc_code_walker (&omp_udr->combiner_ns->code, gfc_dummy_code_callback,
6228 omp_udr_callback, &cd);
6229 if (omp_udr->combiner_ns->code->op == EXEC_CALL)
6230 {
6231 for (a = omp_udr->combiner_ns->code->ext.actual; a; a = a->next)
6232 if (a->expr == NULL)
6233 break;
6234 if (a)
6235 gfc_error ("Subroutine call with alternate returns in combiner "
6236 "of !$OMP DECLARE REDUCTION at %L",
6237 &omp_udr->combiner_ns->code->loc);
6238 }
6239 if (omp_udr->initializer_ns)
6240 {
6241 cd.is_initializer = true;
6242 gfc_code_walker (&omp_udr->initializer_ns->code, gfc_dummy_code_callback,
6243 omp_udr_callback, &cd);
6244 if (omp_udr->initializer_ns->code->op == EXEC_CALL)
6245 {
6246 for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
6247 if (a->expr == NULL)
6248 break;
6249 if (a)
6250 gfc_error ("Subroutine call with alternate returns in "
6251 "INITIALIZER clause of !$OMP DECLARE REDUCTION "
6252 "at %L", &omp_udr->initializer_ns->code->loc);
6253 for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
6254 if (a->expr
6255 && a->expr->expr_type == EXPR_VARIABLE
6256 && a->expr->symtree->n.sym == omp_udr->omp_priv
6257 && a->expr->ref == NULL)
6258 break;
6259 if (a == NULL)
6260 gfc_error ("One of actual subroutine arguments in INITIALIZER "
6261 "clause of !$OMP DECLARE REDUCTION must be OMP_PRIV "
6262 "at %L", &omp_udr->initializer_ns->code->loc);
6263 }
6264 }
6265 else if (omp_udr->ts.type == BT_DERIVED
6266 && !gfc_has_default_initializer (omp_udr->ts.u.derived))
6267 {
6268 gfc_error ("Missing INITIALIZER clause for !$OMP DECLARE REDUCTION "
6269 "of derived type without default initializer at %L",
6270 &omp_udr->where);
6271 return;
6272 }
6273 }
6274
6275 void
6276 gfc_resolve_omp_udrs (gfc_symtree *st)
6277 {
6278 gfc_omp_udr *omp_udr;
6279
6280 if (st == NULL)
6281 return;
6282 gfc_resolve_omp_udrs (st->left);
6283 gfc_resolve_omp_udrs (st->right);
6284 for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
6285 gfc_resolve_omp_udr (omp_udr);
6286 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org