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