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