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