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