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