1 /* OpenMP directive matching and resolving.
2 Copyright (C) 2005-2015 Free Software Foundation, Inc.
3 Contributed by Jakub Jelinek
5 This file is part of GCC.
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
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
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/>. */
23 #include "coretypes.h"
30 #include "diagnostic.h"
31 #include "gomp-constants.h"
33 /* Match an end of OpenMP directive. End of OpenMP directive is optional
34 whitespace, followed by '\n' or comment '!'. */
37 gfc_match_omp_eos (void)
42 old_loc
= gfc_current_locus
;
43 gfc_gobble_whitespace ();
45 c
= gfc_next_ascii_char ();
50 c
= gfc_next_ascii_char ();
58 gfc_current_locus
= old_loc
;
62 /* Free an omp_clauses structure. */
65 gfc_free_omp_clauses (gfc_omp_clauses
*c
)
71 gfc_free_expr (c
->if_expr
);
72 gfc_free_expr (c
->final_expr
);
73 gfc_free_expr (c
->num_threads
);
74 gfc_free_expr (c
->chunk_size
);
75 gfc_free_expr (c
->safelen_expr
);
76 gfc_free_expr (c
->simdlen_expr
);
77 gfc_free_expr (c
->num_teams
);
78 gfc_free_expr (c
->device
);
79 gfc_free_expr (c
->thread_limit
);
80 gfc_free_expr (c
->dist_chunk_size
);
81 gfc_free_expr (c
->async_expr
);
82 gfc_free_expr (c
->gang_expr
);
83 gfc_free_expr (c
->worker_expr
);
84 gfc_free_expr (c
->vector_expr
);
85 gfc_free_expr (c
->num_gangs_expr
);
86 gfc_free_expr (c
->num_workers_expr
);
87 gfc_free_expr (c
->vector_length_expr
);
88 for (i
= 0; i
< OMP_LIST_NUM
; i
++)
89 gfc_free_omp_namelist (c
->lists
[i
]);
90 gfc_free_expr_list (c
->wait_list
);
91 gfc_free_expr_list (c
->tile_list
);
95 /* Free expression list. */
97 gfc_free_expr_list (gfc_expr_list
*list
)
101 for (; list
; list
= n
)
108 /* Free an !$omp declare simd construct list. */
111 gfc_free_omp_declare_simd (gfc_omp_declare_simd
*ods
)
115 gfc_free_omp_clauses (ods
->clauses
);
121 gfc_free_omp_declare_simd_list (gfc_omp_declare_simd
*list
)
125 gfc_omp_declare_simd
*current
= list
;
127 gfc_free_omp_declare_simd (current
);
131 /* Free an !$omp declare reduction. */
134 gfc_free_omp_udr (gfc_omp_udr
*omp_udr
)
138 gfc_free_omp_udr (omp_udr
->next
);
139 gfc_free_namespace (omp_udr
->combiner_ns
);
140 if (omp_udr
->initializer_ns
)
141 gfc_free_namespace (omp_udr
->initializer_ns
);
148 gfc_find_omp_udr (gfc_namespace
*ns
, const char *name
, gfc_typespec
*ts
)
156 gfc_omp_udr
*omp_udr
;
158 st
= gfc_find_symtree (ns
->omp_udr_root
, name
);
160 for (omp_udr
= st
->n
.omp_udr
; omp_udr
; omp_udr
= omp_udr
->next
)
163 else if (gfc_compare_types (&omp_udr
->ts
, ts
))
165 if (ts
->type
== BT_CHARACTER
)
167 if (omp_udr
->ts
.u
.cl
->length
== NULL
)
169 if (ts
->u
.cl
->length
== NULL
)
171 if (gfc_compare_expr (omp_udr
->ts
.u
.cl
->length
,
179 /* Don't escape an interface block. */
180 if (ns
&& !ns
->has_import_set
181 && ns
->proc_name
&& ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
192 /* Match a variable/common block list and construct a namelist from it. */
195 gfc_match_omp_variable_list (const char *str
, gfc_omp_namelist
**list
,
196 bool allow_common
, bool *end_colon
= NULL
,
197 gfc_omp_namelist
***headp
= NULL
,
198 bool allow_sections
= false)
200 gfc_omp_namelist
*head
, *tail
, *p
;
201 locus old_loc
, cur_loc
;
202 char n
[GFC_MAX_SYMBOL_LEN
+1];
209 old_loc
= gfc_current_locus
;
217 cur_loc
= gfc_current_locus
;
218 m
= gfc_match_symbol (&sym
, 1);
224 if (allow_sections
&& gfc_peek_ascii_char () == '(')
226 gfc_current_locus
= cur_loc
;
227 m
= gfc_match_variable (&expr
, 0);
238 gfc_set_sym_referenced (sym
);
239 p
= gfc_get_omp_namelist ();
259 m
= gfc_match (" / %n /", n
);
260 if (m
== MATCH_ERROR
)
265 st
= gfc_find_symtree (gfc_current_ns
->common_root
, n
);
268 gfc_error ("COMMON block /%s/ not found at %C", n
);
271 for (sym
= st
->n
.common
->head
; sym
; sym
= sym
->common_next
)
273 gfc_set_sym_referenced (sym
);
274 p
= gfc_get_omp_namelist ();
286 if (end_colon
&& gfc_match_char (':') == MATCH_YES
)
291 if (gfc_match_char (')') == MATCH_YES
)
293 if (gfc_match_char (',') != MATCH_YES
)
298 list
= &(*list
)->next
;
306 gfc_error ("Syntax error in OpenMP variable list at %C");
309 gfc_free_omp_namelist (head
);
310 gfc_current_locus
= old_loc
;
315 match_oacc_expr_list (const char *str
, gfc_expr_list
**list
,
318 gfc_expr_list
*head
, *tail
, *p
;
325 old_loc
= gfc_current_locus
;
333 m
= gfc_match_expr (&expr
);
334 if (m
== MATCH_YES
|| allow_asterisk
)
336 p
= gfc_get_expr_list ();
346 else if (gfc_match (" *") != MATCH_YES
)
350 if (m
== MATCH_ERROR
)
355 if (gfc_match_char (')') == MATCH_YES
)
357 if (gfc_match_char (',') != MATCH_YES
)
362 list
= &(*list
)->next
;
368 gfc_error ("Syntax error in OpenACC expression list at %C");
371 gfc_free_expr_list (head
);
372 gfc_current_locus
= old_loc
;
377 match_oacc_clause_gang (gfc_omp_clauses
*cp
)
379 if (gfc_match_char ('(') != MATCH_YES
)
381 if (gfc_match (" num :") == MATCH_YES
)
383 cp
->gang_static
= false;
384 return gfc_match (" %e )", &cp
->gang_expr
);
386 if (gfc_match (" static :") == MATCH_YES
)
388 cp
->gang_static
= true;
389 if (gfc_match (" * )") != MATCH_YES
)
390 return gfc_match (" %e )", &cp
->gang_expr
);
393 return gfc_match (" %e )", &cp
->gang_expr
);
396 #define OMP_CLAUSE_PRIVATE ((uint64_t) 1 << 0)
397 #define OMP_CLAUSE_FIRSTPRIVATE ((uint64_t) 1 << 1)
398 #define OMP_CLAUSE_LASTPRIVATE ((uint64_t) 1 << 2)
399 #define OMP_CLAUSE_COPYPRIVATE ((uint64_t) 1 << 3)
400 #define OMP_CLAUSE_SHARED ((uint64_t) 1 << 4)
401 #define OMP_CLAUSE_COPYIN ((uint64_t) 1 << 5)
402 #define OMP_CLAUSE_REDUCTION ((uint64_t) 1 << 6)
403 #define OMP_CLAUSE_IF ((uint64_t) 1 << 7)
404 #define OMP_CLAUSE_NUM_THREADS ((uint64_t) 1 << 8)
405 #define OMP_CLAUSE_SCHEDULE ((uint64_t) 1 << 9)
406 #define OMP_CLAUSE_DEFAULT ((uint64_t) 1 << 10)
407 #define OMP_CLAUSE_ORDERED ((uint64_t) 1 << 11)
408 #define OMP_CLAUSE_COLLAPSE ((uint64_t) 1 << 12)
409 #define OMP_CLAUSE_UNTIED ((uint64_t) 1 << 13)
410 #define OMP_CLAUSE_FINAL ((uint64_t) 1 << 14)
411 #define OMP_CLAUSE_MERGEABLE ((uint64_t) 1 << 15)
412 #define OMP_CLAUSE_ALIGNED ((uint64_t) 1 << 16)
413 #define OMP_CLAUSE_DEPEND ((uint64_t) 1 << 17)
414 #define OMP_CLAUSE_INBRANCH ((uint64_t) 1 << 18)
415 #define OMP_CLAUSE_LINEAR ((uint64_t) 1 << 19)
416 #define OMP_CLAUSE_NOTINBRANCH ((uint64_t) 1 << 20)
417 #define OMP_CLAUSE_PROC_BIND ((uint64_t) 1 << 21)
418 #define OMP_CLAUSE_SAFELEN ((uint64_t) 1 << 22)
419 #define OMP_CLAUSE_SIMDLEN ((uint64_t) 1 << 23)
420 #define OMP_CLAUSE_UNIFORM ((uint64_t) 1 << 24)
421 #define OMP_CLAUSE_DEVICE ((uint64_t) 1 << 25)
422 #define OMP_CLAUSE_MAP ((uint64_t) 1 << 26)
423 #define OMP_CLAUSE_TO ((uint64_t) 1 << 27)
424 #define OMP_CLAUSE_FROM ((uint64_t) 1 << 28)
425 #define OMP_CLAUSE_NUM_TEAMS ((uint64_t) 1 << 29)
426 #define OMP_CLAUSE_THREAD_LIMIT ((uint64_t) 1 << 30)
427 #define OMP_CLAUSE_DIST_SCHEDULE ((uint64_t) 1 << 31)
429 /* OpenACC 2.0 clauses. */
430 #define OMP_CLAUSE_ASYNC ((uint64_t) 1 << 32)
431 #define OMP_CLAUSE_NUM_GANGS ((uint64_t) 1 << 33)
432 #define OMP_CLAUSE_NUM_WORKERS ((uint64_t) 1 << 34)
433 #define OMP_CLAUSE_VECTOR_LENGTH ((uint64_t) 1 << 35)
434 #define OMP_CLAUSE_COPY ((uint64_t) 1 << 36)
435 #define OMP_CLAUSE_COPYOUT ((uint64_t) 1 << 37)
436 #define OMP_CLAUSE_CREATE ((uint64_t) 1 << 38)
437 #define OMP_CLAUSE_PRESENT ((uint64_t) 1 << 39)
438 #define OMP_CLAUSE_PRESENT_OR_COPY ((uint64_t) 1 << 40)
439 #define OMP_CLAUSE_PRESENT_OR_COPYIN ((uint64_t) 1 << 41)
440 #define OMP_CLAUSE_PRESENT_OR_COPYOUT ((uint64_t) 1 << 42)
441 #define OMP_CLAUSE_PRESENT_OR_CREATE ((uint64_t) 1 << 43)
442 #define OMP_CLAUSE_DEVICEPTR ((uint64_t) 1 << 44)
443 #define OMP_CLAUSE_GANG ((uint64_t) 1 << 45)
444 #define OMP_CLAUSE_WORKER ((uint64_t) 1 << 46)
445 #define OMP_CLAUSE_VECTOR ((uint64_t) 1 << 47)
446 #define OMP_CLAUSE_SEQ ((uint64_t) 1 << 48)
447 #define OMP_CLAUSE_INDEPENDENT ((uint64_t) 1 << 49)
448 #define OMP_CLAUSE_USE_DEVICE ((uint64_t) 1 << 50)
449 #define OMP_CLAUSE_DEVICE_RESIDENT ((uint64_t) 1 << 51)
450 #define OMP_CLAUSE_HOST_SELF ((uint64_t) 1 << 52)
451 #define OMP_CLAUSE_OACC_DEVICE ((uint64_t) 1 << 53)
452 #define OMP_CLAUSE_WAIT ((uint64_t) 1 << 54)
453 #define OMP_CLAUSE_DELETE ((uint64_t) 1 << 55)
454 #define OMP_CLAUSE_AUTO ((uint64_t) 1 << 56)
455 #define OMP_CLAUSE_TILE ((uint64_t) 1 << 57)
457 /* Helper function for OpenACC and OpenMP clauses involving memory
461 gfc_match_omp_map_clause (gfc_omp_namelist
**list
, gfc_omp_map_op map_op
)
463 gfc_omp_namelist
**head
= NULL
;
464 if (gfc_match_omp_variable_list ("", list
, false, NULL
, &head
, true)
468 for (n
= *head
; n
; n
= n
->next
)
469 n
->u
.map_op
= map_op
;
476 /* Match OpenMP and OpenACC directive clauses. MASK is a bitmask of
477 clauses that are allowed for a particular directive. */
480 gfc_match_omp_clauses (gfc_omp_clauses
**cp
, uint64_t mask
,
481 bool first
= true, bool needs_space
= true,
482 bool openacc
= false)
484 gfc_omp_clauses
*c
= gfc_get_omp_clauses ();
490 if ((first
|| gfc_match_char (',') != MATCH_YES
)
491 && (needs_space
&& gfc_match_space () != MATCH_YES
))
495 gfc_gobble_whitespace ();
496 if ((mask
& OMP_CLAUSE_ASYNC
) && !c
->async
)
497 if (gfc_match ("async") == MATCH_YES
)
501 if (gfc_match (" ( %e )", &c
->async_expr
) != MATCH_YES
)
503 c
->async_expr
= gfc_get_constant_expr (BT_INTEGER
,
504 gfc_default_integer_kind
,
506 mpz_set_si (c
->async_expr
->value
.integer
, GOMP_ASYNC_NOVAL
);
510 if ((mask
& OMP_CLAUSE_GANG
) && !c
->gang
)
511 if (gfc_match ("gang") == MATCH_YES
)
514 if (match_oacc_clause_gang(c
) == MATCH_YES
)
520 if ((mask
& OMP_CLAUSE_WORKER
) && !c
->worker
)
521 if (gfc_match ("worker") == MATCH_YES
)
524 if (gfc_match (" ( num : %e )", &c
->worker_expr
) == MATCH_YES
525 || gfc_match (" ( %e )", &c
->worker_expr
) == MATCH_YES
)
531 if ((mask
& OMP_CLAUSE_VECTOR_LENGTH
) && c
->vector_length_expr
== NULL
532 && gfc_match ("vector_length ( %e )", &c
->vector_length_expr
)
535 if ((mask
& OMP_CLAUSE_VECTOR
) && !c
->vector
)
536 if (gfc_match ("vector") == MATCH_YES
)
539 if (gfc_match (" ( length : %e )", &c
->vector_expr
) == MATCH_YES
540 || gfc_match (" ( %e )", &c
->vector_expr
) == MATCH_YES
)
546 if ((mask
& OMP_CLAUSE_IF
) && c
->if_expr
== NULL
547 && gfc_match ("if ( %e )", &c
->if_expr
) == MATCH_YES
)
549 if ((mask
& OMP_CLAUSE_FINAL
) && c
->final_expr
== NULL
550 && gfc_match ("final ( %e )", &c
->final_expr
) == MATCH_YES
)
552 if ((mask
& OMP_CLAUSE_NUM_THREADS
) && c
->num_threads
== NULL
553 && gfc_match ("num_threads ( %e )", &c
->num_threads
) == MATCH_YES
)
555 if ((mask
& OMP_CLAUSE_PRIVATE
)
556 && gfc_match_omp_variable_list ("private (",
557 &c
->lists
[OMP_LIST_PRIVATE
], true)
560 if ((mask
& OMP_CLAUSE_FIRSTPRIVATE
)
561 && gfc_match_omp_variable_list ("firstprivate (",
562 &c
->lists
[OMP_LIST_FIRSTPRIVATE
],
566 if ((mask
& OMP_CLAUSE_LASTPRIVATE
)
567 && gfc_match_omp_variable_list ("lastprivate (",
568 &c
->lists
[OMP_LIST_LASTPRIVATE
],
572 if ((mask
& OMP_CLAUSE_COPYPRIVATE
)
573 && gfc_match_omp_variable_list ("copyprivate (",
574 &c
->lists
[OMP_LIST_COPYPRIVATE
],
578 if ((mask
& OMP_CLAUSE_SHARED
)
579 && gfc_match_omp_variable_list ("shared (",
580 &c
->lists
[OMP_LIST_SHARED
], true)
583 if (mask
& OMP_CLAUSE_COPYIN
)
587 if (gfc_match ("copyin ( ") == MATCH_YES
588 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
592 else if (gfc_match_omp_variable_list ("copyin (",
593 &c
->lists
[OMP_LIST_COPYIN
],
597 if ((mask
& OMP_CLAUSE_NUM_GANGS
) && c
->num_gangs_expr
== NULL
598 && gfc_match ("num_gangs ( %e )", &c
->num_gangs_expr
) == MATCH_YES
)
600 if ((mask
& OMP_CLAUSE_NUM_WORKERS
) && c
->num_workers_expr
== NULL
601 && gfc_match ("num_workers ( %e )", &c
->num_workers_expr
)
604 if ((mask
& OMP_CLAUSE_COPY
)
605 && gfc_match ("copy ( ") == MATCH_YES
606 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
607 OMP_MAP_FORCE_TOFROM
))
609 if ((mask
& OMP_CLAUSE_COPYOUT
)
610 && gfc_match ("copyout ( ") == MATCH_YES
611 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
614 if ((mask
& OMP_CLAUSE_CREATE
)
615 && gfc_match ("create ( ") == MATCH_YES
616 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
617 OMP_MAP_FORCE_ALLOC
))
619 if ((mask
& OMP_CLAUSE_DELETE
)
620 && gfc_match ("delete ( ") == MATCH_YES
621 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
622 OMP_MAP_FORCE_DEALLOC
))
624 if ((mask
& OMP_CLAUSE_PRESENT
)
625 && gfc_match ("present ( ") == MATCH_YES
626 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
627 OMP_MAP_FORCE_PRESENT
))
629 if ((mask
& OMP_CLAUSE_PRESENT_OR_COPY
)
630 && gfc_match ("present_or_copy ( ") == MATCH_YES
631 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
634 if ((mask
& OMP_CLAUSE_PRESENT_OR_COPY
)
635 && gfc_match ("pcopy ( ") == MATCH_YES
636 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
639 if ((mask
& OMP_CLAUSE_PRESENT_OR_COPYIN
)
640 && gfc_match ("present_or_copyin ( ") == MATCH_YES
641 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
644 if ((mask
& OMP_CLAUSE_PRESENT_OR_COPYIN
)
645 && gfc_match ("pcopyin ( ") == MATCH_YES
646 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
649 if ((mask
& OMP_CLAUSE_PRESENT_OR_COPYOUT
)
650 && gfc_match ("present_or_copyout ( ") == MATCH_YES
651 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
654 if ((mask
& OMP_CLAUSE_PRESENT_OR_COPYOUT
)
655 && gfc_match ("pcopyout ( ") == MATCH_YES
656 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
659 if ((mask
& OMP_CLAUSE_PRESENT_OR_CREATE
)
660 && gfc_match ("present_or_create ( ") == MATCH_YES
661 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
664 if ((mask
& OMP_CLAUSE_PRESENT_OR_CREATE
)
665 && gfc_match ("pcreate ( ") == MATCH_YES
666 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
669 if ((mask
& OMP_CLAUSE_DEVICEPTR
)
670 && gfc_match ("deviceptr ( ") == MATCH_YES
)
672 gfc_omp_namelist
**list
= &c
->lists
[OMP_LIST_MAP
];
673 gfc_omp_namelist
**head
= NULL
;
674 if (gfc_match_omp_variable_list ("", list
, true, NULL
, &head
, false)
678 for (n
= *head
; n
; n
= n
->next
)
679 n
->u
.map_op
= OMP_MAP_FORCE_DEVICEPTR
;
683 if ((mask
& OMP_CLAUSE_USE_DEVICE
)
684 && gfc_match_omp_variable_list ("use_device (",
685 &c
->lists
[OMP_LIST_USE_DEVICE
], true)
688 if ((mask
& OMP_CLAUSE_DEVICE_RESIDENT
)
689 && gfc_match_omp_variable_list ("device_resident (",
690 &c
->lists
[OMP_LIST_DEVICE_RESIDENT
],
694 if ((mask
& OMP_CLAUSE_OACC_DEVICE
)
695 && gfc_match ("device ( ") == MATCH_YES
696 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
699 if ((mask
& OMP_CLAUSE_HOST_SELF
)
700 && (gfc_match ("host ( ") == MATCH_YES
701 || gfc_match ("self ( ") == MATCH_YES
)
702 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
705 if ((mask
& OMP_CLAUSE_TILE
)
706 && match_oacc_expr_list ("tile (", &c
->tile_list
, true) == MATCH_YES
)
708 if ((mask
& OMP_CLAUSE_SEQ
) && !c
->seq
709 && gfc_match ("seq") == MATCH_YES
)
715 if ((mask
& OMP_CLAUSE_INDEPENDENT
) && !c
->independent
716 && gfc_match ("independent") == MATCH_YES
)
718 c
->independent
= true;
722 if ((mask
& OMP_CLAUSE_AUTO
) && !c
->par_auto
723 && gfc_match ("auto") == MATCH_YES
)
729 if ((mask
& OMP_CLAUSE_WAIT
) && !c
->wait
730 && gfc_match ("wait") == MATCH_YES
)
733 match_oacc_expr_list (" (", &c
->wait_list
, false);
736 old_loc
= gfc_current_locus
;
737 if ((mask
& OMP_CLAUSE_REDUCTION
)
738 && gfc_match ("reduction ( ") == MATCH_YES
)
740 gfc_omp_reduction_op rop
= OMP_REDUCTION_NONE
;
741 char buffer
[GFC_MAX_SYMBOL_LEN
+ 3];
742 if (gfc_match_char ('+') == MATCH_YES
)
743 rop
= OMP_REDUCTION_PLUS
;
744 else if (gfc_match_char ('*') == MATCH_YES
)
745 rop
= OMP_REDUCTION_TIMES
;
746 else if (gfc_match_char ('-') == MATCH_YES
)
747 rop
= OMP_REDUCTION_MINUS
;
748 else if (gfc_match (".and.") == MATCH_YES
)
749 rop
= OMP_REDUCTION_AND
;
750 else if (gfc_match (".or.") == MATCH_YES
)
751 rop
= OMP_REDUCTION_OR
;
752 else if (gfc_match (".eqv.") == MATCH_YES
)
753 rop
= OMP_REDUCTION_EQV
;
754 else if (gfc_match (".neqv.") == MATCH_YES
)
755 rop
= OMP_REDUCTION_NEQV
;
756 if (rop
!= OMP_REDUCTION_NONE
)
757 snprintf (buffer
, sizeof buffer
,
758 "operator %s", gfc_op2string ((gfc_intrinsic_op
) rop
));
759 else if (gfc_match_defined_op_name (buffer
+ 1, 1) == MATCH_YES
)
762 strcat (buffer
, ".");
764 else if (gfc_match_name (buffer
) == MATCH_YES
)
767 const char *n
= buffer
;
769 gfc_find_symbol (buffer
, NULL
, 1, &sym
);
772 if (sym
->attr
.intrinsic
)
774 else if ((sym
->attr
.flavor
!= FL_UNKNOWN
775 && sym
->attr
.flavor
!= FL_PROCEDURE
)
776 || sym
->attr
.external
781 || sym
->attr
.subroutine
784 || sym
->attr
.cray_pointer
785 || sym
->attr
.cray_pointee
786 || (sym
->attr
.proc
!= PROC_UNKNOWN
787 && sym
->attr
.proc
!= PROC_INTRINSIC
)
788 || sym
->attr
.if_source
!= IFSRC_UNKNOWN
789 || sym
== sym
->ns
->proc_name
)
798 rop
= OMP_REDUCTION_NONE
;
799 else if (strcmp (n
, "max") == 0)
800 rop
= OMP_REDUCTION_MAX
;
801 else if (strcmp (n
, "min") == 0)
802 rop
= OMP_REDUCTION_MIN
;
803 else if (strcmp (n
, "iand") == 0)
804 rop
= OMP_REDUCTION_IAND
;
805 else if (strcmp (n
, "ior") == 0)
806 rop
= OMP_REDUCTION_IOR
;
807 else if (strcmp (n
, "ieor") == 0)
808 rop
= OMP_REDUCTION_IEOR
;
809 if (rop
!= OMP_REDUCTION_NONE
811 && ! sym
->attr
.intrinsic
812 && ! sym
->attr
.use_assoc
813 && ((sym
->attr
.flavor
== FL_UNKNOWN
814 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
,
816 || !gfc_add_intrinsic (&sym
->attr
, NULL
)))
817 rop
= OMP_REDUCTION_NONE
;
823 ? gfc_find_omp_udr (gfc_current_ns
, buffer
, NULL
) : NULL
);
824 gfc_omp_namelist
**head
= NULL
;
825 if (rop
== OMP_REDUCTION_NONE
&& udr
)
826 rop
= OMP_REDUCTION_USER
;
828 if (gfc_match_omp_variable_list (" :",
829 &c
->lists
[OMP_LIST_REDUCTION
],
830 false, NULL
, &head
) == MATCH_YES
)
833 if (rop
== OMP_REDUCTION_NONE
)
837 gfc_error_now ("!$OMP DECLARE REDUCTION %s not found "
838 "at %L", buffer
, &old_loc
);
839 gfc_free_omp_namelist (n
);
842 for (n
= *head
; n
; n
= n
->next
)
844 n
->u
.reduction_op
= rop
;
847 n
->udr
= gfc_get_omp_namelist_udr ();
854 gfc_current_locus
= old_loc
;
856 if ((mask
& OMP_CLAUSE_DEFAULT
)
857 && c
->default_sharing
== OMP_DEFAULT_UNKNOWN
)
859 if (gfc_match ("default ( shared )") == MATCH_YES
)
860 c
->default_sharing
= OMP_DEFAULT_SHARED
;
861 else if (gfc_match ("default ( private )") == MATCH_YES
)
862 c
->default_sharing
= OMP_DEFAULT_PRIVATE
;
863 else if (gfc_match ("default ( none )") == MATCH_YES
)
864 c
->default_sharing
= OMP_DEFAULT_NONE
;
865 else if (gfc_match ("default ( firstprivate )") == MATCH_YES
)
866 c
->default_sharing
= OMP_DEFAULT_FIRSTPRIVATE
;
867 if (c
->default_sharing
!= OMP_DEFAULT_UNKNOWN
)
870 old_loc
= gfc_current_locus
;
871 if ((mask
& OMP_CLAUSE_SCHEDULE
)
872 && c
->sched_kind
== OMP_SCHED_NONE
873 && gfc_match ("schedule ( ") == MATCH_YES
)
875 if (gfc_match ("static") == MATCH_YES
)
876 c
->sched_kind
= OMP_SCHED_STATIC
;
877 else if (gfc_match ("dynamic") == MATCH_YES
)
878 c
->sched_kind
= OMP_SCHED_DYNAMIC
;
879 else if (gfc_match ("guided") == MATCH_YES
)
880 c
->sched_kind
= OMP_SCHED_GUIDED
;
881 else if (gfc_match ("runtime") == MATCH_YES
)
882 c
->sched_kind
= OMP_SCHED_RUNTIME
;
883 else if (gfc_match ("auto") == MATCH_YES
)
884 c
->sched_kind
= OMP_SCHED_AUTO
;
885 if (c
->sched_kind
!= OMP_SCHED_NONE
)
888 if (c
->sched_kind
!= OMP_SCHED_RUNTIME
889 && c
->sched_kind
!= OMP_SCHED_AUTO
)
890 m
= gfc_match (" , %e )", &c
->chunk_size
);
892 m
= gfc_match_char (')');
894 c
->sched_kind
= OMP_SCHED_NONE
;
896 if (c
->sched_kind
!= OMP_SCHED_NONE
)
899 gfc_current_locus
= old_loc
;
901 if ((mask
& OMP_CLAUSE_ORDERED
) && !c
->ordered
902 && gfc_match ("ordered") == MATCH_YES
)
904 c
->ordered
= needs_space
= true;
907 if ((mask
& OMP_CLAUSE_UNTIED
) && !c
->untied
908 && gfc_match ("untied") == MATCH_YES
)
910 c
->untied
= needs_space
= true;
913 if ((mask
& OMP_CLAUSE_MERGEABLE
) && !c
->mergeable
914 && gfc_match ("mergeable") == MATCH_YES
)
916 c
->mergeable
= needs_space
= true;
919 if ((mask
& OMP_CLAUSE_COLLAPSE
) && !c
->collapse
)
921 gfc_expr
*cexpr
= NULL
;
922 match m
= gfc_match ("collapse ( %e )", &cexpr
);
927 const char *p
= gfc_extract_int (cexpr
, &collapse
);
933 else if (collapse
<= 0)
935 gfc_error_now ("COLLAPSE clause argument not"
936 " constant positive integer at %C");
939 c
->collapse
= collapse
;
940 gfc_free_expr (cexpr
);
944 if ((mask
& OMP_CLAUSE_INBRANCH
) && !c
->inbranch
&& !c
->notinbranch
945 && gfc_match ("inbranch") == MATCH_YES
)
947 c
->inbranch
= needs_space
= true;
950 if ((mask
& OMP_CLAUSE_NOTINBRANCH
) && !c
->notinbranch
&& !c
->inbranch
951 && gfc_match ("notinbranch") == MATCH_YES
)
953 c
->notinbranch
= needs_space
= true;
956 if ((mask
& OMP_CLAUSE_PROC_BIND
)
957 && c
->proc_bind
== OMP_PROC_BIND_UNKNOWN
)
959 if (gfc_match ("proc_bind ( master )") == MATCH_YES
)
960 c
->proc_bind
= OMP_PROC_BIND_MASTER
;
961 else if (gfc_match ("proc_bind ( spread )") == MATCH_YES
)
962 c
->proc_bind
= OMP_PROC_BIND_SPREAD
;
963 else if (gfc_match ("proc_bind ( close )") == MATCH_YES
)
964 c
->proc_bind
= OMP_PROC_BIND_CLOSE
;
965 if (c
->proc_bind
!= OMP_PROC_BIND_UNKNOWN
)
968 if ((mask
& OMP_CLAUSE_SAFELEN
) && c
->safelen_expr
== NULL
969 && gfc_match ("safelen ( %e )", &c
->safelen_expr
) == MATCH_YES
)
971 if ((mask
& OMP_CLAUSE_SIMDLEN
) && c
->simdlen_expr
== NULL
972 && gfc_match ("simdlen ( %e )", &c
->simdlen_expr
) == MATCH_YES
)
974 if ((mask
& OMP_CLAUSE_UNIFORM
)
975 && gfc_match_omp_variable_list ("uniform (",
976 &c
->lists
[OMP_LIST_UNIFORM
], false)
979 bool end_colon
= false;
980 gfc_omp_namelist
**head
= NULL
;
981 old_loc
= gfc_current_locus
;
982 if ((mask
& OMP_CLAUSE_ALIGNED
)
983 && gfc_match_omp_variable_list ("aligned (",
984 &c
->lists
[OMP_LIST_ALIGNED
], false,
988 gfc_expr
*alignment
= NULL
;
992 && gfc_match (" %e )", &alignment
) != MATCH_YES
)
994 gfc_free_omp_namelist (*head
);
995 gfc_current_locus
= old_loc
;
999 for (n
= *head
; n
; n
= n
->next
)
1000 if (n
->next
&& alignment
)
1001 n
->expr
= gfc_copy_expr (alignment
);
1003 n
->expr
= alignment
;
1008 old_loc
= gfc_current_locus
;
1009 if ((mask
& OMP_CLAUSE_LINEAR
)
1010 && gfc_match_omp_variable_list ("linear (",
1011 &c
->lists
[OMP_LIST_LINEAR
], false,
1015 gfc_expr
*step
= NULL
;
1018 && gfc_match (" %e )", &step
) != MATCH_YES
)
1020 gfc_free_omp_namelist (*head
);
1021 gfc_current_locus
= old_loc
;
1025 else if (!end_colon
)
1027 step
= gfc_get_constant_expr (BT_INTEGER
,
1028 gfc_default_integer_kind
,
1030 mpz_set_si (step
->value
.integer
, 1);
1032 (*head
)->expr
= step
;
1035 if ((mask
& OMP_CLAUSE_DEPEND
)
1036 && gfc_match ("depend ( ") == MATCH_YES
)
1038 match m
= MATCH_YES
;
1039 gfc_omp_depend_op depend_op
= OMP_DEPEND_OUT
;
1040 if (gfc_match ("inout") == MATCH_YES
)
1041 depend_op
= OMP_DEPEND_INOUT
;
1042 else if (gfc_match ("in") == MATCH_YES
)
1043 depend_op
= OMP_DEPEND_IN
;
1044 else if (gfc_match ("out") == MATCH_YES
)
1045 depend_op
= OMP_DEPEND_OUT
;
1050 && gfc_match_omp_variable_list (" : ",
1051 &c
->lists
[OMP_LIST_DEPEND
],
1052 false, NULL
, &head
, true)
1055 gfc_omp_namelist
*n
;
1056 for (n
= *head
; n
; n
= n
->next
)
1057 n
->u
.depend_op
= depend_op
;
1061 gfc_current_locus
= old_loc
;
1063 if ((mask
& OMP_CLAUSE_DIST_SCHEDULE
)
1064 && c
->dist_sched_kind
== OMP_SCHED_NONE
1065 && gfc_match ("dist_schedule ( static") == MATCH_YES
)
1068 c
->dist_sched_kind
= OMP_SCHED_STATIC
;
1069 m
= gfc_match (" , %e )", &c
->dist_chunk_size
);
1071 m
= gfc_match_char (')');
1074 c
->dist_sched_kind
= OMP_SCHED_NONE
;
1075 gfc_current_locus
= old_loc
;
1080 if ((mask
& OMP_CLAUSE_NUM_TEAMS
) && c
->num_teams
== NULL
1081 && gfc_match ("num_teams ( %e )", &c
->num_teams
) == MATCH_YES
)
1083 if ((mask
& OMP_CLAUSE_DEVICE
) && c
->device
== NULL
1084 && gfc_match ("device ( %e )", &c
->device
) == MATCH_YES
)
1086 if ((mask
& OMP_CLAUSE_THREAD_LIMIT
) && c
->thread_limit
== NULL
1087 && gfc_match ("thread_limit ( %e )", &c
->thread_limit
) == MATCH_YES
)
1089 if ((mask
& OMP_CLAUSE_MAP
)
1090 && gfc_match ("map ( ") == MATCH_YES
)
1092 gfc_omp_map_op map_op
= OMP_MAP_TOFROM
;
1093 if (gfc_match ("alloc : ") == MATCH_YES
)
1094 map_op
= OMP_MAP_ALLOC
;
1095 else if (gfc_match ("tofrom : ") == MATCH_YES
)
1096 map_op
= OMP_MAP_TOFROM
;
1097 else if (gfc_match ("to : ") == MATCH_YES
)
1098 map_op
= OMP_MAP_TO
;
1099 else if (gfc_match ("from : ") == MATCH_YES
)
1100 map_op
= OMP_MAP_FROM
;
1102 if (gfc_match_omp_variable_list ("", &c
->lists
[OMP_LIST_MAP
],
1103 false, NULL
, &head
, true)
1106 gfc_omp_namelist
*n
;
1107 for (n
= *head
; n
; n
= n
->next
)
1108 n
->u
.map_op
= map_op
;
1112 gfc_current_locus
= old_loc
;
1114 if ((mask
& OMP_CLAUSE_TO
)
1115 && gfc_match_omp_variable_list ("to (",
1116 &c
->lists
[OMP_LIST_TO
], false,
1120 if ((mask
& OMP_CLAUSE_FROM
)
1121 && gfc_match_omp_variable_list ("from (",
1122 &c
->lists
[OMP_LIST_FROM
], false,
1130 if (gfc_match_omp_eos () != MATCH_YES
)
1132 gfc_free_omp_clauses (c
);
1141 #define OACC_PARALLEL_CLAUSES \
1142 (OMP_CLAUSE_IF | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
1143 | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_REDUCTION \
1144 | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
1145 | OMP_CLAUSE_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_PRESENT_OR_COPY \
1146 | OMP_CLAUSE_PRESENT_OR_COPYIN | OMP_CLAUSE_PRESENT_OR_COPYOUT \
1147 | OMP_CLAUSE_PRESENT_OR_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE \
1148 | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT)
1149 #define OACC_KERNELS_CLAUSES \
1150 (OMP_CLAUSE_IF | OMP_CLAUSE_ASYNC | OMP_CLAUSE_DEVICEPTR \
1151 | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
1152 | OMP_CLAUSE_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_PRESENT_OR_COPY \
1153 | OMP_CLAUSE_PRESENT_OR_COPYIN | OMP_CLAUSE_PRESENT_OR_COPYOUT \
1154 | OMP_CLAUSE_PRESENT_OR_CREATE | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT)
1155 #define OACC_DATA_CLAUSES \
1156 (OMP_CLAUSE_IF | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_COPY \
1157 | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_CREATE \
1158 | OMP_CLAUSE_PRESENT | OMP_CLAUSE_PRESENT_OR_COPY \
1159 | OMP_CLAUSE_PRESENT_OR_COPYIN | OMP_CLAUSE_PRESENT_OR_COPYOUT \
1160 | OMP_CLAUSE_PRESENT_OR_CREATE)
1161 #define OACC_LOOP_CLAUSES \
1162 (OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER \
1163 | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ | OMP_CLAUSE_INDEPENDENT \
1164 | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_AUTO \
1166 #define OACC_PARALLEL_LOOP_CLAUSES \
1167 (OACC_LOOP_CLAUSES | OACC_PARALLEL_CLAUSES)
1168 #define OACC_KERNELS_LOOP_CLAUSES \
1169 (OACC_LOOP_CLAUSES | OACC_KERNELS_CLAUSES)
1170 #define OACC_HOST_DATA_CLAUSES OMP_CLAUSE_USE_DEVICE
1171 #define OACC_DECLARE_CLAUSES \
1172 (OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
1173 | OMP_CLAUSE_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_DEVICE_RESIDENT \
1174 | OMP_CLAUSE_PRESENT | OMP_CLAUSE_PRESENT_OR_COPY \
1175 | OMP_CLAUSE_PRESENT_OR_COPYIN | OMP_CLAUSE_PRESENT_OR_COPYOUT \
1176 | OMP_CLAUSE_PRESENT_OR_CREATE)
1177 #define OACC_UPDATE_CLAUSES \
1178 (OMP_CLAUSE_IF | OMP_CLAUSE_ASYNC | OMP_CLAUSE_HOST_SELF \
1179 | OMP_CLAUSE_OACC_DEVICE | OMP_CLAUSE_WAIT)
1180 #define OACC_ENTER_DATA_CLAUSES \
1181 (OMP_CLAUSE_IF | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT | OMP_CLAUSE_COPYIN \
1182 | OMP_CLAUSE_CREATE | OMP_CLAUSE_PRESENT_OR_COPYIN \
1183 | OMP_CLAUSE_PRESENT_OR_CREATE)
1184 #define OACC_EXIT_DATA_CLAUSES \
1185 (OMP_CLAUSE_IF | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT | OMP_CLAUSE_COPYOUT \
1186 | OMP_CLAUSE_DELETE)
1187 #define OACC_WAIT_CLAUSES \
1192 gfc_match_oacc_parallel_loop (void)
1195 if (gfc_match_omp_clauses (&c
, OACC_PARALLEL_LOOP_CLAUSES
, false, false,
1199 new_st
.op
= EXEC_OACC_PARALLEL_LOOP
;
1200 new_st
.ext
.omp_clauses
= c
;
1206 gfc_match_oacc_parallel (void)
1209 if (gfc_match_omp_clauses (&c
, OACC_PARALLEL_CLAUSES
, false, false, true)
1213 new_st
.op
= EXEC_OACC_PARALLEL
;
1214 new_st
.ext
.omp_clauses
= c
;
1220 gfc_match_oacc_kernels_loop (void)
1223 if (gfc_match_omp_clauses (&c
, OACC_KERNELS_LOOP_CLAUSES
, false, false,
1227 new_st
.op
= EXEC_OACC_KERNELS_LOOP
;
1228 new_st
.ext
.omp_clauses
= c
;
1234 gfc_match_oacc_kernels (void)
1237 if (gfc_match_omp_clauses (&c
, OACC_KERNELS_CLAUSES
, false, false, true)
1241 new_st
.op
= EXEC_OACC_KERNELS
;
1242 new_st
.ext
.omp_clauses
= c
;
1248 gfc_match_oacc_data (void)
1251 if (gfc_match_omp_clauses (&c
, OACC_DATA_CLAUSES
, false, false, true)
1255 new_st
.op
= EXEC_OACC_DATA
;
1256 new_st
.ext
.omp_clauses
= c
;
1262 gfc_match_oacc_host_data (void)
1265 if (gfc_match_omp_clauses (&c
, OACC_HOST_DATA_CLAUSES
, false, false, true)
1269 new_st
.op
= EXEC_OACC_HOST_DATA
;
1270 new_st
.ext
.omp_clauses
= c
;
1276 gfc_match_oacc_loop (void)
1279 if (gfc_match_omp_clauses (&c
, OACC_LOOP_CLAUSES
, false, false, true)
1283 new_st
.op
= EXEC_OACC_LOOP
;
1284 new_st
.ext
.omp_clauses
= c
;
1290 gfc_match_oacc_declare (void)
1293 if (gfc_match_omp_clauses (&c
, OACC_DECLARE_CLAUSES
, false, false, true)
1297 new_st
.ext
.omp_clauses
= c
;
1298 new_st
.ext
.omp_clauses
->loc
= gfc_current_locus
;
1304 gfc_match_oacc_update (void)
1307 if (gfc_match_omp_clauses (&c
, OACC_UPDATE_CLAUSES
, false, false, true)
1311 new_st
.op
= EXEC_OACC_UPDATE
;
1312 new_st
.ext
.omp_clauses
= c
;
1318 gfc_match_oacc_enter_data (void)
1321 if (gfc_match_omp_clauses (&c
, OACC_ENTER_DATA_CLAUSES
, false, false, true)
1325 new_st
.op
= EXEC_OACC_ENTER_DATA
;
1326 new_st
.ext
.omp_clauses
= c
;
1332 gfc_match_oacc_exit_data (void)
1335 if (gfc_match_omp_clauses (&c
, OACC_EXIT_DATA_CLAUSES
, false, false, true)
1339 new_st
.op
= EXEC_OACC_EXIT_DATA
;
1340 new_st
.ext
.omp_clauses
= c
;
1346 gfc_match_oacc_wait (void)
1348 gfc_omp_clauses
*c
= gfc_get_omp_clauses ();
1349 gfc_expr_list
*wait_list
= NULL
, *el
;
1351 match_oacc_expr_list (" (", &wait_list
, true);
1352 gfc_match_omp_clauses (&c
, OACC_WAIT_CLAUSES
, false, false, true);
1354 if (gfc_match_omp_eos () != MATCH_YES
)
1356 gfc_error ("Unexpected junk in !$ACC WAIT at %C");
1361 for (el
= wait_list
; el
; el
= el
->next
)
1363 if (el
->expr
== NULL
)
1365 gfc_error ("Invalid argument to $!ACC WAIT at %L",
1366 &wait_list
->expr
->where
);
1370 if (!gfc_resolve_expr (el
->expr
)
1371 || el
->expr
->ts
.type
!= BT_INTEGER
|| el
->expr
->rank
!= 0
1372 || el
->expr
->expr_type
!= EXPR_CONSTANT
)
1374 gfc_error ("WAIT clause at %L requires a scalar INTEGER expression",
1380 c
->wait_list
= wait_list
;
1381 new_st
.op
= EXEC_OACC_WAIT
;
1382 new_st
.ext
.omp_clauses
= c
;
1388 gfc_match_oacc_cache (void)
1390 gfc_omp_clauses
*c
= gfc_get_omp_clauses ();
1391 match m
= gfc_match_omp_variable_list (" (",
1392 &c
->lists
[OMP_LIST_CACHE
], true);
1395 gfc_free_omp_clauses(c
);
1399 if (gfc_current_state() != COMP_DO
1400 && gfc_current_state() != COMP_DO_CONCURRENT
)
1402 gfc_error ("ACC CACHE directive must be inside of loop %C");
1403 gfc_free_omp_clauses(c
);
1407 new_st
.op
= EXEC_OACC_CACHE
;
1408 new_st
.ext
.omp_clauses
= c
;
1414 gfc_match_oacc_routine (void)
1420 old_loc
= gfc_current_locus
;
1422 m
= gfc_match (" (");
1424 if (gfc_current_ns
->proc_name
1425 && gfc_current_ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
1428 gfc_error ("Only the !$ACC ROUTINE form without "
1429 "list is allowed in interface block at %C");
1434 && gfc_current_ns
->proc_name
1435 && gfc_match_omp_eos () == MATCH_YES
)
1437 if (!gfc_add_omp_declare_target (&gfc_current_ns
->proc_name
->attr
,
1438 gfc_current_ns
->proc_name
->name
,
1447 /* Scan for a function name. */
1448 m
= gfc_match_symbol (&sym
, 0);
1452 gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C");
1453 gfc_current_locus
= old_loc
;
1457 if (!sym
->attr
.external
&& !sym
->attr
.function
&& !sym
->attr
.subroutine
)
1459 gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, invalid"
1460 " function name '%s'", sym
->name
);
1461 gfc_current_locus
= old_loc
;
1465 if (gfc_match_char (')') != MATCH_YES
)
1467 gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting"
1469 gfc_current_locus
= old_loc
;
1473 if (gfc_match_omp_eos () != MATCH_YES
)
1475 gfc_error ("Unexpected junk after !$ACC ROUTINE at %C");
1481 gfc_current_locus
= old_loc
;
1486 #define OMP_PARALLEL_CLAUSES \
1487 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \
1488 | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IF \
1489 | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_PROC_BIND)
1490 #define OMP_DECLARE_SIMD_CLAUSES \
1491 (OMP_CLAUSE_SIMDLEN | OMP_CLAUSE_LINEAR | OMP_CLAUSE_UNIFORM \
1492 | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_INBRANCH | OMP_CLAUSE_NOTINBRANCH)
1493 #define OMP_DO_CLAUSES \
1494 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
1495 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
1496 | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE)
1497 #define OMP_SECTIONS_CLAUSES \
1498 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
1499 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
1500 #define OMP_SIMD_CLAUSES \
1501 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
1502 | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_SAFELEN | OMP_CLAUSE_LINEAR \
1503 | OMP_CLAUSE_ALIGNED)
1504 #define OMP_TASK_CLAUSES \
1505 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \
1506 | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED \
1507 | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE | OMP_CLAUSE_DEPEND)
1508 #define OMP_TARGET_CLAUSES \
1509 (OMP_CLAUSE_DEVICE | OMP_CLAUSE_MAP | OMP_CLAUSE_IF)
1510 #define OMP_TARGET_DATA_CLAUSES \
1511 (OMP_CLAUSE_DEVICE | OMP_CLAUSE_MAP | OMP_CLAUSE_IF)
1512 #define OMP_TARGET_UPDATE_CLAUSES \
1513 (OMP_CLAUSE_DEVICE | OMP_CLAUSE_IF | OMP_CLAUSE_TO | OMP_CLAUSE_FROM)
1514 #define OMP_TEAMS_CLAUSES \
1515 (OMP_CLAUSE_NUM_TEAMS | OMP_CLAUSE_THREAD_LIMIT | OMP_CLAUSE_DEFAULT \
1516 | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \
1517 | OMP_CLAUSE_REDUCTION)
1518 #define OMP_DISTRIBUTE_CLAUSES \
1519 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_COLLAPSE \
1520 | OMP_CLAUSE_DIST_SCHEDULE)
1524 match_omp (gfc_exec_op op
, unsigned int mask
)
1527 if (gfc_match_omp_clauses (&c
, mask
) != MATCH_YES
)
1530 new_st
.ext
.omp_clauses
= c
;
1536 gfc_match_omp_critical (void)
1538 char n
[GFC_MAX_SYMBOL_LEN
+1];
1540 if (gfc_match (" ( %n )", n
) != MATCH_YES
)
1542 if (gfc_match_omp_eos () != MATCH_YES
)
1544 gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
1547 new_st
.op
= EXEC_OMP_CRITICAL
;
1548 new_st
.ext
.omp_name
= n
[0] ? xstrdup (n
) : NULL
;
1554 gfc_match_omp_distribute (void)
1556 return match_omp (EXEC_OMP_DISTRIBUTE
, OMP_DISTRIBUTE_CLAUSES
);
1561 gfc_match_omp_distribute_parallel_do (void)
1563 return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO
,
1564 OMP_DISTRIBUTE_CLAUSES
| OMP_PARALLEL_CLAUSES
1570 gfc_match_omp_distribute_parallel_do_simd (void)
1572 return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
,
1573 (OMP_DISTRIBUTE_CLAUSES
| OMP_PARALLEL_CLAUSES
1574 | OMP_DO_CLAUSES
| OMP_SIMD_CLAUSES
)
1575 & ~OMP_CLAUSE_ORDERED
);
1580 gfc_match_omp_distribute_simd (void)
1582 return match_omp (EXEC_OMP_DISTRIBUTE_SIMD
,
1583 OMP_DISTRIBUTE_CLAUSES
| OMP_SIMD_CLAUSES
);
1588 gfc_match_omp_do (void)
1590 return match_omp (EXEC_OMP_DO
, OMP_DO_CLAUSES
);
1595 gfc_match_omp_do_simd (void)
1597 return match_omp (EXEC_OMP_DO_SIMD
, ((OMP_DO_CLAUSES
| OMP_SIMD_CLAUSES
)
1598 & ~OMP_CLAUSE_ORDERED
));
1603 gfc_match_omp_flush (void)
1605 gfc_omp_namelist
*list
= NULL
;
1606 gfc_match_omp_variable_list (" (", &list
, true);
1607 if (gfc_match_omp_eos () != MATCH_YES
)
1609 gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
1610 gfc_free_omp_namelist (list
);
1613 new_st
.op
= EXEC_OMP_FLUSH
;
1614 new_st
.ext
.omp_namelist
= list
;
1620 gfc_match_omp_declare_simd (void)
1622 locus where
= gfc_current_locus
;
1623 gfc_symbol
*proc_name
;
1625 gfc_omp_declare_simd
*ods
;
1627 if (gfc_match (" ( %s ) ", &proc_name
) != MATCH_YES
)
1630 if (gfc_match_omp_clauses (&c
, OMP_DECLARE_SIMD_CLAUSES
, true,
1631 false) != MATCH_YES
)
1634 ods
= gfc_get_omp_declare_simd ();
1636 ods
->proc_name
= proc_name
;
1638 ods
->next
= gfc_current_ns
->omp_declare_simd
;
1639 gfc_current_ns
->omp_declare_simd
= ods
;
1645 match_udr_expr (gfc_symtree
*omp_sym1
, gfc_symtree
*omp_sym2
)
1648 locus old_loc
= gfc_current_locus
;
1649 char sname
[GFC_MAX_SYMBOL_LEN
+ 1];
1651 gfc_namespace
*ns
= gfc_current_ns
;
1652 gfc_expr
*lvalue
= NULL
, *rvalue
= NULL
;
1654 gfc_actual_arglist
*arglist
;
1656 m
= gfc_match (" %v =", &lvalue
);
1658 gfc_current_locus
= old_loc
;
1661 m
= gfc_match (" %e )", &rvalue
);
1664 ns
->code
= gfc_get_code (EXEC_ASSIGN
);
1665 ns
->code
->expr1
= lvalue
;
1666 ns
->code
->expr2
= rvalue
;
1667 ns
->code
->loc
= old_loc
;
1671 gfc_current_locus
= old_loc
;
1672 gfc_free_expr (lvalue
);
1675 m
= gfc_match (" %n", sname
);
1679 if (strcmp (sname
, omp_sym1
->name
) == 0
1680 || strcmp (sname
, omp_sym2
->name
) == 0)
1683 gfc_current_ns
= ns
->parent
;
1684 if (gfc_get_ha_sym_tree (sname
, &st
))
1688 if (sym
->attr
.flavor
!= FL_PROCEDURE
1689 && sym
->attr
.flavor
!= FL_UNKNOWN
)
1692 if (!sym
->attr
.generic
1693 && !sym
->attr
.subroutine
1694 && !sym
->attr
.function
)
1696 if (!(sym
->attr
.external
&& !sym
->attr
.referenced
))
1698 /* ...create a symbol in this scope... */
1699 if (sym
->ns
!= gfc_current_ns
1700 && gfc_get_sym_tree (sname
, NULL
, &st
, false) == 1)
1703 if (sym
!= st
->n
.sym
)
1707 /* ...and then to try to make the symbol into a subroutine. */
1708 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
1712 gfc_set_sym_referenced (sym
);
1713 gfc_gobble_whitespace ();
1714 if (gfc_peek_ascii_char () != '(')
1717 gfc_current_ns
= ns
;
1718 m
= gfc_match_actual_arglist (1, &arglist
);
1722 if (gfc_match_char (')') != MATCH_YES
)
1725 ns
->code
= gfc_get_code (EXEC_CALL
);
1726 ns
->code
->symtree
= st
;
1727 ns
->code
->ext
.actual
= arglist
;
1728 ns
->code
->loc
= old_loc
;
1733 gfc_omp_udr_predef (gfc_omp_reduction_op rop
, const char *name
,
1734 gfc_typespec
*ts
, const char **n
)
1736 if (!gfc_numeric_ts (ts
) && ts
->type
!= BT_LOGICAL
)
1741 case OMP_REDUCTION_PLUS
:
1742 case OMP_REDUCTION_MINUS
:
1743 case OMP_REDUCTION_TIMES
:
1744 return ts
->type
!= BT_LOGICAL
;
1745 case OMP_REDUCTION_AND
:
1746 case OMP_REDUCTION_OR
:
1747 case OMP_REDUCTION_EQV
:
1748 case OMP_REDUCTION_NEQV
:
1749 return ts
->type
== BT_LOGICAL
;
1750 case OMP_REDUCTION_USER
:
1751 if (name
[0] != '.' && (ts
->type
== BT_INTEGER
|| ts
->type
== BT_REAL
))
1755 gfc_find_symbol (name
, NULL
, 1, &sym
);
1758 if (sym
->attr
.intrinsic
)
1760 else if ((sym
->attr
.flavor
!= FL_UNKNOWN
1761 && sym
->attr
.flavor
!= FL_PROCEDURE
)
1762 || sym
->attr
.external
1763 || sym
->attr
.generic
1767 || sym
->attr
.subroutine
1768 || sym
->attr
.pointer
1770 || sym
->attr
.cray_pointer
1771 || sym
->attr
.cray_pointee
1772 || (sym
->attr
.proc
!= PROC_UNKNOWN
1773 && sym
->attr
.proc
!= PROC_INTRINSIC
)
1774 || sym
->attr
.if_source
!= IFSRC_UNKNOWN
1775 || sym
== sym
->ns
->proc_name
)
1783 && (strcmp (*n
, "max") == 0 || strcmp (*n
, "min") == 0))
1786 && ts
->type
== BT_INTEGER
1787 && (strcmp (*n
, "iand") == 0
1788 || strcmp (*n
, "ior") == 0
1789 || strcmp (*n
, "ieor") == 0))
1800 gfc_omp_udr_find (gfc_symtree
*st
, gfc_typespec
*ts
)
1802 gfc_omp_udr
*omp_udr
;
1807 for (omp_udr
= st
->n
.omp_udr
; omp_udr
; omp_udr
= omp_udr
->next
)
1808 if (omp_udr
->ts
.type
== ts
->type
1809 || ((omp_udr
->ts
.type
== BT_DERIVED
|| omp_udr
->ts
.type
== BT_CLASS
)
1810 && (ts
->type
== BT_DERIVED
&& ts
->type
== BT_CLASS
)))
1812 if (omp_udr
->ts
.type
== BT_DERIVED
|| omp_udr
->ts
.type
== BT_CLASS
)
1814 if (strcmp (omp_udr
->ts
.u
.derived
->name
, ts
->u
.derived
->name
) == 0)
1817 else if (omp_udr
->ts
.kind
== ts
->kind
)
1819 if (omp_udr
->ts
.type
== BT_CHARACTER
)
1821 if (omp_udr
->ts
.u
.cl
->length
== NULL
1822 || ts
->u
.cl
->length
== NULL
)
1824 if (omp_udr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
1826 if (ts
->u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
1828 if (omp_udr
->ts
.u
.cl
->length
->ts
.type
!= BT_INTEGER
)
1830 if (ts
->u
.cl
->length
->ts
.type
!= BT_INTEGER
)
1832 if (gfc_compare_expr (omp_udr
->ts
.u
.cl
->length
,
1833 ts
->u
.cl
->length
, INTRINSIC_EQ
) != 0)
1843 gfc_match_omp_declare_reduction (void)
1846 gfc_intrinsic_op op
;
1847 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
1848 auto_vec
<gfc_typespec
, 5> tss
;
1852 locus where
= gfc_current_locus
;
1853 locus end_loc
= gfc_current_locus
;
1854 bool end_loc_set
= false;
1855 gfc_omp_reduction_op rop
= OMP_REDUCTION_NONE
;
1857 if (gfc_match_char ('(') != MATCH_YES
)
1860 m
= gfc_match (" %o : ", &op
);
1861 if (m
== MATCH_ERROR
)
1865 snprintf (name
, sizeof name
, "operator %s", gfc_op2string (op
));
1866 rop
= (gfc_omp_reduction_op
) op
;
1870 m
= gfc_match_defined_op_name (name
+ 1, 1);
1871 if (m
== MATCH_ERROR
)
1877 if (gfc_match (" : ") != MATCH_YES
)
1882 if (gfc_match (" %n : ", name
) != MATCH_YES
)
1885 rop
= OMP_REDUCTION_USER
;
1888 m
= gfc_match_type_spec (&ts
);
1891 /* Treat len=: the same as len=*. */
1892 if (ts
.type
== BT_CHARACTER
)
1893 ts
.deferred
= false;
1896 while (gfc_match_char (',') == MATCH_YES
)
1898 m
= gfc_match_type_spec (&ts
);
1903 if (gfc_match_char (':') != MATCH_YES
)
1906 st
= gfc_find_symtree (gfc_current_ns
->omp_udr_root
, name
);
1907 for (i
= 0; i
< tss
.length (); i
++)
1909 gfc_symtree
*omp_out
, *omp_in
;
1910 gfc_symtree
*omp_priv
= NULL
, *omp_orig
= NULL
;
1911 gfc_namespace
*combiner_ns
, *initializer_ns
= NULL
;
1912 gfc_omp_udr
*prev_udr
, *omp_udr
;
1913 const char *predef_name
= NULL
;
1915 omp_udr
= gfc_get_omp_udr ();
1916 omp_udr
->name
= gfc_get_string (name
);
1918 omp_udr
->ts
= tss
[i
];
1919 omp_udr
->where
= where
;
1921 gfc_current_ns
= combiner_ns
= gfc_get_namespace (gfc_current_ns
, 1);
1922 combiner_ns
->proc_name
= combiner_ns
->parent
->proc_name
;
1924 gfc_get_sym_tree ("omp_out", combiner_ns
, &omp_out
, false);
1925 gfc_get_sym_tree ("omp_in", combiner_ns
, &omp_in
, false);
1926 combiner_ns
->omp_udr_ns
= 1;
1927 omp_out
->n
.sym
->ts
= tss
[i
];
1928 omp_in
->n
.sym
->ts
= tss
[i
];
1929 omp_out
->n
.sym
->attr
.omp_udr_artificial_var
= 1;
1930 omp_in
->n
.sym
->attr
.omp_udr_artificial_var
= 1;
1931 omp_out
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
1932 omp_in
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
1933 gfc_commit_symbols ();
1934 omp_udr
->combiner_ns
= combiner_ns
;
1935 omp_udr
->omp_out
= omp_out
->n
.sym
;
1936 omp_udr
->omp_in
= omp_in
->n
.sym
;
1938 locus old_loc
= gfc_current_locus
;
1940 if (!match_udr_expr (omp_out
, omp_in
))
1943 gfc_current_locus
= old_loc
;
1944 gfc_current_ns
= combiner_ns
->parent
;
1945 gfc_undo_symbols ();
1946 gfc_free_omp_udr (omp_udr
);
1950 if (gfc_match (" initializer ( ") == MATCH_YES
)
1952 gfc_current_ns
= combiner_ns
->parent
;
1953 initializer_ns
= gfc_get_namespace (gfc_current_ns
, 1);
1954 gfc_current_ns
= initializer_ns
;
1955 initializer_ns
->proc_name
= initializer_ns
->parent
->proc_name
;
1957 gfc_get_sym_tree ("omp_priv", initializer_ns
, &omp_priv
, false);
1958 gfc_get_sym_tree ("omp_orig", initializer_ns
, &omp_orig
, false);
1959 initializer_ns
->omp_udr_ns
= 1;
1960 omp_priv
->n
.sym
->ts
= tss
[i
];
1961 omp_orig
->n
.sym
->ts
= tss
[i
];
1962 omp_priv
->n
.sym
->attr
.omp_udr_artificial_var
= 1;
1963 omp_orig
->n
.sym
->attr
.omp_udr_artificial_var
= 1;
1964 omp_priv
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
1965 omp_orig
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
1966 gfc_commit_symbols ();
1967 omp_udr
->initializer_ns
= initializer_ns
;
1968 omp_udr
->omp_priv
= omp_priv
->n
.sym
;
1969 omp_udr
->omp_orig
= omp_orig
->n
.sym
;
1971 if (!match_udr_expr (omp_priv
, omp_orig
))
1975 gfc_current_ns
= combiner_ns
->parent
;
1979 end_loc
= gfc_current_locus
;
1981 gfc_current_locus
= old_loc
;
1983 prev_udr
= gfc_omp_udr_find (st
, &tss
[i
]);
1984 if (gfc_omp_udr_predef (rop
, name
, &tss
[i
], &predef_name
)
1985 /* Don't error on !$omp declare reduction (min : integer : ...)
1986 just yet, there could be integer :: min afterwards,
1987 making it valid. When the UDR is resolved, we'll get
1989 && (rop
!= OMP_REDUCTION_USER
|| name
[0] == '.'))
1992 gfc_error_now ("Redefinition of predefined %s "
1993 "!$OMP DECLARE REDUCTION at %L",
1994 predef_name
, &where
);
1996 gfc_error_now ("Redefinition of predefined "
1997 "!$OMP DECLARE REDUCTION at %L", &where
);
2001 gfc_error_now ("Redefinition of !$OMP DECLARE REDUCTION at %L",
2003 gfc_error_now ("Previous !$OMP DECLARE REDUCTION at %L",
2008 omp_udr
->next
= st
->n
.omp_udr
;
2009 st
->n
.omp_udr
= omp_udr
;
2013 st
= gfc_new_symtree (&gfc_current_ns
->omp_udr_root
, name
);
2014 st
->n
.omp_udr
= omp_udr
;
2020 gfc_current_locus
= end_loc
;
2021 if (gfc_match_omp_eos () != MATCH_YES
)
2023 gfc_error ("Unexpected junk after !$OMP DECLARE REDUCTION at %C");
2024 gfc_current_locus
= where
;
2036 gfc_match_omp_declare_target (void)
2039 char n
[GFC_MAX_SYMBOL_LEN
+1];
2044 old_loc
= gfc_current_locus
;
2046 m
= gfc_match (" (");
2048 if (gfc_current_ns
->proc_name
2049 && gfc_current_ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
2052 gfc_error ("Only the !$OMP DECLARE TARGET form without "
2053 "list is allowed in interface block at %C");
2058 && gfc_current_ns
->proc_name
2059 && gfc_match_omp_eos () == MATCH_YES
)
2061 if (!gfc_add_omp_declare_target (&gfc_current_ns
->proc_name
->attr
,
2062 gfc_current_ns
->proc_name
->name
,
2073 m
= gfc_match_symbol (&sym
, 0);
2077 if (sym
->attr
.in_common
)
2078 gfc_error_now ("OMP DECLARE TARGET on a variable at %C is an "
2079 "element of a COMMON block");
2080 else if (!gfc_add_omp_declare_target (&sym
->attr
, sym
->name
,
2090 m
= gfc_match (" / %n /", n
);
2091 if (m
== MATCH_ERROR
)
2093 if (m
== MATCH_NO
|| n
[0] == '\0')
2096 st
= gfc_find_symtree (gfc_current_ns
->common_root
, n
);
2099 gfc_error ("COMMON block /%s/ not found at %C", n
);
2102 st
->n
.common
->omp_declare_target
= 1;
2103 for (sym
= st
->n
.common
->head
; sym
; sym
= sym
->common_next
)
2104 if (!gfc_add_omp_declare_target (&sym
->attr
, sym
->name
,
2109 if (gfc_match_char (')') == MATCH_YES
)
2111 if (gfc_match_char (',') != MATCH_YES
)
2115 if (gfc_match_omp_eos () != MATCH_YES
)
2117 gfc_error ("Unexpected junk after !$OMP DECLARE TARGET at %C");
2123 gfc_error ("Syntax error in !$OMP DECLARE TARGET list at %C");
2126 gfc_current_locus
= old_loc
;
2132 gfc_match_omp_threadprivate (void)
2135 char n
[GFC_MAX_SYMBOL_LEN
+1];
2140 old_loc
= gfc_current_locus
;
2142 m
= gfc_match (" (");
2148 m
= gfc_match_symbol (&sym
, 0);
2152 if (sym
->attr
.in_common
)
2153 gfc_error_now ("Threadprivate variable at %C is an element of "
2155 else if (!gfc_add_threadprivate (&sym
->attr
, sym
->name
, &sym
->declared_at
))
2164 m
= gfc_match (" / %n /", n
);
2165 if (m
== MATCH_ERROR
)
2167 if (m
== MATCH_NO
|| n
[0] == '\0')
2170 st
= gfc_find_symtree (gfc_current_ns
->common_root
, n
);
2173 gfc_error ("COMMON block /%s/ not found at %C", n
);
2176 st
->n
.common
->threadprivate
= 1;
2177 for (sym
= st
->n
.common
->head
; sym
; sym
= sym
->common_next
)
2178 if (!gfc_add_threadprivate (&sym
->attr
, sym
->name
, &sym
->declared_at
))
2182 if (gfc_match_char (')') == MATCH_YES
)
2184 if (gfc_match_char (',') != MATCH_YES
)
2188 if (gfc_match_omp_eos () != MATCH_YES
)
2190 gfc_error ("Unexpected junk after OMP THREADPRIVATE at %C");
2197 gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C");
2200 gfc_current_locus
= old_loc
;
2206 gfc_match_omp_parallel (void)
2208 return match_omp (EXEC_OMP_PARALLEL
, OMP_PARALLEL_CLAUSES
);
2213 gfc_match_omp_parallel_do (void)
2215 return match_omp (EXEC_OMP_PARALLEL_DO
,
2216 OMP_PARALLEL_CLAUSES
| OMP_DO_CLAUSES
);
2221 gfc_match_omp_parallel_do_simd (void)
2223 return match_omp (EXEC_OMP_PARALLEL_DO_SIMD
,
2224 (OMP_PARALLEL_CLAUSES
| OMP_DO_CLAUSES
| OMP_SIMD_CLAUSES
)
2225 & ~OMP_CLAUSE_ORDERED
);
2230 gfc_match_omp_parallel_sections (void)
2232 return match_omp (EXEC_OMP_PARALLEL_SECTIONS
,
2233 OMP_PARALLEL_CLAUSES
| OMP_SECTIONS_CLAUSES
);
2238 gfc_match_omp_parallel_workshare (void)
2240 return match_omp (EXEC_OMP_PARALLEL_WORKSHARE
, OMP_PARALLEL_CLAUSES
);
2245 gfc_match_omp_sections (void)
2247 return match_omp (EXEC_OMP_SECTIONS
, OMP_SECTIONS_CLAUSES
);
2252 gfc_match_omp_simd (void)
2254 return match_omp (EXEC_OMP_SIMD
, OMP_SIMD_CLAUSES
);
2259 gfc_match_omp_single (void)
2261 return match_omp (EXEC_OMP_SINGLE
,
2262 OMP_CLAUSE_PRIVATE
| OMP_CLAUSE_FIRSTPRIVATE
);
2267 gfc_match_omp_task (void)
2269 return match_omp (EXEC_OMP_TASK
, OMP_TASK_CLAUSES
);
2274 gfc_match_omp_taskwait (void)
2276 if (gfc_match_omp_eos () != MATCH_YES
)
2278 gfc_error ("Unexpected junk after TASKWAIT clause at %C");
2281 new_st
.op
= EXEC_OMP_TASKWAIT
;
2282 new_st
.ext
.omp_clauses
= NULL
;
2288 gfc_match_omp_taskyield (void)
2290 if (gfc_match_omp_eos () != MATCH_YES
)
2292 gfc_error ("Unexpected junk after TASKYIELD clause at %C");
2295 new_st
.op
= EXEC_OMP_TASKYIELD
;
2296 new_st
.ext
.omp_clauses
= NULL
;
2302 gfc_match_omp_target (void)
2304 return match_omp (EXEC_OMP_TARGET
, OMP_TARGET_CLAUSES
);
2309 gfc_match_omp_target_data (void)
2311 return match_omp (EXEC_OMP_TARGET_DATA
, OMP_TARGET_DATA_CLAUSES
);
2316 gfc_match_omp_target_teams (void)
2318 return match_omp (EXEC_OMP_TARGET_TEAMS
,
2319 OMP_TARGET_CLAUSES
| OMP_TEAMS_CLAUSES
);
2324 gfc_match_omp_target_teams_distribute (void)
2326 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
,
2327 OMP_TARGET_CLAUSES
| OMP_TEAMS_CLAUSES
2328 | OMP_DISTRIBUTE_CLAUSES
);
2333 gfc_match_omp_target_teams_distribute_parallel_do (void)
2335 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
,
2336 OMP_TARGET_CLAUSES
| OMP_TEAMS_CLAUSES
2337 | OMP_DISTRIBUTE_CLAUSES
| OMP_PARALLEL_CLAUSES
2343 gfc_match_omp_target_teams_distribute_parallel_do_simd (void)
2345 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
,
2346 (OMP_TARGET_CLAUSES
| OMP_TEAMS_CLAUSES
2347 | OMP_DISTRIBUTE_CLAUSES
| OMP_PARALLEL_CLAUSES
2348 | OMP_DO_CLAUSES
| OMP_SIMD_CLAUSES
)
2349 & ~OMP_CLAUSE_ORDERED
);
2354 gfc_match_omp_target_teams_distribute_simd (void)
2356 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
,
2357 OMP_TARGET_CLAUSES
| OMP_TEAMS_CLAUSES
2358 | OMP_DISTRIBUTE_CLAUSES
| OMP_SIMD_CLAUSES
);
2363 gfc_match_omp_target_update (void)
2365 return match_omp (EXEC_OMP_TARGET_UPDATE
, OMP_TARGET_UPDATE_CLAUSES
);
2370 gfc_match_omp_teams (void)
2372 return match_omp (EXEC_OMP_TEAMS
, OMP_TEAMS_CLAUSES
);
2377 gfc_match_omp_teams_distribute (void)
2379 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE
,
2380 OMP_TEAMS_CLAUSES
| OMP_DISTRIBUTE_CLAUSES
);
2385 gfc_match_omp_teams_distribute_parallel_do (void)
2387 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
,
2388 OMP_TEAMS_CLAUSES
| OMP_DISTRIBUTE_CLAUSES
2389 | OMP_PARALLEL_CLAUSES
| OMP_DO_CLAUSES
);
2394 gfc_match_omp_teams_distribute_parallel_do_simd (void)
2396 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
,
2397 (OMP_TEAMS_CLAUSES
| OMP_DISTRIBUTE_CLAUSES
2398 | OMP_PARALLEL_CLAUSES
| OMP_DO_CLAUSES
2399 | OMP_SIMD_CLAUSES
) & ~OMP_CLAUSE_ORDERED
);
2404 gfc_match_omp_teams_distribute_simd (void)
2406 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
,
2407 OMP_TEAMS_CLAUSES
| OMP_DISTRIBUTE_CLAUSES
2408 | OMP_SIMD_CLAUSES
);
2413 gfc_match_omp_workshare (void)
2415 if (gfc_match_omp_eos () != MATCH_YES
)
2417 gfc_error ("Unexpected junk after $OMP WORKSHARE statement at %C");
2420 new_st
.op
= EXEC_OMP_WORKSHARE
;
2421 new_st
.ext
.omp_clauses
= gfc_get_omp_clauses ();
2427 gfc_match_omp_master (void)
2429 if (gfc_match_omp_eos () != MATCH_YES
)
2431 gfc_error ("Unexpected junk after $OMP MASTER statement at %C");
2434 new_st
.op
= EXEC_OMP_MASTER
;
2435 new_st
.ext
.omp_clauses
= NULL
;
2441 gfc_match_omp_ordered (void)
2443 if (gfc_match_omp_eos () != MATCH_YES
)
2445 gfc_error ("Unexpected junk after $OMP ORDERED statement at %C");
2448 new_st
.op
= EXEC_OMP_ORDERED
;
2449 new_st
.ext
.omp_clauses
= NULL
;
2455 gfc_match_omp_atomic (void)
2457 gfc_omp_atomic_op op
= GFC_OMP_ATOMIC_UPDATE
;
2459 if (gfc_match ("% seq_cst") == MATCH_YES
)
2461 locus old_loc
= gfc_current_locus
;
2462 if (seq_cst
&& gfc_match_char (',') == MATCH_YES
)
2465 || gfc_match_space () == MATCH_YES
)
2467 gfc_gobble_whitespace ();
2468 if (gfc_match ("update") == MATCH_YES
)
2469 op
= GFC_OMP_ATOMIC_UPDATE
;
2470 else if (gfc_match ("read") == MATCH_YES
)
2471 op
= GFC_OMP_ATOMIC_READ
;
2472 else if (gfc_match ("write") == MATCH_YES
)
2473 op
= GFC_OMP_ATOMIC_WRITE
;
2474 else if (gfc_match ("capture") == MATCH_YES
)
2475 op
= GFC_OMP_ATOMIC_CAPTURE
;
2479 gfc_current_locus
= old_loc
;
2483 && (gfc_match (", seq_cst") == MATCH_YES
2484 || gfc_match ("% seq_cst") == MATCH_YES
))
2488 if (gfc_match_omp_eos () != MATCH_YES
)
2490 gfc_error ("Unexpected junk after $OMP ATOMIC statement at %C");
2493 new_st
.op
= EXEC_OMP_ATOMIC
;
2495 op
= (gfc_omp_atomic_op
) (op
| GFC_OMP_ATOMIC_SEQ_CST
);
2496 new_st
.ext
.omp_atomic
= op
;
2502 gfc_match_omp_barrier (void)
2504 if (gfc_match_omp_eos () != MATCH_YES
)
2506 gfc_error ("Unexpected junk after $OMP BARRIER statement at %C");
2509 new_st
.op
= EXEC_OMP_BARRIER
;
2510 new_st
.ext
.omp_clauses
= NULL
;
2516 gfc_match_omp_taskgroup (void)
2518 if (gfc_match_omp_eos () != MATCH_YES
)
2520 gfc_error ("Unexpected junk after $OMP TASKGROUP statement at %C");
2523 new_st
.op
= EXEC_OMP_TASKGROUP
;
2528 static enum gfc_omp_cancel_kind
2529 gfc_match_omp_cancel_kind (void)
2531 if (gfc_match_space () != MATCH_YES
)
2532 return OMP_CANCEL_UNKNOWN
;
2533 if (gfc_match ("parallel") == MATCH_YES
)
2534 return OMP_CANCEL_PARALLEL
;
2535 if (gfc_match ("sections") == MATCH_YES
)
2536 return OMP_CANCEL_SECTIONS
;
2537 if (gfc_match ("do") == MATCH_YES
)
2538 return OMP_CANCEL_DO
;
2539 if (gfc_match ("taskgroup") == MATCH_YES
)
2540 return OMP_CANCEL_TASKGROUP
;
2541 return OMP_CANCEL_UNKNOWN
;
2546 gfc_match_omp_cancel (void)
2549 enum gfc_omp_cancel_kind kind
= gfc_match_omp_cancel_kind ();
2550 if (kind
== OMP_CANCEL_UNKNOWN
)
2552 if (gfc_match_omp_clauses (&c
, OMP_CLAUSE_IF
, false) != MATCH_YES
)
2555 new_st
.op
= EXEC_OMP_CANCEL
;
2556 new_st
.ext
.omp_clauses
= c
;
2562 gfc_match_omp_cancellation_point (void)
2565 enum gfc_omp_cancel_kind kind
= gfc_match_omp_cancel_kind ();
2566 if (kind
== OMP_CANCEL_UNKNOWN
)
2568 if (gfc_match_omp_eos () != MATCH_YES
)
2570 gfc_error ("Unexpected junk after $OMP CANCELLATION POINT statement "
2574 c
= gfc_get_omp_clauses ();
2576 new_st
.op
= EXEC_OMP_CANCELLATION_POINT
;
2577 new_st
.ext
.omp_clauses
= c
;
2583 gfc_match_omp_end_nowait (void)
2585 bool nowait
= false;
2586 if (gfc_match ("% nowait") == MATCH_YES
)
2588 if (gfc_match_omp_eos () != MATCH_YES
)
2590 gfc_error ("Unexpected junk after NOWAIT clause at %C");
2593 new_st
.op
= EXEC_OMP_END_NOWAIT
;
2594 new_st
.ext
.omp_bool
= nowait
;
2600 gfc_match_omp_end_single (void)
2603 if (gfc_match ("% nowait") == MATCH_YES
)
2605 new_st
.op
= EXEC_OMP_END_NOWAIT
;
2606 new_st
.ext
.omp_bool
= true;
2609 if (gfc_match_omp_clauses (&c
, OMP_CLAUSE_COPYPRIVATE
) != MATCH_YES
)
2611 new_st
.op
= EXEC_OMP_END_SINGLE
;
2612 new_st
.ext
.omp_clauses
= c
;
2618 oacc_is_loop (gfc_code
*code
)
2620 return code
->op
== EXEC_OACC_PARALLEL_LOOP
2621 || code
->op
== EXEC_OACC_KERNELS_LOOP
2622 || code
->op
== EXEC_OACC_LOOP
;
2626 resolve_oacc_scalar_int_expr (gfc_expr
*expr
, const char *clause
)
2628 if (!gfc_resolve_expr (expr
)
2629 || expr
->ts
.type
!= BT_INTEGER
|| expr
->rank
!= 0)
2630 gfc_error ("%s clause at %L requires a scalar INTEGER expression",
2631 clause
, &expr
->where
);
2636 resolve_oacc_positive_int_expr (gfc_expr
*expr
, const char *clause
)
2638 resolve_oacc_scalar_int_expr (expr
, clause
);
2639 if (expr
->expr_type
== EXPR_CONSTANT
&& expr
->ts
.type
== BT_INTEGER
2640 && mpz_sgn(expr
->value
.integer
) <= 0)
2641 gfc_warning ("INTEGER expression of %s clause at %L must be positive",
2642 clause
, &expr
->where
);
2645 /* Emits error when symbol is pointer, cray pointer or cray pointee
2646 of derived of polymorphic type. */
2649 check_symbol_not_pointer (gfc_symbol
*sym
, locus loc
, const char *name
)
2651 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.pointer
)
2652 gfc_error ("POINTER object '%s' of derived type in %s clause at %L",
2653 sym
->name
, name
, &loc
);
2654 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.cray_pointer
)
2655 gfc_error ("Cray pointer object of derived type '%s' in %s clause at %L",
2656 sym
->name
, name
, &loc
);
2657 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.cray_pointee
)
2658 gfc_error ("Cray pointee object of derived type '%s' in %s clause at %L",
2659 sym
->name
, name
, &loc
);
2661 if ((sym
->ts
.type
== BT_ASSUMED
&& sym
->attr
.pointer
)
2662 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
2663 && CLASS_DATA (sym
)->attr
.pointer
))
2664 gfc_error ("POINTER object '%s' of polymorphic type in %s clause at %L",
2665 sym
->name
, name
, &loc
);
2666 if ((sym
->ts
.type
== BT_ASSUMED
&& sym
->attr
.cray_pointer
)
2667 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
2668 && CLASS_DATA (sym
)->attr
.cray_pointer
))
2669 gfc_error ("Cray pointer object of polymorphic type '%s' in %s clause at %L",
2670 sym
->name
, name
, &loc
);
2671 if ((sym
->ts
.type
== BT_ASSUMED
&& sym
->attr
.cray_pointee
)
2672 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
2673 && CLASS_DATA (sym
)->attr
.cray_pointee
))
2674 gfc_error ("Cray pointee object of polymorphic type '%s' in %s clause at %L",
2675 sym
->name
, name
, &loc
);
2678 /* Emits error when symbol represents assumed size/rank array. */
2681 check_array_not_assumed (gfc_symbol
*sym
, locus loc
, const char *name
)
2683 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
2684 gfc_error ("Assumed size array '%s' in %s clause at %L",
2685 sym
->name
, name
, &loc
);
2686 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
)
2687 gfc_error ("Assumed rank array '%s' in %s clause at %L",
2688 sym
->name
, name
, &loc
);
2689 if (sym
->as
&& sym
->as
->type
== AS_DEFERRED
&& sym
->attr
.pointer
2690 && !sym
->attr
.contiguous
)
2691 gfc_error ("Noncontiguous deferred shape array '%s' in %s clause at %L",
2692 sym
->name
, name
, &loc
);
2696 resolve_oacc_data_clauses (gfc_symbol
*sym
, locus loc
, const char *name
)
2698 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.allocatable
)
2699 gfc_error ("ALLOCATABLE object '%s' of derived type in %s clause at %L",
2700 sym
->name
, name
, &loc
);
2701 if ((sym
->ts
.type
== BT_ASSUMED
&& sym
->attr
.allocatable
)
2702 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
2703 && CLASS_DATA (sym
)->attr
.allocatable
))
2704 gfc_error ("ALLOCATABLE object '%s' of polymorphic type "
2705 "in %s clause at %L", sym
->name
, name
, &loc
);
2706 check_symbol_not_pointer (sym
, loc
, name
);
2707 check_array_not_assumed (sym
, loc
, name
);
2711 resolve_oacc_deviceptr_clause (gfc_symbol
*sym
, locus loc
, const char *name
)
2713 if (sym
->attr
.pointer
2714 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
2715 && CLASS_DATA (sym
)->attr
.class_pointer
))
2716 gfc_error ("POINTER object '%s' in %s clause at %L",
2717 sym
->name
, name
, &loc
);
2718 if (sym
->attr
.cray_pointer
2719 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
2720 && CLASS_DATA (sym
)->attr
.cray_pointer
))
2721 gfc_error ("Cray pointer object '%s' in %s clause at %L",
2722 sym
->name
, name
, &loc
);
2723 if (sym
->attr
.cray_pointee
2724 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
2725 && CLASS_DATA (sym
)->attr
.cray_pointee
))
2726 gfc_error ("Cray pointee object '%s' in %s clause at %L",
2727 sym
->name
, name
, &loc
);
2728 if (sym
->attr
.allocatable
2729 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
2730 && CLASS_DATA (sym
)->attr
.allocatable
))
2731 gfc_error ("ALLOCATABLE object '%s' in %s clause at %L",
2732 sym
->name
, name
, &loc
);
2733 if (sym
->attr
.value
)
2734 gfc_error ("VALUE object '%s' in %s clause at %L",
2735 sym
->name
, name
, &loc
);
2736 check_array_not_assumed (sym
, loc
, name
);
2740 struct resolve_omp_udr_callback_data
2742 gfc_symbol
*sym1
, *sym2
;
2747 resolve_omp_udr_callback (gfc_expr
**e
, int *, void *data
)
2749 struct resolve_omp_udr_callback_data
*rcd
2750 = (struct resolve_omp_udr_callback_data
*) data
;
2751 if ((*e
)->expr_type
== EXPR_VARIABLE
2752 && ((*e
)->symtree
->n
.sym
== rcd
->sym1
2753 || (*e
)->symtree
->n
.sym
== rcd
->sym2
))
2755 gfc_ref
*ref
= gfc_get_ref ();
2756 ref
->type
= REF_ARRAY
;
2757 ref
->u
.ar
.where
= (*e
)->where
;
2758 ref
->u
.ar
.as
= (*e
)->symtree
->n
.sym
->as
;
2759 ref
->u
.ar
.type
= AR_FULL
;
2760 ref
->u
.ar
.dimen
= 0;
2761 ref
->next
= (*e
)->ref
;
2769 resolve_omp_udr_callback2 (gfc_expr
**e
, int *, void *)
2771 if ((*e
)->expr_type
== EXPR_FUNCTION
2772 && (*e
)->value
.function
.isym
== NULL
)
2774 gfc_symbol
*sym
= (*e
)->symtree
->n
.sym
;
2775 if (!sym
->attr
.intrinsic
2776 && sym
->attr
.if_source
== IFSRC_UNKNOWN
)
2777 gfc_error ("Implicitly declared function %s used in "
2778 "!$OMP DECLARE REDUCTION at %L ", sym
->name
, &(*e
)->where
);
2785 resolve_omp_udr_clause (gfc_omp_namelist
*n
, gfc_namespace
*ns
,
2786 gfc_symbol
*sym1
, gfc_symbol
*sym2
)
2789 gfc_symbol sym1_copy
, sym2_copy
;
2791 if (ns
->code
->op
== EXEC_ASSIGN
)
2793 copy
= gfc_get_code (EXEC_ASSIGN
);
2794 copy
->expr1
= gfc_copy_expr (ns
->code
->expr1
);
2795 copy
->expr2
= gfc_copy_expr (ns
->code
->expr2
);
2799 copy
= gfc_get_code (EXEC_CALL
);
2800 copy
->symtree
= ns
->code
->symtree
;
2801 copy
->ext
.actual
= gfc_copy_actual_arglist (ns
->code
->ext
.actual
);
2803 copy
->loc
= ns
->code
->loc
;
2808 sym1
->name
= sym1_copy
.name
;
2809 sym2
->name
= sym2_copy
.name
;
2810 ns
->proc_name
= ns
->parent
->proc_name
;
2811 if (n
->sym
->attr
.dimension
)
2813 struct resolve_omp_udr_callback_data rcd
;
2816 gfc_code_walker (©
, gfc_dummy_code_callback
,
2817 resolve_omp_udr_callback
, &rcd
);
2819 gfc_resolve_code (copy
, gfc_current_ns
);
2820 if (copy
->op
== EXEC_CALL
&& copy
->resolved_isym
== NULL
)
2822 gfc_symbol
*sym
= copy
->resolved_sym
;
2824 && !sym
->attr
.intrinsic
2825 && sym
->attr
.if_source
== IFSRC_UNKNOWN
)
2826 gfc_error ("Implicitly declared subroutine %s used in "
2827 "!$OMP DECLARE REDUCTION at %L ", sym
->name
,
2830 gfc_code_walker (©
, gfc_dummy_code_callback
,
2831 resolve_omp_udr_callback2
, NULL
);
2837 /* Returns true if clause in list 'list' is compatible with any of
2838 of the clauses in lists [0..list-1]. E.g., a reduction variable may
2839 appear in both reduction and private clauses, so this function
2840 will return true in this case. */
2843 oacc_compatible_clauses (gfc_omp_clauses
*clauses
, int list
,
2844 gfc_symbol
*sym
, bool openacc
)
2846 gfc_omp_namelist
*n
;
2851 if (list
!= OMP_LIST_REDUCTION
)
2854 for (n
= clauses
->lists
[OMP_LIST_FIRST
]; n
; n
= n
->next
)
2861 /* OpenMP directive resolving routines. */
2864 resolve_omp_clauses (gfc_code
*code
, locus
*where
,
2865 gfc_omp_clauses
*omp_clauses
, gfc_namespace
*ns
,
2866 bool openacc
= false)
2868 gfc_omp_namelist
*n
;
2871 static const char *clause_names
[]
2872 = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
2873 "COPYIN", "UNIFORM", "ALIGNED", "LINEAR", "DEPEND", "MAP",
2874 "TO", "FROM", "REDUCTION", "DEVICE_RESIDENT", "USE_DEVICE",
2877 if (omp_clauses
== NULL
)
2880 if (omp_clauses
->if_expr
)
2882 gfc_expr
*expr
= omp_clauses
->if_expr
;
2883 if (!gfc_resolve_expr (expr
)
2884 || expr
->ts
.type
!= BT_LOGICAL
|| expr
->rank
!= 0)
2885 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
2888 if (omp_clauses
->final_expr
)
2890 gfc_expr
*expr
= omp_clauses
->final_expr
;
2891 if (!gfc_resolve_expr (expr
)
2892 || expr
->ts
.type
!= BT_LOGICAL
|| expr
->rank
!= 0)
2893 gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression",
2896 if (omp_clauses
->num_threads
)
2898 gfc_expr
*expr
= omp_clauses
->num_threads
;
2899 if (!gfc_resolve_expr (expr
)
2900 || expr
->ts
.type
!= BT_INTEGER
|| expr
->rank
!= 0)
2901 gfc_error ("NUM_THREADS clause at %L requires a scalar "
2902 "INTEGER expression", &expr
->where
);
2904 if (omp_clauses
->chunk_size
)
2906 gfc_expr
*expr
= omp_clauses
->chunk_size
;
2907 if (!gfc_resolve_expr (expr
)
2908 || expr
->ts
.type
!= BT_INTEGER
|| expr
->rank
!= 0)
2909 gfc_error ("SCHEDULE clause's chunk_size at %L requires "
2910 "a scalar INTEGER expression", &expr
->where
);
2913 /* Check that no symbol appears on multiple clauses, except that
2914 a symbol can appear on both firstprivate and lastprivate. */
2915 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
2916 for (n
= omp_clauses
->lists
[list
]; n
; n
= n
->next
)
2919 if (n
->sym
->attr
.flavor
== FL_VARIABLE
2920 || n
->sym
->attr
.proc_pointer
2921 || (!code
&& (!n
->sym
->attr
.dummy
|| n
->sym
->ns
!= ns
)))
2923 if (!code
&& (!n
->sym
->attr
.dummy
|| n
->sym
->ns
!= ns
))
2924 gfc_error ("Variable %qs is not a dummy argument at %L",
2925 n
->sym
->name
, where
);
2928 if (n
->sym
->attr
.flavor
== FL_PROCEDURE
2929 && n
->sym
->result
== n
->sym
2930 && n
->sym
->attr
.function
)
2932 if (gfc_current_ns
->proc_name
== n
->sym
2933 || (gfc_current_ns
->parent
2934 && gfc_current_ns
->parent
->proc_name
== n
->sym
))
2936 if (gfc_current_ns
->proc_name
->attr
.entry_master
)
2938 gfc_entry_list
*el
= gfc_current_ns
->entries
;
2939 for (; el
; el
= el
->next
)
2940 if (el
->sym
== n
->sym
)
2945 if (gfc_current_ns
->parent
2946 && gfc_current_ns
->parent
->proc_name
->attr
.entry_master
)
2948 gfc_entry_list
*el
= gfc_current_ns
->parent
->entries
;
2949 for (; el
; el
= el
->next
)
2950 if (el
->sym
== n
->sym
)
2956 gfc_error ("Object %qs is not a variable at %L", n
->sym
->name
,
2960 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
2961 if (list
!= OMP_LIST_FIRSTPRIVATE
2962 && list
!= OMP_LIST_LASTPRIVATE
2963 && list
!= OMP_LIST_ALIGNED
2964 && list
!= OMP_LIST_DEPEND
2965 && (list
!= OMP_LIST_MAP
|| openacc
)
2966 && list
!= OMP_LIST_FROM
2967 && list
!= OMP_LIST_TO
)
2968 for (n
= omp_clauses
->lists
[list
]; n
; n
= n
->next
)
2970 if (n
->sym
->mark
&& !oacc_compatible_clauses (omp_clauses
, list
,
2972 gfc_error ("Symbol %qs present on multiple clauses at %L",
2973 n
->sym
->name
, where
);
2978 gcc_assert (OMP_LIST_LASTPRIVATE
== OMP_LIST_FIRSTPRIVATE
+ 1);
2979 for (list
= OMP_LIST_FIRSTPRIVATE
; list
<= OMP_LIST_LASTPRIVATE
; list
++)
2980 for (n
= omp_clauses
->lists
[list
]; n
; n
= n
->next
)
2983 gfc_error ("Symbol %qs present on multiple clauses at %L",
2984 n
->sym
->name
, where
);
2988 for (n
= omp_clauses
->lists
[OMP_LIST_FIRSTPRIVATE
]; n
; n
= n
->next
)
2991 gfc_error ("Symbol %qs present on multiple clauses at %L",
2992 n
->sym
->name
, where
);
2996 for (n
= omp_clauses
->lists
[OMP_LIST_LASTPRIVATE
]; n
; n
= n
->next
)
2999 for (n
= omp_clauses
->lists
[OMP_LIST_LASTPRIVATE
]; n
; n
= n
->next
)
3002 gfc_error ("Symbol %qs present on multiple clauses at %L",
3003 n
->sym
->name
, where
);
3008 for (n
= omp_clauses
->lists
[OMP_LIST_ALIGNED
]; n
; n
= n
->next
)
3011 for (n
= omp_clauses
->lists
[OMP_LIST_ALIGNED
]; n
; n
= n
->next
)
3014 gfc_error ("Symbol %qs present on multiple clauses at %L",
3015 n
->sym
->name
, where
);
3020 for (n
= omp_clauses
->lists
[OMP_LIST_TO
]; n
; n
= n
->next
)
3022 for (n
= omp_clauses
->lists
[OMP_LIST_FROM
]; n
; n
= n
->next
)
3023 if (n
->expr
== NULL
)
3025 for (n
= omp_clauses
->lists
[OMP_LIST_TO
]; n
; n
= n
->next
)
3027 if (n
->expr
== NULL
&& n
->sym
->mark
)
3028 gfc_error ("Symbol %qs present on both FROM and TO clauses at %L",
3029 n
->sym
->name
, where
);
3034 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
3035 if ((n
= omp_clauses
->lists
[list
]) != NULL
)
3039 if (list
< OMP_LIST_NUM
)
3040 name
= clause_names
[list
];
3046 case OMP_LIST_COPYIN
:
3047 for (; n
!= NULL
; n
= n
->next
)
3049 if (!n
->sym
->attr
.threadprivate
)
3050 gfc_error ("Non-THREADPRIVATE object %qs in COPYIN clause"
3051 " at %L", n
->sym
->name
, where
);
3054 case OMP_LIST_COPYPRIVATE
:
3055 for (; n
!= NULL
; n
= n
->next
)
3057 if (n
->sym
->as
&& n
->sym
->as
->type
== AS_ASSUMED_SIZE
)
3058 gfc_error ("Assumed size array %qs in COPYPRIVATE clause "
3059 "at %L", n
->sym
->name
, where
);
3060 if (n
->sym
->attr
.pointer
&& n
->sym
->attr
.intent
== INTENT_IN
)
3061 gfc_error ("INTENT(IN) POINTER %qs in COPYPRIVATE clause "
3062 "at %L", n
->sym
->name
, where
);
3065 case OMP_LIST_SHARED
:
3066 for (; n
!= NULL
; n
= n
->next
)
3068 if (n
->sym
->attr
.threadprivate
)
3069 gfc_error ("THREADPRIVATE object %qs in SHARED clause at "
3070 "%L", n
->sym
->name
, where
);
3071 if (n
->sym
->attr
.cray_pointee
)
3072 gfc_error ("Cray pointee %qs in SHARED clause at %L",
3073 n
->sym
->name
, where
);
3074 if (n
->sym
->attr
.associate_var
)
3075 gfc_error ("ASSOCIATE name %qs in SHARED clause at %L",
3076 n
->sym
->name
, where
);
3079 case OMP_LIST_ALIGNED
:
3080 for (; n
!= NULL
; n
= n
->next
)
3082 if (!n
->sym
->attr
.pointer
3083 && !n
->sym
->attr
.allocatable
3084 && !n
->sym
->attr
.cray_pointer
3085 && (n
->sym
->ts
.type
!= BT_DERIVED
3086 || (n
->sym
->ts
.u
.derived
->from_intmod
3087 != INTMOD_ISO_C_BINDING
)
3088 || (n
->sym
->ts
.u
.derived
->intmod_sym_id
3089 != ISOCBINDING_PTR
)))
3090 gfc_error ("%qs in ALIGNED clause must be POINTER, "
3091 "ALLOCATABLE, Cray pointer or C_PTR at %L",
3092 n
->sym
->name
, where
);
3095 gfc_expr
*expr
= n
->expr
;
3097 if (!gfc_resolve_expr (expr
)
3098 || expr
->ts
.type
!= BT_INTEGER
3100 || gfc_extract_int (expr
, &alignment
)
3102 gfc_error ("%qs in ALIGNED clause at %L requires a scalar "
3103 "positive constant integer alignment "
3104 "expression", n
->sym
->name
, where
);
3108 case OMP_LIST_DEPEND
:
3112 for (; n
!= NULL
; n
= n
->next
)
3116 if (!gfc_resolve_expr (n
->expr
)
3117 || n
->expr
->expr_type
!= EXPR_VARIABLE
3118 || n
->expr
->ref
== NULL
3119 || n
->expr
->ref
->next
3120 || n
->expr
->ref
->type
!= REF_ARRAY
)
3121 gfc_error ("%qs in %s clause at %L is not a proper "
3122 "array section", n
->sym
->name
, name
, where
);
3123 else if (n
->expr
->ref
->u
.ar
.codimen
)
3124 gfc_error ("Coarrays not supported in %s clause at %L",
3129 gfc_array_ref
*ar
= &n
->expr
->ref
->u
.ar
;
3130 for (i
= 0; i
< ar
->dimen
; i
++)
3133 gfc_error ("Stride should not be specified for "
3134 "array section in %s clause at %L",
3138 else if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
3139 && ar
->dimen_type
[i
] != DIMEN_RANGE
)
3141 gfc_error ("%qs in %s clause at %L is not a "
3142 "proper array section",
3143 n
->sym
->name
, name
, where
);
3146 else if (list
== OMP_LIST_DEPEND
3148 && ar
->start
[i
]->expr_type
== EXPR_CONSTANT
3150 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
3151 && mpz_cmp (ar
->start
[i
]->value
.integer
,
3152 ar
->end
[i
]->value
.integer
) > 0)
3154 gfc_error ("%qs in DEPEND clause at %L is a "
3155 "zero size array section",
3156 n
->sym
->name
, where
);
3163 if (list
== OMP_LIST_MAP
3164 && n
->u
.map_op
== OMP_MAP_FORCE_DEVICEPTR
)
3165 resolve_oacc_deviceptr_clause (n
->sym
, *where
, name
);
3167 resolve_oacc_data_clauses (n
->sym
, *where
, name
);
3171 if (list
!= OMP_LIST_DEPEND
)
3172 for (n
= omp_clauses
->lists
[list
]; n
!= NULL
; n
= n
->next
)
3174 n
->sym
->attr
.referenced
= 1;
3175 if (n
->sym
->attr
.threadprivate
)
3176 gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
3177 n
->sym
->name
, name
, where
);
3178 if (n
->sym
->attr
.cray_pointee
)
3179 gfc_error ("Cray pointee %qs in %s clause at %L",
3180 n
->sym
->name
, name
, where
);
3184 for (; n
!= NULL
; n
= n
->next
)
3187 if (n
->sym
->attr
.threadprivate
)
3188 gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
3189 n
->sym
->name
, name
, where
);
3190 if (n
->sym
->attr
.cray_pointee
)
3191 gfc_error ("Cray pointee %qs in %s clause at %L",
3192 n
->sym
->name
, name
, where
);
3193 if (n
->sym
->attr
.associate_var
)
3194 gfc_error ("ASSOCIATE name %qs in %s clause at %L",
3195 n
->sym
->name
, name
, where
);
3196 if (list
!= OMP_LIST_PRIVATE
)
3198 if (n
->sym
->attr
.proc_pointer
&& list
== OMP_LIST_REDUCTION
)
3199 gfc_error ("Procedure pointer %qs in %s clause at %L",
3200 n
->sym
->name
, name
, where
);
3201 if (n
->sym
->attr
.pointer
&& list
== OMP_LIST_REDUCTION
)
3202 gfc_error ("POINTER object %qs in %s clause at %L",
3203 n
->sym
->name
, name
, where
);
3204 if (n
->sym
->attr
.cray_pointer
&& list
== OMP_LIST_REDUCTION
)
3205 gfc_error ("Cray pointer %qs in %s clause at %L",
3206 n
->sym
->name
, name
, where
);
3209 && (oacc_is_loop (code
) || code
->op
== EXEC_OACC_PARALLEL
))
3210 check_array_not_assumed (n
->sym
, *where
, name
);
3211 else if (n
->sym
->as
&& n
->sym
->as
->type
== AS_ASSUMED_SIZE
)
3212 gfc_error ("Assumed size array %qs in %s clause at %L",
3213 n
->sym
->name
, name
, where
);
3214 if (n
->sym
->attr
.in_namelist
&& list
!= OMP_LIST_REDUCTION
)
3215 gfc_error ("Variable %qs in %s clause is used in "
3216 "NAMELIST statement at %L",
3217 n
->sym
->name
, name
, where
);
3218 if (n
->sym
->attr
.pointer
&& n
->sym
->attr
.intent
== INTENT_IN
)
3221 case OMP_LIST_PRIVATE
:
3222 case OMP_LIST_LASTPRIVATE
:
3223 case OMP_LIST_LINEAR
:
3224 /* case OMP_LIST_REDUCTION: */
3225 gfc_error ("INTENT(IN) POINTER %qs in %s clause at %L",
3226 n
->sym
->name
, name
, where
);
3234 case OMP_LIST_REDUCTION
:
3235 switch (n
->u
.reduction_op
)
3237 case OMP_REDUCTION_PLUS
:
3238 case OMP_REDUCTION_TIMES
:
3239 case OMP_REDUCTION_MINUS
:
3240 if (!gfc_numeric_ts (&n
->sym
->ts
))
3243 case OMP_REDUCTION_AND
:
3244 case OMP_REDUCTION_OR
:
3245 case OMP_REDUCTION_EQV
:
3246 case OMP_REDUCTION_NEQV
:
3247 if (n
->sym
->ts
.type
!= BT_LOGICAL
)
3250 case OMP_REDUCTION_MAX
:
3251 case OMP_REDUCTION_MIN
:
3252 if (n
->sym
->ts
.type
!= BT_INTEGER
3253 && n
->sym
->ts
.type
!= BT_REAL
)
3256 case OMP_REDUCTION_IAND
:
3257 case OMP_REDUCTION_IOR
:
3258 case OMP_REDUCTION_IEOR
:
3259 if (n
->sym
->ts
.type
!= BT_INTEGER
)
3262 case OMP_REDUCTION_USER
:
3272 const char *udr_name
= NULL
;
3275 udr_name
= n
->udr
->udr
->name
;
3277 = gfc_find_omp_udr (NULL
, udr_name
,
3279 if (n
->udr
->udr
== NULL
)
3287 if (udr_name
== NULL
)
3288 switch (n
->u
.reduction_op
)
3290 case OMP_REDUCTION_PLUS
:
3291 case OMP_REDUCTION_TIMES
:
3292 case OMP_REDUCTION_MINUS
:
3293 case OMP_REDUCTION_AND
:
3294 case OMP_REDUCTION_OR
:
3295 case OMP_REDUCTION_EQV
:
3296 case OMP_REDUCTION_NEQV
:
3297 udr_name
= gfc_op2string ((gfc_intrinsic_op
)
3300 case OMP_REDUCTION_MAX
:
3303 case OMP_REDUCTION_MIN
:
3306 case OMP_REDUCTION_IAND
:
3309 case OMP_REDUCTION_IOR
:
3312 case OMP_REDUCTION_IEOR
:
3318 gfc_error ("!$OMP DECLARE REDUCTION %s not found "
3319 "for type %s at %L", udr_name
,
3320 gfc_typename (&n
->sym
->ts
), where
);
3324 gfc_omp_udr
*udr
= n
->udr
->udr
;
3325 n
->u
.reduction_op
= OMP_REDUCTION_USER
;
3327 = resolve_omp_udr_clause (n
, udr
->combiner_ns
,
3330 if (udr
->initializer_ns
)
3332 = resolve_omp_udr_clause (n
,
3333 udr
->initializer_ns
,
3339 case OMP_LIST_LINEAR
:
3340 if (n
->sym
->ts
.type
!= BT_INTEGER
)
3341 gfc_error ("LINEAR variable %qs must be INTEGER "
3342 "at %L", n
->sym
->name
, where
);
3343 else if (!code
&& !n
->sym
->attr
.value
)
3344 gfc_error ("LINEAR dummy argument %qs must have VALUE "
3345 "attribute at %L", n
->sym
->name
, where
);
3348 gfc_expr
*expr
= n
->expr
;
3349 if (!gfc_resolve_expr (expr
)
3350 || expr
->ts
.type
!= BT_INTEGER
3352 gfc_error ("%qs in LINEAR clause at %L requires "
3353 "a scalar integer linear-step expression",
3354 n
->sym
->name
, where
);
3355 else if (!code
&& expr
->expr_type
!= EXPR_CONSTANT
)
3356 gfc_error ("%qs in LINEAR clause at %L requires "
3357 "a constant integer linear-step expression",
3358 n
->sym
->name
, where
);
3361 /* Workaround for PR middle-end/26316, nothing really needs
3362 to be done here for OMP_LIST_PRIVATE. */
3363 case OMP_LIST_PRIVATE
:
3364 gcc_assert (code
&& code
->op
!= EXEC_NOP
);
3366 case OMP_LIST_USE_DEVICE
:
3367 if (n
->sym
->attr
.allocatable
3368 || (n
->sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (n
->sym
)
3369 && CLASS_DATA (n
->sym
)->attr
.allocatable
))
3370 gfc_error ("ALLOCATABLE object '%s' in %s clause at %L",
3371 n
->sym
->name
, name
, where
);
3372 if (n
->sym
->attr
.pointer
3373 || (n
->sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (n
->sym
)
3374 && CLASS_DATA (n
->sym
)->attr
.class_pointer
))
3375 gfc_error ("POINTER object '%s' in %s clause at %L",
3376 n
->sym
->name
, name
, where
);
3377 if (n
->sym
->attr
.cray_pointer
)
3378 gfc_error ("Cray pointer object '%s' in %s clause at %L",
3379 n
->sym
->name
, name
, where
);
3380 if (n
->sym
->attr
.cray_pointee
)
3381 gfc_error ("Cray pointee object '%s' in %s clause at %L",
3382 n
->sym
->name
, name
, where
);
3384 case OMP_LIST_DEVICE_RESIDENT
:
3385 case OMP_LIST_CACHE
:
3386 check_symbol_not_pointer (n
->sym
, *where
, name
);
3387 check_array_not_assumed (n
->sym
, *where
, name
);
3396 if (omp_clauses
->safelen_expr
)
3398 gfc_expr
*expr
= omp_clauses
->safelen_expr
;
3399 if (!gfc_resolve_expr (expr
)
3400 || expr
->ts
.type
!= BT_INTEGER
|| expr
->rank
!= 0)
3401 gfc_error ("SAFELEN clause at %L requires a scalar "
3402 "INTEGER expression", &expr
->where
);
3404 if (omp_clauses
->simdlen_expr
)
3406 gfc_expr
*expr
= omp_clauses
->simdlen_expr
;
3407 if (!gfc_resolve_expr (expr
)
3408 || expr
->ts
.type
!= BT_INTEGER
|| expr
->rank
!= 0)
3409 gfc_error ("SIMDLEN clause at %L requires a scalar "
3410 "INTEGER expression", &expr
->where
);
3412 if (omp_clauses
->num_teams
)
3414 gfc_expr
*expr
= omp_clauses
->num_teams
;
3415 if (!gfc_resolve_expr (expr
)
3416 || expr
->ts
.type
!= BT_INTEGER
|| expr
->rank
!= 0)
3417 gfc_error ("NUM_TEAMS clause at %L requires a scalar "
3418 "INTEGER expression", &expr
->where
);
3420 if (omp_clauses
->device
)
3422 gfc_expr
*expr
= omp_clauses
->device
;
3423 if (!gfc_resolve_expr (expr
)
3424 || expr
->ts
.type
!= BT_INTEGER
|| expr
->rank
!= 0)
3425 gfc_error ("DEVICE clause at %L requires a scalar "
3426 "INTEGER expression", &expr
->where
);
3428 if (omp_clauses
->dist_chunk_size
)
3430 gfc_expr
*expr
= omp_clauses
->dist_chunk_size
;
3431 if (!gfc_resolve_expr (expr
)
3432 || expr
->ts
.type
!= BT_INTEGER
|| expr
->rank
!= 0)
3433 gfc_error ("DIST_SCHEDULE clause's chunk_size at %L requires "
3434 "a scalar INTEGER expression", &expr
->where
);
3436 if (omp_clauses
->thread_limit
)
3438 gfc_expr
*expr
= omp_clauses
->thread_limit
;
3439 if (!gfc_resolve_expr (expr
)
3440 || expr
->ts
.type
!= BT_INTEGER
|| expr
->rank
!= 0)
3441 gfc_error ("THREAD_LIMIT clause at %L requires a scalar "
3442 "INTEGER expression", &expr
->where
);
3444 if (omp_clauses
->async
)
3445 if (omp_clauses
->async_expr
)
3446 resolve_oacc_scalar_int_expr (omp_clauses
->async_expr
, "ASYNC");
3447 if (omp_clauses
->num_gangs_expr
)
3448 resolve_oacc_positive_int_expr (omp_clauses
->num_gangs_expr
, "NUM_GANGS");
3449 if (omp_clauses
->num_workers_expr
)
3450 resolve_oacc_positive_int_expr (omp_clauses
->num_workers_expr
, "NUM_WORKERS");
3451 if (omp_clauses
->vector_length_expr
)
3452 resolve_oacc_positive_int_expr (omp_clauses
->vector_length_expr
, "VECTOR_LENGTH");
3453 if (omp_clauses
->gang_expr
)
3454 resolve_oacc_positive_int_expr (omp_clauses
->gang_expr
, "GANG");
3455 if (omp_clauses
->worker_expr
)
3456 resolve_oacc_positive_int_expr (omp_clauses
->worker_expr
, "WORKER");
3457 if (omp_clauses
->vector_expr
)
3458 resolve_oacc_positive_int_expr (omp_clauses
->vector_expr
, "VECTOR");
3459 if (omp_clauses
->wait
)
3460 if (omp_clauses
->wait_list
)
3461 for (el
= omp_clauses
->wait_list
; el
; el
= el
->next
)
3462 resolve_oacc_scalar_int_expr (el
->expr
, "WAIT");
3466 /* Return true if SYM is ever referenced in EXPR except in the SE node. */
3469 expr_references_sym (gfc_expr
*e
, gfc_symbol
*s
, gfc_expr
*se
)
3471 gfc_actual_arglist
*arg
;
3472 if (e
== NULL
|| e
== se
)
3474 switch (e
->expr_type
)
3479 case EXPR_STRUCTURE
:
3481 if (e
->symtree
!= NULL
3482 && e
->symtree
->n
.sym
== s
)
3485 case EXPR_SUBSTRING
:
3487 && (expr_references_sym (e
->ref
->u
.ss
.start
, s
, se
)
3488 || expr_references_sym (e
->ref
->u
.ss
.end
, s
, se
)))
3492 if (expr_references_sym (e
->value
.op
.op2
, s
, se
))
3494 return expr_references_sym (e
->value
.op
.op1
, s
, se
);
3496 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
3497 if (expr_references_sym (arg
->expr
, s
, se
))
3506 /* If EXPR is a conversion function that widens the type
3507 if WIDENING is true or narrows the type if WIDENING is false,
3508 return the inner expression, otherwise return NULL. */
3511 is_conversion (gfc_expr
*expr
, bool widening
)
3513 gfc_typespec
*ts1
, *ts2
;
3515 if (expr
->expr_type
!= EXPR_FUNCTION
3516 || expr
->value
.function
.isym
== NULL
3517 || expr
->value
.function
.esym
!= NULL
3518 || expr
->value
.function
.isym
->id
!= GFC_ISYM_CONVERSION
)
3524 ts2
= &expr
->value
.function
.actual
->expr
->ts
;
3528 ts1
= &expr
->value
.function
.actual
->expr
->ts
;
3532 if (ts1
->type
> ts2
->type
3533 || (ts1
->type
== ts2
->type
&& ts1
->kind
> ts2
->kind
))
3534 return expr
->value
.function
.actual
->expr
;
3541 resolve_omp_atomic (gfc_code
*code
)
3543 gfc_code
*atomic_code
= code
;
3545 gfc_expr
*expr2
, *expr2_tmp
;
3546 gfc_omp_atomic_op aop
3547 = (gfc_omp_atomic_op
) (atomic_code
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
);
3549 code
= code
->block
->next
;
3550 gcc_assert (code
->op
== EXEC_ASSIGN
);
3551 gcc_assert (((aop
!= GFC_OMP_ATOMIC_CAPTURE
) && code
->next
== NULL
)
3552 || ((aop
== GFC_OMP_ATOMIC_CAPTURE
)
3553 && code
->next
!= NULL
3554 && code
->next
->op
== EXEC_ASSIGN
3555 && code
->next
->next
== NULL
));
3557 if (code
->expr1
->expr_type
!= EXPR_VARIABLE
3558 || code
->expr1
->symtree
== NULL
3559 || code
->expr1
->rank
!= 0
3560 || (code
->expr1
->ts
.type
!= BT_INTEGER
3561 && code
->expr1
->ts
.type
!= BT_REAL
3562 && code
->expr1
->ts
.type
!= BT_COMPLEX
3563 && code
->expr1
->ts
.type
!= BT_LOGICAL
))
3565 gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
3566 "intrinsic type at %L", &code
->loc
);
3570 var
= code
->expr1
->symtree
->n
.sym
;
3571 expr2
= is_conversion (code
->expr2
, false);
3574 if (aop
== GFC_OMP_ATOMIC_READ
|| aop
== GFC_OMP_ATOMIC_WRITE
)
3575 expr2
= is_conversion (code
->expr2
, true);
3577 expr2
= code
->expr2
;
3582 case GFC_OMP_ATOMIC_READ
:
3583 if (expr2
->expr_type
!= EXPR_VARIABLE
3584 || expr2
->symtree
== NULL
3586 || (expr2
->ts
.type
!= BT_INTEGER
3587 && expr2
->ts
.type
!= BT_REAL
3588 && expr2
->ts
.type
!= BT_COMPLEX
3589 && expr2
->ts
.type
!= BT_LOGICAL
))
3590 gfc_error ("!$OMP ATOMIC READ statement must read from a scalar "
3591 "variable of intrinsic type at %L", &expr2
->where
);
3593 case GFC_OMP_ATOMIC_WRITE
:
3594 if (expr2
->rank
!= 0 || expr_references_sym (code
->expr2
, var
, NULL
))
3595 gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr "
3596 "must be scalar and cannot reference var at %L",
3599 case GFC_OMP_ATOMIC_CAPTURE
:
3601 if (expr2
== code
->expr2
)
3603 expr2_tmp
= is_conversion (code
->expr2
, true);
3604 if (expr2_tmp
== NULL
)
3607 if (expr2_tmp
->expr_type
== EXPR_VARIABLE
)
3609 if (expr2_tmp
->symtree
== NULL
3610 || expr2_tmp
->rank
!= 0
3611 || (expr2_tmp
->ts
.type
!= BT_INTEGER
3612 && expr2_tmp
->ts
.type
!= BT_REAL
3613 && expr2_tmp
->ts
.type
!= BT_COMPLEX
3614 && expr2_tmp
->ts
.type
!= BT_LOGICAL
)
3615 || expr2_tmp
->symtree
->n
.sym
== var
)
3617 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read from "
3618 "a scalar variable of intrinsic type at %L",
3622 var
= expr2_tmp
->symtree
->n
.sym
;
3624 if (code
->expr1
->expr_type
!= EXPR_VARIABLE
3625 || code
->expr1
->symtree
== NULL
3626 || code
->expr1
->rank
!= 0
3627 || (code
->expr1
->ts
.type
!= BT_INTEGER
3628 && code
->expr1
->ts
.type
!= BT_REAL
3629 && code
->expr1
->ts
.type
!= BT_COMPLEX
3630 && code
->expr1
->ts
.type
!= BT_LOGICAL
))
3632 gfc_error ("!$OMP ATOMIC CAPTURE update statement must set "
3633 "a scalar variable of intrinsic type at %L",
3634 &code
->expr1
->where
);
3637 if (code
->expr1
->symtree
->n
.sym
!= var
)
3639 gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
3640 "different variable than update statement writes "
3641 "into at %L", &code
->expr1
->where
);
3644 expr2
= is_conversion (code
->expr2
, false);
3646 expr2
= code
->expr2
;
3653 if (gfc_expr_attr (code
->expr1
).allocatable
)
3655 gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L",
3660 if (aop
== GFC_OMP_ATOMIC_CAPTURE
3661 && code
->next
== NULL
3662 && code
->expr2
->rank
== 0
3663 && !expr_references_sym (code
->expr2
, var
, NULL
))
3664 atomic_code
->ext
.omp_atomic
3665 = (gfc_omp_atomic_op
) (atomic_code
->ext
.omp_atomic
3666 | GFC_OMP_ATOMIC_SWAP
);
3667 else if (expr2
->expr_type
== EXPR_OP
)
3669 gfc_expr
*v
= NULL
, *e
, *c
;
3670 gfc_intrinsic_op op
= expr2
->value
.op
.op
;
3671 gfc_intrinsic_op alt_op
= INTRINSIC_NONE
;
3675 case INTRINSIC_PLUS
:
3676 alt_op
= INTRINSIC_MINUS
;
3678 case INTRINSIC_TIMES
:
3679 alt_op
= INTRINSIC_DIVIDE
;
3681 case INTRINSIC_MINUS
:
3682 alt_op
= INTRINSIC_PLUS
;
3684 case INTRINSIC_DIVIDE
:
3685 alt_op
= INTRINSIC_TIMES
;
3691 alt_op
= INTRINSIC_NEQV
;
3693 case INTRINSIC_NEQV
:
3694 alt_op
= INTRINSIC_EQV
;
3697 gfc_error ("!$OMP ATOMIC assignment operator must be binary "
3698 "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
3703 /* Check for var = var op expr resp. var = expr op var where
3704 expr doesn't reference var and var op expr is mathematically
3705 equivalent to var op (expr) resp. expr op var equivalent to
3706 (expr) op var. We rely here on the fact that the matcher
3707 for x op1 y op2 z where op1 and op2 have equal precedence
3708 returns (x op1 y) op2 z. */
3709 e
= expr2
->value
.op
.op2
;
3710 if (e
->expr_type
== EXPR_VARIABLE
3711 && e
->symtree
!= NULL
3712 && e
->symtree
->n
.sym
== var
)
3714 else if ((c
= is_conversion (e
, true)) != NULL
3715 && c
->expr_type
== EXPR_VARIABLE
3716 && c
->symtree
!= NULL
3717 && c
->symtree
->n
.sym
== var
)
3721 gfc_expr
**p
= NULL
, **q
;
3722 for (q
= &expr2
->value
.op
.op1
; (e
= *q
) != NULL
; )
3723 if (e
->expr_type
== EXPR_VARIABLE
3724 && e
->symtree
!= NULL
3725 && e
->symtree
->n
.sym
== var
)
3730 else if ((c
= is_conversion (e
, true)) != NULL
)
3731 q
= &e
->value
.function
.actual
->expr
;
3732 else if (e
->expr_type
!= EXPR_OP
3733 || (e
->value
.op
.op
!= op
3734 && e
->value
.op
.op
!= alt_op
)
3740 q
= &e
->value
.op
.op1
;
3745 gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
3746 "or var = expr op var at %L", &expr2
->where
);
3753 switch (e
->value
.op
.op
)
3755 case INTRINSIC_MINUS
:
3756 case INTRINSIC_DIVIDE
:
3758 case INTRINSIC_NEQV
:
3759 gfc_error ("!$OMP ATOMIC var = var op expr not "
3760 "mathematically equivalent to var = var op "
3761 "(expr) at %L", &expr2
->where
);
3767 /* Canonicalize into var = var op (expr). */
3768 *p
= e
->value
.op
.op2
;
3769 e
->value
.op
.op2
= expr2
;
3771 if (code
->expr2
== expr2
)
3772 code
->expr2
= expr2
= e
;
3774 code
->expr2
->value
.function
.actual
->expr
= expr2
= e
;
3776 if (!gfc_compare_types (&expr2
->value
.op
.op1
->ts
, &expr2
->ts
))
3778 for (p
= &expr2
->value
.op
.op1
; *p
!= v
;
3779 p
= &(*p
)->value
.function
.actual
->expr
)
3782 gfc_free_expr (expr2
->value
.op
.op1
);
3783 expr2
->value
.op
.op1
= v
;
3784 gfc_convert_type (v
, &expr2
->ts
, 2);
3789 if (e
->rank
!= 0 || expr_references_sym (code
->expr2
, var
, v
))
3791 gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
3792 "must be scalar and cannot reference var at %L",
3797 else if (expr2
->expr_type
== EXPR_FUNCTION
3798 && expr2
->value
.function
.isym
!= NULL
3799 && expr2
->value
.function
.esym
== NULL
3800 && expr2
->value
.function
.actual
!= NULL
3801 && expr2
->value
.function
.actual
->next
!= NULL
)
3803 gfc_actual_arglist
*arg
, *var_arg
;
3805 switch (expr2
->value
.function
.isym
->id
)
3813 if (expr2
->value
.function
.actual
->next
->next
!= NULL
)
3815 gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
3816 "or IEOR must have two arguments at %L",
3822 gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
3823 "MIN, MAX, IAND, IOR or IEOR at %L",
3829 for (arg
= expr2
->value
.function
.actual
; arg
; arg
= arg
->next
)
3831 if ((arg
== expr2
->value
.function
.actual
3832 || (var_arg
== NULL
&& arg
->next
== NULL
))
3833 && arg
->expr
->expr_type
== EXPR_VARIABLE
3834 && arg
->expr
->symtree
!= NULL
3835 && arg
->expr
->symtree
->n
.sym
== var
)
3837 else if (expr_references_sym (arg
->expr
, var
, NULL
))
3839 gfc_error ("!$OMP ATOMIC intrinsic arguments except one must "
3840 "not reference %qs at %L",
3841 var
->name
, &arg
->expr
->where
);
3844 if (arg
->expr
->rank
!= 0)
3846 gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
3847 "at %L", &arg
->expr
->where
);
3852 if (var_arg
== NULL
)
3854 gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
3855 "be %qs at %L", var
->name
, &expr2
->where
);
3859 if (var_arg
!= expr2
->value
.function
.actual
)
3861 /* Canonicalize, so that var comes first. */
3862 gcc_assert (var_arg
->next
== NULL
);
3863 for (arg
= expr2
->value
.function
.actual
;
3864 arg
->next
!= var_arg
; arg
= arg
->next
)
3866 var_arg
->next
= expr2
->value
.function
.actual
;
3867 expr2
->value
.function
.actual
= var_arg
;
3872 gfc_error ("!$OMP ATOMIC assignment must have an operator or "
3873 "intrinsic on right hand side at %L", &expr2
->where
);
3875 if (aop
== GFC_OMP_ATOMIC_CAPTURE
&& code
->next
)
3878 if (code
->expr1
->expr_type
!= EXPR_VARIABLE
3879 || code
->expr1
->symtree
== NULL
3880 || code
->expr1
->rank
!= 0
3881 || (code
->expr1
->ts
.type
!= BT_INTEGER
3882 && code
->expr1
->ts
.type
!= BT_REAL
3883 && code
->expr1
->ts
.type
!= BT_COMPLEX
3884 && code
->expr1
->ts
.type
!= BT_LOGICAL
))
3886 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must set "
3887 "a scalar variable of intrinsic type at %L",
3888 &code
->expr1
->where
);
3892 expr2
= is_conversion (code
->expr2
, false);
3895 expr2
= is_conversion (code
->expr2
, true);
3897 expr2
= code
->expr2
;
3900 if (expr2
->expr_type
!= EXPR_VARIABLE
3901 || expr2
->symtree
== NULL
3903 || (expr2
->ts
.type
!= BT_INTEGER
3904 && expr2
->ts
.type
!= BT_REAL
3905 && expr2
->ts
.type
!= BT_COMPLEX
3906 && expr2
->ts
.type
!= BT_LOGICAL
))
3908 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read "
3909 "from a scalar variable of intrinsic type at %L",
3913 if (expr2
->symtree
->n
.sym
!= var
)
3915 gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
3916 "different variable than update statement writes "
3917 "into at %L", &expr2
->where
);
3924 struct fortran_omp_context
3927 hash_set
<gfc_symbol
*> *sharing_clauses
;
3928 hash_set
<gfc_symbol
*> *private_iterators
;
3929 struct fortran_omp_context
*previous
;
3932 static gfc_code
*omp_current_do_code
;
3933 static int omp_current_do_collapse
;
3936 gfc_resolve_omp_do_blocks (gfc_code
*code
, gfc_namespace
*ns
)
3938 if (code
->block
->next
&& code
->block
->next
->op
== EXEC_DO
)
3943 omp_current_do_code
= code
->block
->next
;
3944 omp_current_do_collapse
= code
->ext
.omp_clauses
->collapse
;
3945 for (i
= 1, c
= omp_current_do_code
; i
< omp_current_do_collapse
; i
++)
3948 if (c
->op
!= EXEC_DO
|| c
->next
== NULL
)
3951 if (c
->op
!= EXEC_DO
)
3954 if (i
< omp_current_do_collapse
|| omp_current_do_collapse
<= 0)
3955 omp_current_do_collapse
= 1;
3957 gfc_resolve_blocks (code
->block
, ns
);
3958 omp_current_do_collapse
= 0;
3959 omp_current_do_code
= NULL
;
3964 gfc_resolve_omp_parallel_blocks (gfc_code
*code
, gfc_namespace
*ns
)
3966 struct fortran_omp_context ctx
;
3967 gfc_omp_clauses
*omp_clauses
= code
->ext
.omp_clauses
;
3968 gfc_omp_namelist
*n
;
3972 ctx
.sharing_clauses
= new hash_set
<gfc_symbol
*>;
3973 ctx
.private_iterators
= new hash_set
<gfc_symbol
*>;
3974 ctx
.previous
= omp_current_ctx
;
3975 ctx
.is_openmp
= true;
3976 omp_current_ctx
= &ctx
;
3978 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
3981 case OMP_LIST_SHARED
:
3982 case OMP_LIST_PRIVATE
:
3983 case OMP_LIST_FIRSTPRIVATE
:
3984 case OMP_LIST_LASTPRIVATE
:
3985 case OMP_LIST_REDUCTION
:
3986 case OMP_LIST_LINEAR
:
3987 for (n
= omp_clauses
->lists
[list
]; n
; n
= n
->next
)
3988 ctx
.sharing_clauses
->add (n
->sym
);
3996 case EXEC_OMP_PARALLEL_DO
:
3997 case EXEC_OMP_PARALLEL_DO_SIMD
:
3998 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
3999 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4000 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4001 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4002 case EXEC_OMP_TEAMS_DISTRIBUTE
:
4003 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4004 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4005 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
4006 gfc_resolve_omp_do_blocks (code
, ns
);
4009 gfc_resolve_blocks (code
->block
, ns
);
4012 omp_current_ctx
= ctx
.previous
;
4013 delete ctx
.sharing_clauses
;
4014 delete ctx
.private_iterators
;
4018 /* Save and clear openmp.c private state. */
4021 gfc_omp_save_and_clear_state (struct gfc_omp_saved_state
*state
)
4023 state
->ptrs
[0] = omp_current_ctx
;
4024 state
->ptrs
[1] = omp_current_do_code
;
4025 state
->ints
[0] = omp_current_do_collapse
;
4026 omp_current_ctx
= NULL
;
4027 omp_current_do_code
= NULL
;
4028 omp_current_do_collapse
= 0;
4032 /* Restore openmp.c private state from the saved state. */
4035 gfc_omp_restore_state (struct gfc_omp_saved_state
*state
)
4037 omp_current_ctx
= (struct fortran_omp_context
*) state
->ptrs
[0];
4038 omp_current_do_code
= (gfc_code
*) state
->ptrs
[1];
4039 omp_current_do_collapse
= state
->ints
[0];
4043 /* Note a DO iterator variable. This is special in !$omp parallel
4044 construct, where they are predetermined private. */
4047 gfc_resolve_do_iterator (gfc_code
*code
, gfc_symbol
*sym
)
4049 int i
= omp_current_do_collapse
;
4050 gfc_code
*c
= omp_current_do_code
;
4052 if (sym
->attr
.threadprivate
)
4055 /* !$omp do and !$omp parallel do iteration variable is predetermined
4056 private just in the !$omp do resp. !$omp parallel do construct,
4057 with no implications for the outer parallel constructs. */
4067 if (omp_current_ctx
== NULL
)
4070 /* An openacc context may represent a data clause. Abort if so. */
4071 if (!omp_current_ctx
->is_openmp
&& !oacc_is_loop (omp_current_ctx
->code
))
4074 if (omp_current_ctx
->is_openmp
4075 && omp_current_ctx
->sharing_clauses
->contains (sym
))
4078 if (! omp_current_ctx
->private_iterators
->add (sym
))
4080 gfc_omp_clauses
*omp_clauses
= omp_current_ctx
->code
->ext
.omp_clauses
;
4081 gfc_omp_namelist
*p
;
4083 p
= gfc_get_omp_namelist ();
4085 p
->next
= omp_clauses
->lists
[OMP_LIST_PRIVATE
];
4086 omp_clauses
->lists
[OMP_LIST_PRIVATE
] = p
;
4092 resolve_omp_do (gfc_code
*code
)
4094 gfc_code
*do_code
, *c
;
4095 int list
, i
, collapse
;
4096 gfc_omp_namelist
*n
;
4099 bool is_simd
= false;
4103 case EXEC_OMP_DISTRIBUTE
: name
= "!$OMP DISTRIBUTE"; break;
4104 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
4105 name
= "!$OMP DISTRIBUTE PARALLEL DO";
4107 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4108 name
= "!$OMP DISTRIBUTE PARALLEL DO SIMD";
4111 case EXEC_OMP_DISTRIBUTE_SIMD
:
4112 name
= "!$OMP DISTRIBUTE SIMD";
4115 case EXEC_OMP_DO
: name
= "!$OMP DO"; break;
4116 case EXEC_OMP_DO_SIMD
: name
= "!$OMP DO SIMD"; is_simd
= true; break;
4117 case EXEC_OMP_PARALLEL_DO
: name
= "!$OMP PARALLEL DO"; break;
4118 case EXEC_OMP_PARALLEL_DO_SIMD
:
4119 name
= "!$OMP PARALLEL DO SIMD";
4122 case EXEC_OMP_SIMD
: name
= "!$OMP SIMD"; is_simd
= true; break;
4123 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
4124 name
= "!$OMP TARGET TEAMS_DISTRIBUTE";
4126 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4127 name
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
4129 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4130 name
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
4133 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4134 name
= "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
4137 case EXEC_OMP_TEAMS_DISTRIBUTE
: name
= "!$OMP TEAMS_DISTRIBUTE"; break;
4138 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4139 name
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
4141 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4142 name
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
4145 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
4146 name
= "!$OMP TEAMS DISTRIBUTE SIMD";
4149 default: gcc_unreachable ();
4152 if (code
->ext
.omp_clauses
)
4153 resolve_omp_clauses (code
, &code
->loc
, code
->ext
.omp_clauses
, NULL
);
4155 do_code
= code
->block
->next
;
4156 collapse
= code
->ext
.omp_clauses
->collapse
;
4159 for (i
= 1; i
<= collapse
; i
++)
4161 if (do_code
->op
== EXEC_DO_WHILE
)
4163 gfc_error ("%s cannot be a DO WHILE or DO without loop control "
4164 "at %L", name
, &do_code
->loc
);
4167 if (do_code
->op
== EXEC_DO_CONCURRENT
)
4169 gfc_error ("%s cannot be a DO CONCURRENT loop at %L", name
,
4173 gcc_assert (do_code
->op
== EXEC_DO
);
4174 if (do_code
->ext
.iterator
->var
->ts
.type
!= BT_INTEGER
)
4175 gfc_error ("%s iteration variable must be of type integer at %L",
4176 name
, &do_code
->loc
);
4177 dovar
= do_code
->ext
.iterator
->var
->symtree
->n
.sym
;
4178 if (dovar
->attr
.threadprivate
)
4179 gfc_error ("%s iteration variable must not be THREADPRIVATE "
4180 "at %L", name
, &do_code
->loc
);
4181 if (code
->ext
.omp_clauses
)
4182 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
4184 ? (list
!= OMP_LIST_PRIVATE
&& list
!= OMP_LIST_LASTPRIVATE
)
4185 : code
->ext
.omp_clauses
->collapse
> 1
4186 ? (list
!= OMP_LIST_LASTPRIVATE
)
4187 : (list
!= OMP_LIST_LINEAR
))
4188 for (n
= code
->ext
.omp_clauses
->lists
[list
]; n
; n
= n
->next
)
4189 if (dovar
== n
->sym
)
4192 gfc_error ("%s iteration variable present on clause "
4193 "other than PRIVATE or LASTPRIVATE at %L",
4194 name
, &do_code
->loc
);
4195 else if (code
->ext
.omp_clauses
->collapse
> 1)
4196 gfc_error ("%s iteration variable present on clause "
4197 "other than LASTPRIVATE at %L",
4198 name
, &do_code
->loc
);
4200 gfc_error ("%s iteration variable present on clause "
4201 "other than LINEAR at %L",
4202 name
, &do_code
->loc
);
4207 gfc_code
*do_code2
= code
->block
->next
;
4210 for (j
= 1; j
< i
; j
++)
4212 gfc_symbol
*ivar
= do_code2
->ext
.iterator
->var
->symtree
->n
.sym
;
4214 || gfc_find_sym_in_expr (ivar
, do_code
->ext
.iterator
->start
)
4215 || gfc_find_sym_in_expr (ivar
, do_code
->ext
.iterator
->end
)
4216 || gfc_find_sym_in_expr (ivar
, do_code
->ext
.iterator
->step
))
4218 gfc_error ("%s collapsed loops don't form rectangular "
4219 "iteration space at %L", name
, &do_code
->loc
);
4224 do_code2
= do_code2
->block
->next
;
4229 for (c
= do_code
->next
; c
; c
= c
->next
)
4230 if (c
->op
!= EXEC_NOP
&& c
->op
!= EXEC_CONTINUE
)
4232 gfc_error ("collapsed %s loops not perfectly nested at %L",
4238 do_code
= do_code
->block
;
4239 if (do_code
->op
!= EXEC_DO
&& do_code
->op
!= EXEC_DO_WHILE
)
4241 gfc_error ("not enough DO loops for collapsed %s at %L",
4245 do_code
= do_code
->next
;
4247 || (do_code
->op
!= EXEC_DO
&& do_code
->op
!= EXEC_DO_WHILE
))
4249 gfc_error ("not enough DO loops for collapsed %s at %L",
4257 oacc_is_parallel (gfc_code
*code
)
4259 return code
->op
== EXEC_OACC_PARALLEL
|| code
->op
== EXEC_OACC_PARALLEL_LOOP
;
4263 oacc_is_kernels (gfc_code
*code
)
4265 return code
->op
== EXEC_OACC_KERNELS
|| code
->op
== EXEC_OACC_KERNELS_LOOP
;
4268 static gfc_statement
4269 omp_code_to_statement (gfc_code
*code
)
4273 case EXEC_OMP_PARALLEL
:
4274 return ST_OMP_PARALLEL
;
4275 case EXEC_OMP_PARALLEL_SECTIONS
:
4276 return ST_OMP_PARALLEL_SECTIONS
;
4277 case EXEC_OMP_SECTIONS
:
4278 return ST_OMP_SECTIONS
;
4279 case EXEC_OMP_ORDERED
:
4280 return ST_OMP_ORDERED
;
4281 case EXEC_OMP_CRITICAL
:
4282 return ST_OMP_CRITICAL
;
4283 case EXEC_OMP_MASTER
:
4284 return ST_OMP_MASTER
;
4285 case EXEC_OMP_SINGLE
:
4286 return ST_OMP_SINGLE
;
4289 case EXEC_OMP_WORKSHARE
:
4290 return ST_OMP_WORKSHARE
;
4291 case EXEC_OMP_PARALLEL_WORKSHARE
:
4292 return ST_OMP_PARALLEL_WORKSHARE
;
4300 static gfc_statement
4301 oacc_code_to_statement (gfc_code
*code
)
4305 case EXEC_OACC_PARALLEL
:
4306 return ST_OACC_PARALLEL
;
4307 case EXEC_OACC_KERNELS
:
4308 return ST_OACC_KERNELS
;
4309 case EXEC_OACC_DATA
:
4310 return ST_OACC_DATA
;
4311 case EXEC_OACC_HOST_DATA
:
4312 return ST_OACC_HOST_DATA
;
4313 case EXEC_OACC_PARALLEL_LOOP
:
4314 return ST_OACC_PARALLEL_LOOP
;
4315 case EXEC_OACC_KERNELS_LOOP
:
4316 return ST_OACC_KERNELS_LOOP
;
4317 case EXEC_OACC_LOOP
:
4318 return ST_OACC_LOOP
;
4325 resolve_oacc_directive_inside_omp_region (gfc_code
*code
)
4327 if (omp_current_ctx
!= NULL
&& omp_current_ctx
->is_openmp
)
4329 gfc_statement st
= omp_code_to_statement (omp_current_ctx
->code
);
4330 gfc_statement oacc_st
= oacc_code_to_statement (code
);
4331 gfc_error ("The %s directive cannot be specified within "
4332 "a %s region at %L", gfc_ascii_statement (oacc_st
),
4333 gfc_ascii_statement (st
), &code
->loc
);
4338 resolve_omp_directive_inside_oacc_region (gfc_code
*code
)
4340 if (omp_current_ctx
!= NULL
&& !omp_current_ctx
->is_openmp
)
4342 gfc_statement st
= oacc_code_to_statement (omp_current_ctx
->code
);
4343 gfc_statement omp_st
= omp_code_to_statement (code
);
4344 gfc_error ("The %s directive cannot be specified within "
4345 "a %s region at %L", gfc_ascii_statement (omp_st
),
4346 gfc_ascii_statement (st
), &code
->loc
);
4352 resolve_oacc_nested_loops (gfc_code
*code
, gfc_code
* do_code
, int collapse
,
4359 for (i
= 1; i
<= collapse
; i
++)
4361 if (do_code
->op
== EXEC_DO_WHILE
)
4363 gfc_error ("!$ACC LOOP cannot be a DO WHILE or DO without loop control "
4364 "at %L", &do_code
->loc
);
4367 gcc_assert (do_code
->op
== EXEC_DO
|| do_code
->op
== EXEC_DO_CONCURRENT
);
4368 if (do_code
->ext
.iterator
->var
->ts
.type
!= BT_INTEGER
)
4369 gfc_error ("!$ACC LOOP iteration variable must be of type integer at %L",
4371 dovar
= do_code
->ext
.iterator
->var
->symtree
->n
.sym
;
4374 gfc_code
*do_code2
= code
->block
->next
;
4377 for (j
= 1; j
< i
; j
++)
4379 gfc_symbol
*ivar
= do_code2
->ext
.iterator
->var
->symtree
->n
.sym
;
4381 || gfc_find_sym_in_expr (ivar
, do_code
->ext
.iterator
->start
)
4382 || gfc_find_sym_in_expr (ivar
, do_code
->ext
.iterator
->end
)
4383 || gfc_find_sym_in_expr (ivar
, do_code
->ext
.iterator
->step
))
4385 gfc_error ("!$ACC LOOP %s loops don't form rectangular iteration space at %L",
4386 clause
, &do_code
->loc
);
4391 do_code2
= do_code2
->block
->next
;
4396 for (c
= do_code
->next
; c
; c
= c
->next
)
4397 if (c
->op
!= EXEC_NOP
&& c
->op
!= EXEC_CONTINUE
)
4399 gfc_error ("%s !$ACC LOOP loops not perfectly nested at %L",
4405 do_code
= do_code
->block
;
4406 if (do_code
->op
!= EXEC_DO
&& do_code
->op
!= EXEC_DO_WHILE
4407 && do_code
->op
!= EXEC_DO_CONCURRENT
)
4409 gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
4410 clause
, &code
->loc
);
4413 do_code
= do_code
->next
;
4415 || (do_code
->op
!= EXEC_DO
&& do_code
->op
!= EXEC_DO_WHILE
4416 && do_code
->op
!= EXEC_DO_CONCURRENT
))
4418 gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
4419 clause
, &code
->loc
);
4427 resolve_oacc_params_in_parallel (gfc_code
*code
, const char *clause
)
4429 fortran_omp_context
*c
;
4431 if (oacc_is_parallel (code
))
4432 gfc_error ("!$ACC LOOP %s in PARALLEL region doesn't allow "
4433 "non-static arguments at %L", clause
, &code
->loc
);
4434 for (c
= omp_current_ctx
; c
; c
= c
->previous
)
4436 if (oacc_is_loop (c
->code
))
4438 if (oacc_is_parallel (c
->code
))
4439 gfc_error ("!$ACC LOOP %s in PARALLEL region doesn't allow "
4440 "non-static arguments at %L", clause
, &code
->loc
);
4446 resolve_oacc_loop_blocks (gfc_code
*code
)
4448 fortran_omp_context
*c
;
4450 if (!oacc_is_loop (code
))
4453 if (code
->op
== EXEC_OACC_LOOP
)
4454 for (c
= omp_current_ctx
; c
; c
= c
->previous
)
4456 if (oacc_is_loop (c
->code
))
4458 if (code
->ext
.omp_clauses
->gang
)
4460 if (c
->code
->ext
.omp_clauses
->gang
)
4461 gfc_error ("Loop parallelized across gangs is not allowed "
4462 "inside another loop parallelized across gangs at %L",
4464 if (c
->code
->ext
.omp_clauses
->worker
)
4465 gfc_error ("Loop parallelized across gangs is not allowed "
4466 "inside loop parallelized across workers at %L",
4468 if (c
->code
->ext
.omp_clauses
->vector
)
4469 gfc_error ("Loop parallelized across gangs is not allowed "
4470 "inside loop parallelized across workers at %L",
4473 if (code
->ext
.omp_clauses
->worker
)
4475 if (c
->code
->ext
.omp_clauses
->worker
)
4476 gfc_error ("Loop parallelized across workers is not allowed "
4477 "inside another loop parallelized across workers at %L",
4479 if (c
->code
->ext
.omp_clauses
->vector
)
4480 gfc_error ("Loop parallelized across workers is not allowed "
4481 "inside another loop parallelized across vectors at %L",
4484 if (code
->ext
.omp_clauses
->vector
)
4485 if (c
->code
->ext
.omp_clauses
->vector
)
4486 gfc_error ("Loop parallelized across vectors is not allowed "
4487 "inside another loop parallelized across vectors at %L",
4491 if (oacc_is_parallel (c
->code
) || oacc_is_kernels (c
->code
))
4495 if (code
->ext
.omp_clauses
->seq
)
4497 if (code
->ext
.omp_clauses
->independent
)
4498 gfc_error ("Clause SEQ conflicts with INDEPENDENT at %L", &code
->loc
);
4499 if (code
->ext
.omp_clauses
->gang
)
4500 gfc_error ("Clause SEQ conflicts with GANG at %L", &code
->loc
);
4501 if (code
->ext
.omp_clauses
->worker
)
4502 gfc_error ("Clause SEQ conflicts with WORKER at %L", &code
->loc
);
4503 if (code
->ext
.omp_clauses
->vector
)
4504 gfc_error ("Clause SEQ conflicts with VECTOR at %L", &code
->loc
);
4505 if (code
->ext
.omp_clauses
->par_auto
)
4506 gfc_error ("Clause SEQ conflicts with AUTO at %L", &code
->loc
);
4508 if (code
->ext
.omp_clauses
->par_auto
)
4510 if (code
->ext
.omp_clauses
->gang
)
4511 gfc_error ("Clause AUTO conflicts with GANG at %L", &code
->loc
);
4512 if (code
->ext
.omp_clauses
->worker
)
4513 gfc_error ("Clause AUTO conflicts with WORKER at %L", &code
->loc
);
4514 if (code
->ext
.omp_clauses
->vector
)
4515 gfc_error ("Clause AUTO conflicts with VECTOR at %L", &code
->loc
);
4517 if (!code
->ext
.omp_clauses
->tile_list
)
4519 if (code
->ext
.omp_clauses
->gang
)
4521 if (code
->ext
.omp_clauses
->worker
)
4522 gfc_error ("Clause GANG conflicts with WORKER at %L", &code
->loc
);
4523 if (code
->ext
.omp_clauses
->vector
)
4524 gfc_error ("Clause GANG conflicts with VECTOR at %L", &code
->loc
);
4526 if (code
->ext
.omp_clauses
->worker
)
4527 if (code
->ext
.omp_clauses
->vector
)
4528 gfc_error ("Clause WORKER conflicts with VECTOR at %L", &code
->loc
);
4530 else if (code
->ext
.omp_clauses
->gang
4531 && code
->ext
.omp_clauses
->worker
4532 && code
->ext
.omp_clauses
->vector
)
4533 gfc_error ("Tiled loop cannot be parallelized across gangs, workers and "
4534 "vectors at the same time at %L", &code
->loc
);
4536 if (code
->ext
.omp_clauses
->gang
4537 && code
->ext
.omp_clauses
->gang_expr
4538 && !code
->ext
.omp_clauses
->gang_static
)
4539 resolve_oacc_params_in_parallel (code
, "GANG");
4541 if (code
->ext
.omp_clauses
->worker
4542 && code
->ext
.omp_clauses
->worker_expr
)
4543 resolve_oacc_params_in_parallel (code
, "WORKER");
4545 if (code
->ext
.omp_clauses
->tile_list
)
4549 for (el
= code
->ext
.omp_clauses
->tile_list
; el
; el
= el
->next
)
4552 if (el
->expr
== NULL
)
4554 resolve_oacc_positive_int_expr (el
->expr
, "TILE");
4555 if (el
->expr
->expr_type
!= EXPR_CONSTANT
)
4556 gfc_error ("TILE requires constant expression at %L", &code
->loc
);
4558 resolve_oacc_nested_loops (code
, code
->block
->next
, num
, "tiled");
4564 gfc_resolve_oacc_blocks (gfc_code
*code
, gfc_namespace
*ns
)
4566 fortran_omp_context ctx
;
4568 resolve_oacc_loop_blocks (code
);
4571 ctx
.sharing_clauses
= NULL
;
4572 ctx
.private_iterators
= new hash_set
<gfc_symbol
*>;
4573 ctx
.previous
= omp_current_ctx
;
4574 ctx
.is_openmp
= false;
4575 omp_current_ctx
= &ctx
;
4577 gfc_resolve_blocks (code
->block
, ns
);
4579 omp_current_ctx
= ctx
.previous
;
4580 delete ctx
.private_iterators
;
4585 resolve_oacc_loop (gfc_code
*code
)
4590 if (code
->ext
.omp_clauses
)
4591 resolve_omp_clauses (code
, &code
->loc
, code
->ext
.omp_clauses
, NULL
, true);
4593 do_code
= code
->block
->next
;
4594 collapse
= code
->ext
.omp_clauses
->collapse
;
4598 resolve_oacc_nested_loops (code
, do_code
, collapse
, "collapsed");
4603 resolve_oacc_cache (gfc_code
*code ATTRIBUTE_UNUSED
)
4605 sorry ("Sorry, !$ACC cache unimplemented yet");
4610 gfc_resolve_oacc_declare (gfc_namespace
*ns
)
4613 gfc_omp_namelist
*n
;
4616 if (ns
->oacc_declare_clauses
== NULL
)
4619 loc
= ns
->oacc_declare_clauses
->loc
;
4621 for (list
= OMP_LIST_DEVICE_RESIDENT
;
4622 list
<= OMP_LIST_DEVICE_RESIDENT
; list
++)
4623 for (n
= ns
->oacc_declare_clauses
->lists
[list
]; n
; n
= n
->next
)
4626 if (n
->sym
->attr
.flavor
== FL_PARAMETER
)
4627 gfc_error ("PARAMETER object '%s' is not allowed at %L", n
->sym
->name
, &loc
);
4630 for (list
= OMP_LIST_DEVICE_RESIDENT
;
4631 list
<= OMP_LIST_DEVICE_RESIDENT
; list
++)
4632 for (n
= ns
->oacc_declare_clauses
->lists
[list
]; n
; n
= n
->next
)
4635 gfc_error ("Symbol '%s' present on multiple clauses at %L",
4636 n
->sym
->name
, &loc
);
4641 for (n
= ns
->oacc_declare_clauses
->lists
[OMP_LIST_DEVICE_RESIDENT
]; n
;
4643 check_array_not_assumed (n
->sym
, loc
, "DEVICE_RESIDENT");
4648 gfc_resolve_oacc_directive (gfc_code
*code
, gfc_namespace
*ns ATTRIBUTE_UNUSED
)
4650 resolve_oacc_directive_inside_omp_region (code
);
4654 case EXEC_OACC_PARALLEL
:
4655 case EXEC_OACC_KERNELS
:
4656 case EXEC_OACC_DATA
:
4657 case EXEC_OACC_HOST_DATA
:
4658 case EXEC_OACC_UPDATE
:
4659 case EXEC_OACC_ENTER_DATA
:
4660 case EXEC_OACC_EXIT_DATA
:
4661 case EXEC_OACC_WAIT
:
4662 resolve_omp_clauses (code
, &code
->loc
, code
->ext
.omp_clauses
, NULL
,
4665 case EXEC_OACC_PARALLEL_LOOP
:
4666 case EXEC_OACC_KERNELS_LOOP
:
4667 case EXEC_OACC_LOOP
:
4668 resolve_oacc_loop (code
);
4670 case EXEC_OACC_CACHE
:
4671 resolve_oacc_cache (code
);
4679 /* Resolve OpenMP directive clauses and check various requirements
4680 of each directive. */
4683 gfc_resolve_omp_directive (gfc_code
*code
, gfc_namespace
*ns ATTRIBUTE_UNUSED
)
4685 resolve_omp_directive_inside_oacc_region (code
);
4687 if (code
->op
!= EXEC_OMP_ATOMIC
)
4688 gfc_maybe_initialize_eh ();
4692 case EXEC_OMP_DISTRIBUTE
:
4693 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
4694 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4695 case EXEC_OMP_DISTRIBUTE_SIMD
:
4697 case EXEC_OMP_DO_SIMD
:
4698 case EXEC_OMP_PARALLEL_DO
:
4699 case EXEC_OMP_PARALLEL_DO_SIMD
:
4701 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
4702 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4703 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4704 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4705 case EXEC_OMP_TEAMS_DISTRIBUTE
:
4706 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4707 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4708 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
4709 resolve_omp_do (code
);
4711 case EXEC_OMP_CANCEL
:
4712 case EXEC_OMP_PARALLEL_WORKSHARE
:
4713 case EXEC_OMP_PARALLEL
:
4714 case EXEC_OMP_PARALLEL_SECTIONS
:
4715 case EXEC_OMP_SECTIONS
:
4716 case EXEC_OMP_SINGLE
:
4717 case EXEC_OMP_TARGET
:
4718 case EXEC_OMP_TARGET_DATA
:
4719 case EXEC_OMP_TARGET_TEAMS
:
4721 case EXEC_OMP_TEAMS
:
4722 case EXEC_OMP_WORKSHARE
:
4723 if (code
->ext
.omp_clauses
)
4724 resolve_omp_clauses (code
, &code
->loc
, code
->ext
.omp_clauses
, NULL
);
4726 case EXEC_OMP_TARGET_UPDATE
:
4727 if (code
->ext
.omp_clauses
)
4728 resolve_omp_clauses (code
, &code
->loc
, code
->ext
.omp_clauses
, NULL
);
4729 if (code
->ext
.omp_clauses
== NULL
4730 || (code
->ext
.omp_clauses
->lists
[OMP_LIST_TO
] == NULL
4731 && code
->ext
.omp_clauses
->lists
[OMP_LIST_FROM
] == NULL
))
4732 gfc_error ("OMP TARGET UPDATE at %L requires at least one TO or "
4733 "FROM clause", &code
->loc
);
4735 case EXEC_OMP_ATOMIC
:
4736 resolve_omp_atomic (code
);
4743 /* Resolve !$omp declare simd constructs in NS. */
4746 gfc_resolve_omp_declare_simd (gfc_namespace
*ns
)
4748 gfc_omp_declare_simd
*ods
;
4750 for (ods
= ns
->omp_declare_simd
; ods
; ods
= ods
->next
)
4752 if (ods
->proc_name
!= ns
->proc_name
)
4753 gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure "
4754 "%qs at %L", ns
->proc_name
->name
, &ods
->where
);
4756 resolve_omp_clauses (NULL
, &ods
->where
, ods
->clauses
, ns
);
4760 struct omp_udr_callback_data
4762 gfc_omp_udr
*omp_udr
;
4763 bool is_initializer
;
4767 omp_udr_callback (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
4770 struct omp_udr_callback_data
*cd
= (struct omp_udr_callback_data
*) data
;
4771 if ((*e
)->expr_type
== EXPR_VARIABLE
)
4773 if (cd
->is_initializer
)
4775 if ((*e
)->symtree
->n
.sym
!= cd
->omp_udr
->omp_priv
4776 && (*e
)->symtree
->n
.sym
!= cd
->omp_udr
->omp_orig
)
4777 gfc_error ("Variable other than OMP_PRIV or OMP_ORIG used in "
4778 "INITIALIZER clause of !$OMP DECLARE REDUCTION at %L",
4783 if ((*e
)->symtree
->n
.sym
!= cd
->omp_udr
->omp_out
4784 && (*e
)->symtree
->n
.sym
!= cd
->omp_udr
->omp_in
)
4785 gfc_error ("Variable other than OMP_OUT or OMP_IN used in "
4786 "combiner of !$OMP DECLARE REDUCTION at %L",
4793 /* Resolve !$omp declare reduction constructs. */
4796 gfc_resolve_omp_udr (gfc_omp_udr
*omp_udr
)
4798 gfc_actual_arglist
*a
;
4799 const char *predef_name
= NULL
;
4801 switch (omp_udr
->rop
)
4803 case OMP_REDUCTION_PLUS
:
4804 case OMP_REDUCTION_TIMES
:
4805 case OMP_REDUCTION_MINUS
:
4806 case OMP_REDUCTION_AND
:
4807 case OMP_REDUCTION_OR
:
4808 case OMP_REDUCTION_EQV
:
4809 case OMP_REDUCTION_NEQV
:
4810 case OMP_REDUCTION_MAX
:
4811 case OMP_REDUCTION_USER
:
4814 gfc_error ("Invalid operator for !$OMP DECLARE REDUCTION %s at %L",
4815 omp_udr
->name
, &omp_udr
->where
);
4819 if (gfc_omp_udr_predef (omp_udr
->rop
, omp_udr
->name
,
4820 &omp_udr
->ts
, &predef_name
))
4823 gfc_error_now ("Redefinition of predefined %s "
4824 "!$OMP DECLARE REDUCTION at %L",
4825 predef_name
, &omp_udr
->where
);
4827 gfc_error_now ("Redefinition of predefined "
4828 "!$OMP DECLARE REDUCTION at %L", &omp_udr
->where
);
4832 if (omp_udr
->ts
.type
== BT_CHARACTER
4833 && omp_udr
->ts
.u
.cl
->length
4834 && omp_udr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
4836 gfc_error ("CHARACTER length in !$OMP DECLARE REDUCTION %s not "
4837 "constant at %L", omp_udr
->name
, &omp_udr
->where
);
4841 struct omp_udr_callback_data cd
;
4842 cd
.omp_udr
= omp_udr
;
4843 cd
.is_initializer
= false;
4844 gfc_code_walker (&omp_udr
->combiner_ns
->code
, gfc_dummy_code_callback
,
4845 omp_udr_callback
, &cd
);
4846 if (omp_udr
->combiner_ns
->code
->op
== EXEC_CALL
)
4848 for (a
= omp_udr
->combiner_ns
->code
->ext
.actual
; a
; a
= a
->next
)
4849 if (a
->expr
== NULL
)
4852 gfc_error ("Subroutine call with alternate returns in combiner "
4853 "of !$OMP DECLARE REDUCTION at %L",
4854 &omp_udr
->combiner_ns
->code
->loc
);
4856 if (omp_udr
->initializer_ns
)
4858 cd
.is_initializer
= true;
4859 gfc_code_walker (&omp_udr
->initializer_ns
->code
, gfc_dummy_code_callback
,
4860 omp_udr_callback
, &cd
);
4861 if (omp_udr
->initializer_ns
->code
->op
== EXEC_CALL
)
4863 for (a
= omp_udr
->initializer_ns
->code
->ext
.actual
; a
; a
= a
->next
)
4864 if (a
->expr
== NULL
)
4867 gfc_error ("Subroutine call with alternate returns in "
4868 "INITIALIZER clause of !$OMP DECLARE REDUCTION "
4869 "at %L", &omp_udr
->initializer_ns
->code
->loc
);
4870 for (a
= omp_udr
->initializer_ns
->code
->ext
.actual
; a
; a
= a
->next
)
4872 && a
->expr
->expr_type
== EXPR_VARIABLE
4873 && a
->expr
->symtree
->n
.sym
== omp_udr
->omp_priv
4874 && a
->expr
->ref
== NULL
)
4877 gfc_error ("One of actual subroutine arguments in INITIALIZER "
4878 "clause of !$OMP DECLARE REDUCTION must be OMP_PRIV "
4879 "at %L", &omp_udr
->initializer_ns
->code
->loc
);
4882 else if (omp_udr
->ts
.type
== BT_DERIVED
4883 && !gfc_has_default_initializer (omp_udr
->ts
.u
.derived
))
4885 gfc_error ("Missing INITIALIZER clause for !$OMP DECLARE REDUCTION "
4886 "of derived type without default initializer at %L",
4893 gfc_resolve_omp_udrs (gfc_symtree
*st
)
4895 gfc_omp_udr
*omp_udr
;
4899 gfc_resolve_omp_udrs (st
->left
);
4900 gfc_resolve_omp_udrs (st
->right
);
4901 for (omp_udr
= st
->n
.omp_udr
; omp_udr
; omp_udr
= omp_udr
->next
)
4902 gfc_resolve_omp_udr (omp_udr
);