1 /* OpenMP directive matching and resolving.
2 Copyright (C) 2005-2016 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"
28 #include "diagnostic.h"
29 #include "gomp-constants.h"
31 /* Match an end of OpenMP directive. End of OpenMP directive is optional
32 whitespace, followed by '\n' or comment '!'. */
35 gfc_match_omp_eos (void)
40 old_loc
= gfc_current_locus
;
41 gfc_gobble_whitespace ();
43 c
= gfc_next_ascii_char ();
48 c
= gfc_next_ascii_char ();
56 gfc_current_locus
= old_loc
;
60 /* Free an omp_clauses structure. */
63 gfc_free_omp_clauses (gfc_omp_clauses
*c
)
69 gfc_free_expr (c
->if_expr
);
70 gfc_free_expr (c
->final_expr
);
71 gfc_free_expr (c
->num_threads
);
72 gfc_free_expr (c
->chunk_size
);
73 gfc_free_expr (c
->safelen_expr
);
74 gfc_free_expr (c
->simdlen_expr
);
75 gfc_free_expr (c
->num_teams
);
76 gfc_free_expr (c
->device
);
77 gfc_free_expr (c
->thread_limit
);
78 gfc_free_expr (c
->dist_chunk_size
);
79 gfc_free_expr (c
->async_expr
);
80 gfc_free_expr (c
->gang_num_expr
);
81 gfc_free_expr (c
->gang_static_expr
);
82 gfc_free_expr (c
->worker_expr
);
83 gfc_free_expr (c
->vector_expr
);
84 gfc_free_expr (c
->num_gangs_expr
);
85 gfc_free_expr (c
->num_workers_expr
);
86 gfc_free_expr (c
->vector_length_expr
);
87 for (i
= 0; i
< OMP_LIST_NUM
; i
++)
88 gfc_free_omp_namelist (c
->lists
[i
]);
89 gfc_free_expr_list (c
->wait_list
);
90 gfc_free_expr_list (c
->tile_list
);
94 /* Free oacc_declare structures. */
97 gfc_free_oacc_declare_clauses (struct gfc_oacc_declare
*oc
)
99 struct gfc_oacc_declare
*decl
= oc
;
103 struct gfc_oacc_declare
*next
;
106 gfc_free_omp_clauses (decl
->clauses
);
113 /* Free expression list. */
115 gfc_free_expr_list (gfc_expr_list
*list
)
119 for (; list
; list
= n
)
126 /* Free an !$omp declare simd construct list. */
129 gfc_free_omp_declare_simd (gfc_omp_declare_simd
*ods
)
133 gfc_free_omp_clauses (ods
->clauses
);
139 gfc_free_omp_declare_simd_list (gfc_omp_declare_simd
*list
)
143 gfc_omp_declare_simd
*current
= list
;
145 gfc_free_omp_declare_simd (current
);
149 /* Free an !$omp declare reduction. */
152 gfc_free_omp_udr (gfc_omp_udr
*omp_udr
)
156 gfc_free_omp_udr (omp_udr
->next
);
157 gfc_free_namespace (omp_udr
->combiner_ns
);
158 if (omp_udr
->initializer_ns
)
159 gfc_free_namespace (omp_udr
->initializer_ns
);
166 gfc_find_omp_udr (gfc_namespace
*ns
, const char *name
, gfc_typespec
*ts
)
174 gfc_omp_udr
*omp_udr
;
176 st
= gfc_find_symtree (ns
->omp_udr_root
, name
);
179 for (omp_udr
= st
->n
.omp_udr
; omp_udr
; omp_udr
= omp_udr
->next
)
182 else if (gfc_compare_types (&omp_udr
->ts
, ts
))
184 if (ts
->type
== BT_CHARACTER
)
186 if (omp_udr
->ts
.u
.cl
->length
== NULL
)
188 if (ts
->u
.cl
->length
== NULL
)
190 if (gfc_compare_expr (omp_udr
->ts
.u
.cl
->length
,
199 /* Don't escape an interface block. */
200 if (ns
&& !ns
->has_import_set
201 && ns
->proc_name
&& ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
212 /* Match a variable/common block list and construct a namelist from it. */
215 gfc_match_omp_variable_list (const char *str
, gfc_omp_namelist
**list
,
216 bool allow_common
, bool *end_colon
= NULL
,
217 gfc_omp_namelist
***headp
= NULL
,
218 bool allow_sections
= false)
220 gfc_omp_namelist
*head
, *tail
, *p
;
221 locus old_loc
, cur_loc
;
222 char n
[GFC_MAX_SYMBOL_LEN
+1];
229 old_loc
= gfc_current_locus
;
237 cur_loc
= gfc_current_locus
;
238 m
= gfc_match_symbol (&sym
, 1);
244 if (allow_sections
&& gfc_peek_ascii_char () == '(')
246 gfc_current_locus
= cur_loc
;
247 m
= gfc_match_variable (&expr
, 0);
258 gfc_set_sym_referenced (sym
);
259 p
= gfc_get_omp_namelist ();
269 tail
->where
= cur_loc
;
280 m
= gfc_match (" / %n /", n
);
281 if (m
== MATCH_ERROR
)
286 st
= gfc_find_symtree (gfc_current_ns
->common_root
, n
);
289 gfc_error ("COMMON block /%s/ not found at %C", n
);
292 for (sym
= st
->n
.common
->head
; sym
; sym
= sym
->common_next
)
294 gfc_set_sym_referenced (sym
);
295 p
= gfc_get_omp_namelist ();
304 tail
->where
= cur_loc
;
308 if (end_colon
&& gfc_match_char (':') == MATCH_YES
)
313 if (gfc_match_char (')') == MATCH_YES
)
315 if (gfc_match_char (',') != MATCH_YES
)
320 list
= &(*list
)->next
;
328 gfc_error ("Syntax error in OpenMP variable list at %C");
331 gfc_free_omp_namelist (head
);
332 gfc_current_locus
= old_loc
;
337 match_oacc_expr_list (const char *str
, gfc_expr_list
**list
,
340 gfc_expr_list
*head
, *tail
, *p
;
347 old_loc
= gfc_current_locus
;
355 m
= gfc_match_expr (&expr
);
356 if (m
== MATCH_YES
|| allow_asterisk
)
358 p
= gfc_get_expr_list ();
368 else if (gfc_match (" *") != MATCH_YES
)
372 if (m
== MATCH_ERROR
)
377 if (gfc_match_char (')') == MATCH_YES
)
379 if (gfc_match_char (',') != MATCH_YES
)
384 list
= &(*list
)->next
;
390 gfc_error ("Syntax error in OpenACC expression list at %C");
393 gfc_free_expr_list (head
);
394 gfc_current_locus
= old_loc
;
399 match_oacc_clause_gwv (gfc_omp_clauses
*cp
, unsigned gwv
)
401 match ret
= MATCH_YES
;
403 if (gfc_match (" ( ") != MATCH_YES
)
406 if (gwv
== GOMP_DIM_GANG
)
408 /* The gang clause accepts two optional arguments, num and static.
409 The num argument may either be explicit (num: <val>) or
410 implicit without (<val> without num:). */
412 while (ret
== MATCH_YES
)
414 if (gfc_match (" static :") == MATCH_YES
)
419 cp
->gang_static
= true;
420 if (gfc_match_char ('*') == MATCH_YES
)
421 cp
->gang_static_expr
= NULL
;
422 else if (gfc_match (" %e ", &cp
->gang_static_expr
) != MATCH_YES
)
427 if (cp
->gang_num_expr
)
430 /* The 'num' argument is optional. */
431 gfc_match (" num :");
433 if (gfc_match (" %e ", &cp
->gang_num_expr
) != MATCH_YES
)
437 ret
= gfc_match (" , ");
440 else if (gwv
== GOMP_DIM_WORKER
)
442 /* The 'num' argument is optional. */
443 gfc_match (" num :");
445 if (gfc_match (" %e ", &cp
->worker_expr
) != MATCH_YES
)
448 else if (gwv
== GOMP_DIM_VECTOR
)
450 /* The 'length' argument is optional. */
451 gfc_match (" length :");
453 if (gfc_match (" %e ", &cp
->vector_expr
) != MATCH_YES
)
457 gfc_fatal_error ("Unexpected OpenACC parallelism.");
459 return gfc_match (" )");
463 gfc_match_oacc_clause_link (const char *str
, gfc_omp_namelist
**list
)
465 gfc_omp_namelist
*head
= NULL
;
466 gfc_omp_namelist
*tail
, *p
;
468 char n
[GFC_MAX_SYMBOL_LEN
+1];
473 old_loc
= gfc_current_locus
;
479 m
= gfc_match (" (");
483 m
= gfc_match_symbol (&sym
, 0);
487 if (sym
->attr
.in_common
)
489 gfc_error_now ("Variable at %C is an element of a COMMON block");
492 gfc_set_sym_referenced (sym
);
493 p
= gfc_get_omp_namelist ();
503 tail
->where
= gfc_current_locus
;
512 m
= gfc_match (" / %n /", n
);
513 if (m
== MATCH_ERROR
)
515 if (m
== MATCH_NO
|| n
[0] == '\0')
518 st
= gfc_find_symtree (gfc_current_ns
->common_root
, n
);
521 gfc_error ("COMMON block /%s/ not found at %C", n
);
525 for (sym
= st
->n
.common
->head
; sym
; sym
= sym
->common_next
)
527 gfc_set_sym_referenced (sym
);
528 p
= gfc_get_omp_namelist ();
537 tail
->where
= gfc_current_locus
;
541 if (gfc_match_char (')') == MATCH_YES
)
543 if (gfc_match_char (',') != MATCH_YES
)
547 if (gfc_match_omp_eos () != MATCH_YES
)
549 gfc_error ("Unexpected junk after !$ACC DECLARE at %C");
554 list
= &(*list
)->next
;
559 gfc_error ("Syntax error in !$ACC DECLARE list at %C");
562 gfc_current_locus
= old_loc
;
566 #define OMP_CLAUSE_PRIVATE ((uint64_t) 1 << 0)
567 #define OMP_CLAUSE_FIRSTPRIVATE ((uint64_t) 1 << 1)
568 #define OMP_CLAUSE_LASTPRIVATE ((uint64_t) 1 << 2)
569 #define OMP_CLAUSE_COPYPRIVATE ((uint64_t) 1 << 3)
570 #define OMP_CLAUSE_SHARED ((uint64_t) 1 << 4)
571 #define OMP_CLAUSE_COPYIN ((uint64_t) 1 << 5)
572 #define OMP_CLAUSE_REDUCTION ((uint64_t) 1 << 6)
573 #define OMP_CLAUSE_IF ((uint64_t) 1 << 7)
574 #define OMP_CLAUSE_NUM_THREADS ((uint64_t) 1 << 8)
575 #define OMP_CLAUSE_SCHEDULE ((uint64_t) 1 << 9)
576 #define OMP_CLAUSE_DEFAULT ((uint64_t) 1 << 10)
577 #define OMP_CLAUSE_ORDERED ((uint64_t) 1 << 11)
578 #define OMP_CLAUSE_COLLAPSE ((uint64_t) 1 << 12)
579 #define OMP_CLAUSE_UNTIED ((uint64_t) 1 << 13)
580 #define OMP_CLAUSE_FINAL ((uint64_t) 1 << 14)
581 #define OMP_CLAUSE_MERGEABLE ((uint64_t) 1 << 15)
582 #define OMP_CLAUSE_ALIGNED ((uint64_t) 1 << 16)
583 #define OMP_CLAUSE_DEPEND ((uint64_t) 1 << 17)
584 #define OMP_CLAUSE_INBRANCH ((uint64_t) 1 << 18)
585 #define OMP_CLAUSE_LINEAR ((uint64_t) 1 << 19)
586 #define OMP_CLAUSE_NOTINBRANCH ((uint64_t) 1 << 20)
587 #define OMP_CLAUSE_PROC_BIND ((uint64_t) 1 << 21)
588 #define OMP_CLAUSE_SAFELEN ((uint64_t) 1 << 22)
589 #define OMP_CLAUSE_SIMDLEN ((uint64_t) 1 << 23)
590 #define OMP_CLAUSE_UNIFORM ((uint64_t) 1 << 24)
591 #define OMP_CLAUSE_DEVICE ((uint64_t) 1 << 25)
592 #define OMP_CLAUSE_MAP ((uint64_t) 1 << 26)
593 #define OMP_CLAUSE_TO ((uint64_t) 1 << 27)
594 #define OMP_CLAUSE_FROM ((uint64_t) 1 << 28)
595 #define OMP_CLAUSE_NUM_TEAMS ((uint64_t) 1 << 29)
596 #define OMP_CLAUSE_THREAD_LIMIT ((uint64_t) 1 << 30)
597 #define OMP_CLAUSE_DIST_SCHEDULE ((uint64_t) 1 << 31)
599 /* OpenACC 2.0 clauses. */
600 #define OMP_CLAUSE_ASYNC ((uint64_t) 1 << 32)
601 #define OMP_CLAUSE_NUM_GANGS ((uint64_t) 1 << 33)
602 #define OMP_CLAUSE_NUM_WORKERS ((uint64_t) 1 << 34)
603 #define OMP_CLAUSE_VECTOR_LENGTH ((uint64_t) 1 << 35)
604 #define OMP_CLAUSE_COPY ((uint64_t) 1 << 36)
605 #define OMP_CLAUSE_COPYOUT ((uint64_t) 1 << 37)
606 #define OMP_CLAUSE_CREATE ((uint64_t) 1 << 38)
607 #define OMP_CLAUSE_PRESENT ((uint64_t) 1 << 39)
608 #define OMP_CLAUSE_PRESENT_OR_COPY ((uint64_t) 1 << 40)
609 #define OMP_CLAUSE_PRESENT_OR_COPYIN ((uint64_t) 1 << 41)
610 #define OMP_CLAUSE_PRESENT_OR_COPYOUT ((uint64_t) 1 << 42)
611 #define OMP_CLAUSE_PRESENT_OR_CREATE ((uint64_t) 1 << 43)
612 #define OMP_CLAUSE_DEVICEPTR ((uint64_t) 1 << 44)
613 #define OMP_CLAUSE_GANG ((uint64_t) 1 << 45)
614 #define OMP_CLAUSE_WORKER ((uint64_t) 1 << 46)
615 #define OMP_CLAUSE_VECTOR ((uint64_t) 1 << 47)
616 #define OMP_CLAUSE_SEQ ((uint64_t) 1 << 48)
617 #define OMP_CLAUSE_INDEPENDENT ((uint64_t) 1 << 49)
618 #define OMP_CLAUSE_USE_DEVICE ((uint64_t) 1 << 50)
619 #define OMP_CLAUSE_DEVICE_RESIDENT ((uint64_t) 1 << 51)
620 #define OMP_CLAUSE_HOST_SELF ((uint64_t) 1 << 52)
621 #define OMP_CLAUSE_OACC_DEVICE ((uint64_t) 1 << 53)
622 #define OMP_CLAUSE_WAIT ((uint64_t) 1 << 54)
623 #define OMP_CLAUSE_DELETE ((uint64_t) 1 << 55)
624 #define OMP_CLAUSE_AUTO ((uint64_t) 1 << 56)
625 #define OMP_CLAUSE_TILE ((uint64_t) 1 << 57)
626 #define OMP_CLAUSE_LINK ((uint64_t) 1 << 58)
628 /* Helper function for OpenACC and OpenMP clauses involving memory
632 gfc_match_omp_map_clause (gfc_omp_namelist
**list
, gfc_omp_map_op map_op
)
634 gfc_omp_namelist
**head
= NULL
;
635 if (gfc_match_omp_variable_list ("", list
, false, NULL
, &head
, true)
639 for (n
= *head
; n
; n
= n
->next
)
640 n
->u
.map_op
= map_op
;
647 /* Match OpenMP and OpenACC directive clauses. MASK is a bitmask of
648 clauses that are allowed for a particular directive. */
651 gfc_match_omp_clauses (gfc_omp_clauses
**cp
, uint64_t mask
,
652 bool first
= true, bool needs_space
= true,
653 bool openacc
= false)
655 gfc_omp_clauses
*c
= gfc_get_omp_clauses ();
661 if ((first
|| gfc_match_char (',') != MATCH_YES
)
662 && (needs_space
&& gfc_match_space () != MATCH_YES
))
666 gfc_gobble_whitespace ();
668 gfc_omp_namelist
**head
;
669 old_loc
= gfc_current_locus
;
670 char pc
= gfc_peek_ascii_char ();
676 if ((mask
& OMP_CLAUSE_ALIGNED
)
677 && gfc_match_omp_variable_list ("aligned (",
678 &c
->lists
[OMP_LIST_ALIGNED
],
682 gfc_expr
*alignment
= NULL
;
685 if (end_colon
&& gfc_match (" %e )", &alignment
) != MATCH_YES
)
687 gfc_free_omp_namelist (*head
);
688 gfc_current_locus
= old_loc
;
692 for (n
= *head
; n
; n
= n
->next
)
693 if (n
->next
&& alignment
)
694 n
->expr
= gfc_copy_expr (alignment
);
699 if ((mask
& OMP_CLAUSE_ASYNC
)
701 && gfc_match ("async") == MATCH_YES
)
704 match m
= gfc_match (" ( %e )", &c
->async_expr
);
705 if (m
== MATCH_ERROR
)
707 gfc_current_locus
= old_loc
;
710 else if (m
== MATCH_NO
)
713 = gfc_get_constant_expr (BT_INTEGER
,
714 gfc_default_integer_kind
,
716 mpz_set_si (c
->async_expr
->value
.integer
, GOMP_ASYNC_NOVAL
);
721 if ((mask
& OMP_CLAUSE_AUTO
)
723 && gfc_match ("auto") == MATCH_YES
)
731 if ((mask
& OMP_CLAUSE_COLLAPSE
)
734 gfc_expr
*cexpr
= NULL
;
735 match m
= gfc_match ("collapse ( %e )", &cexpr
);
740 const char *p
= gfc_extract_int (cexpr
, &collapse
);
746 else if (collapse
<= 0)
748 gfc_error_now ("COLLAPSE clause argument not"
749 " constant positive integer at %C");
752 c
->collapse
= collapse
;
753 gfc_free_expr (cexpr
);
757 if ((mask
& OMP_CLAUSE_COPY
)
758 && gfc_match ("copy ( ") == MATCH_YES
759 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
760 OMP_MAP_FORCE_TOFROM
))
762 if (mask
& OMP_CLAUSE_COPYIN
)
766 if (gfc_match ("copyin ( ") == MATCH_YES
767 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
771 else if (gfc_match_omp_variable_list ("copyin (",
772 &c
->lists
[OMP_LIST_COPYIN
],
776 if ((mask
& OMP_CLAUSE_COPYOUT
)
777 && gfc_match ("copyout ( ") == MATCH_YES
778 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
781 if ((mask
& OMP_CLAUSE_COPYPRIVATE
)
782 && gfc_match_omp_variable_list ("copyprivate (",
783 &c
->lists
[OMP_LIST_COPYPRIVATE
],
786 if ((mask
& OMP_CLAUSE_CREATE
)
787 && gfc_match ("create ( ") == MATCH_YES
788 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
789 OMP_MAP_FORCE_ALLOC
))
793 if ((mask
& OMP_CLAUSE_DELETE
)
794 && gfc_match ("delete ( ") == MATCH_YES
795 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
798 if ((mask
& OMP_CLAUSE_DEFAULT
)
799 && c
->default_sharing
== OMP_DEFAULT_UNKNOWN
)
801 if (gfc_match ("default ( none )") == MATCH_YES
)
802 c
->default_sharing
= OMP_DEFAULT_NONE
;
804 /* c->default_sharing = OMP_DEFAULT_UNKNOWN */;
805 else if (gfc_match ("default ( shared )") == MATCH_YES
)
806 c
->default_sharing
= OMP_DEFAULT_SHARED
;
807 else if (gfc_match ("default ( private )") == MATCH_YES
)
808 c
->default_sharing
= OMP_DEFAULT_PRIVATE
;
809 else if (gfc_match ("default ( firstprivate )") == MATCH_YES
)
810 c
->default_sharing
= OMP_DEFAULT_FIRSTPRIVATE
;
811 if (c
->default_sharing
!= OMP_DEFAULT_UNKNOWN
)
814 if ((mask
& OMP_CLAUSE_DEPEND
)
815 && gfc_match ("depend ( ") == MATCH_YES
)
818 gfc_omp_depend_op depend_op
= OMP_DEPEND_OUT
;
819 if (gfc_match ("inout") == MATCH_YES
)
820 depend_op
= OMP_DEPEND_INOUT
;
821 else if (gfc_match ("in") == MATCH_YES
)
822 depend_op
= OMP_DEPEND_IN
;
823 else if (gfc_match ("out") == MATCH_YES
)
824 depend_op
= OMP_DEPEND_OUT
;
829 && gfc_match_omp_variable_list (" : ",
830 &c
->lists
[OMP_LIST_DEPEND
],
835 for (n
= *head
; n
; n
= n
->next
)
836 n
->u
.depend_op
= depend_op
;
840 gfc_current_locus
= old_loc
;
842 if ((mask
& OMP_CLAUSE_DEVICE
)
844 && gfc_match ("device ( %e )", &c
->device
) == MATCH_YES
)
846 if ((mask
& OMP_CLAUSE_OACC_DEVICE
)
847 && gfc_match ("device ( ") == MATCH_YES
848 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
851 if ((mask
& OMP_CLAUSE_DEVICEPTR
)
852 && gfc_match ("deviceptr ( ") == MATCH_YES
)
854 gfc_omp_namelist
**list
= &c
->lists
[OMP_LIST_MAP
];
855 gfc_omp_namelist
**head
= NULL
;
856 if (gfc_match_omp_variable_list ("", list
, true, NULL
,
857 &head
, false) == MATCH_YES
)
860 for (n
= *head
; n
; n
= n
->next
)
861 n
->u
.map_op
= OMP_MAP_FORCE_DEVICEPTR
;
865 if ((mask
& OMP_CLAUSE_DEVICE_RESIDENT
)
866 && gfc_match_omp_variable_list
867 ("device_resident (",
868 &c
->lists
[OMP_LIST_DEVICE_RESIDENT
], true) == MATCH_YES
)
870 if ((mask
& OMP_CLAUSE_DIST_SCHEDULE
)
871 && c
->dist_sched_kind
== OMP_SCHED_NONE
872 && gfc_match ("dist_schedule ( static") == MATCH_YES
)
875 c
->dist_sched_kind
= OMP_SCHED_STATIC
;
876 m
= gfc_match (" , %e )", &c
->dist_chunk_size
);
878 m
= gfc_match_char (')');
881 c
->dist_sched_kind
= OMP_SCHED_NONE
;
882 gfc_current_locus
= old_loc
;
889 if ((mask
& OMP_CLAUSE_FINAL
)
890 && c
->final_expr
== NULL
891 && gfc_match ("final ( %e )", &c
->final_expr
) == MATCH_YES
)
893 if ((mask
& OMP_CLAUSE_FIRSTPRIVATE
)
894 && gfc_match_omp_variable_list ("firstprivate (",
895 &c
->lists
[OMP_LIST_FIRSTPRIVATE
],
898 if ((mask
& OMP_CLAUSE_FROM
)
899 && gfc_match_omp_variable_list ("from (",
900 &c
->lists
[OMP_LIST_FROM
], false,
901 NULL
, &head
, true) == MATCH_YES
)
905 if ((mask
& OMP_CLAUSE_GANG
)
907 && gfc_match ("gang") == MATCH_YES
)
910 match m
= match_oacc_clause_gwv (c
, GOMP_DIM_GANG
);
911 if (m
== MATCH_ERROR
)
913 gfc_current_locus
= old_loc
;
916 else if (m
== MATCH_NO
)
922 if ((mask
& OMP_CLAUSE_HOST_SELF
)
923 && gfc_match ("host ( ") == MATCH_YES
924 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
929 if ((mask
& OMP_CLAUSE_IF
)
930 && c
->if_expr
== NULL
931 && gfc_match ("if ( %e )", &c
->if_expr
) == MATCH_YES
)
933 if ((mask
& OMP_CLAUSE_INBRANCH
)
936 && gfc_match ("inbranch") == MATCH_YES
)
938 c
->inbranch
= needs_space
= true;
941 if ((mask
& OMP_CLAUSE_INDEPENDENT
)
943 && gfc_match ("independent") == MATCH_YES
)
945 c
->independent
= true;
951 if ((mask
& OMP_CLAUSE_LASTPRIVATE
)
952 && gfc_match_omp_variable_list ("lastprivate (",
953 &c
->lists
[OMP_LIST_LASTPRIVATE
],
958 if ((mask
& OMP_CLAUSE_LINEAR
)
959 && gfc_match_omp_variable_list ("linear (",
960 &c
->lists
[OMP_LIST_LINEAR
],
964 gfc_expr
*step
= NULL
;
966 if (end_colon
&& gfc_match (" %e )", &step
) != MATCH_YES
)
968 gfc_free_omp_namelist (*head
);
969 gfc_current_locus
= old_loc
;
975 step
= gfc_get_constant_expr (BT_INTEGER
,
976 gfc_default_integer_kind
,
978 mpz_set_si (step
->value
.integer
, 1);
980 (*head
)->expr
= step
;
983 if ((mask
& OMP_CLAUSE_LINK
)
984 && (gfc_match_oacc_clause_link ("link (",
985 &c
->lists
[OMP_LIST_LINK
])
990 if ((mask
& OMP_CLAUSE_MAP
)
991 && gfc_match ("map ( ") == MATCH_YES
)
993 gfc_omp_map_op map_op
= OMP_MAP_TOFROM
;
994 if (gfc_match ("alloc : ") == MATCH_YES
)
995 map_op
= OMP_MAP_ALLOC
;
996 else if (gfc_match ("tofrom : ") == MATCH_YES
)
997 map_op
= OMP_MAP_TOFROM
;
998 else if (gfc_match ("to : ") == MATCH_YES
)
1000 else if (gfc_match ("from : ") == MATCH_YES
)
1001 map_op
= OMP_MAP_FROM
;
1003 if (gfc_match_omp_variable_list ("", &c
->lists
[OMP_LIST_MAP
],
1007 gfc_omp_namelist
*n
;
1008 for (n
= *head
; n
; n
= n
->next
)
1009 n
->u
.map_op
= map_op
;
1013 gfc_current_locus
= old_loc
;
1015 if ((mask
& OMP_CLAUSE_MERGEABLE
) && !c
->mergeable
1016 && gfc_match ("mergeable") == MATCH_YES
)
1018 c
->mergeable
= needs_space
= true;
1023 if ((mask
& OMP_CLAUSE_NOTINBRANCH
)
1026 && gfc_match ("notinbranch") == MATCH_YES
)
1028 c
->notinbranch
= needs_space
= true;
1031 if ((mask
& OMP_CLAUSE_NUM_GANGS
)
1032 && c
->num_gangs_expr
== NULL
1033 && gfc_match ("num_gangs ( %e )",
1034 &c
->num_gangs_expr
) == MATCH_YES
)
1036 if ((mask
& OMP_CLAUSE_NUM_TEAMS
)
1037 && c
->num_teams
== NULL
1038 && gfc_match ("num_teams ( %e )", &c
->num_teams
) == MATCH_YES
)
1040 if ((mask
& OMP_CLAUSE_NUM_THREADS
)
1041 && c
->num_threads
== NULL
1042 && (gfc_match ("num_threads ( %e )", &c
->num_threads
)
1045 if ((mask
& OMP_CLAUSE_NUM_WORKERS
)
1046 && c
->num_workers_expr
== NULL
1047 && gfc_match ("num_workers ( %e )",
1048 &c
->num_workers_expr
) == MATCH_YES
)
1052 if ((mask
& OMP_CLAUSE_ORDERED
)
1054 && gfc_match ("ordered") == MATCH_YES
)
1056 c
->ordered
= needs_space
= true;
1061 if ((mask
& OMP_CLAUSE_PRESENT_OR_COPY
)
1062 && gfc_match ("pcopy ( ") == MATCH_YES
1063 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1066 if ((mask
& OMP_CLAUSE_PRESENT_OR_COPYIN
)
1067 && gfc_match ("pcopyin ( ") == MATCH_YES
1068 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1071 if ((mask
& OMP_CLAUSE_PRESENT_OR_COPYOUT
)
1072 && gfc_match ("pcopyout ( ") == MATCH_YES
1073 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1076 if ((mask
& OMP_CLAUSE_PRESENT_OR_CREATE
)
1077 && gfc_match ("pcreate ( ") == MATCH_YES
1078 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1081 if ((mask
& OMP_CLAUSE_PRESENT
)
1082 && gfc_match ("present ( ") == MATCH_YES
1083 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1084 OMP_MAP_FORCE_PRESENT
))
1086 if ((mask
& OMP_CLAUSE_PRESENT_OR_COPY
)
1087 && gfc_match ("present_or_copy ( ") == MATCH_YES
1088 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1091 if ((mask
& OMP_CLAUSE_PRESENT_OR_COPYIN
)
1092 && gfc_match ("present_or_copyin ( ") == MATCH_YES
1093 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1096 if ((mask
& OMP_CLAUSE_PRESENT_OR_COPYOUT
)
1097 && gfc_match ("present_or_copyout ( ") == MATCH_YES
1098 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1101 if ((mask
& OMP_CLAUSE_PRESENT_OR_CREATE
)
1102 && gfc_match ("present_or_create ( ") == MATCH_YES
1103 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1106 if ((mask
& OMP_CLAUSE_PRIVATE
)
1107 && gfc_match_omp_variable_list ("private (",
1108 &c
->lists
[OMP_LIST_PRIVATE
],
1111 if ((mask
& OMP_CLAUSE_PROC_BIND
)
1112 && c
->proc_bind
== OMP_PROC_BIND_UNKNOWN
)
1114 if (gfc_match ("proc_bind ( master )") == MATCH_YES
)
1115 c
->proc_bind
= OMP_PROC_BIND_MASTER
;
1116 else if (gfc_match ("proc_bind ( spread )") == MATCH_YES
)
1117 c
->proc_bind
= OMP_PROC_BIND_SPREAD
;
1118 else if (gfc_match ("proc_bind ( close )") == MATCH_YES
)
1119 c
->proc_bind
= OMP_PROC_BIND_CLOSE
;
1120 if (c
->proc_bind
!= OMP_PROC_BIND_UNKNOWN
)
1125 if ((mask
& OMP_CLAUSE_REDUCTION
)
1126 && gfc_match ("reduction ( ") == MATCH_YES
)
1128 gfc_omp_reduction_op rop
= OMP_REDUCTION_NONE
;
1129 char buffer
[GFC_MAX_SYMBOL_LEN
+ 3];
1130 if (gfc_match_char ('+') == MATCH_YES
)
1131 rop
= OMP_REDUCTION_PLUS
;
1132 else if (gfc_match_char ('*') == MATCH_YES
)
1133 rop
= OMP_REDUCTION_TIMES
;
1134 else if (gfc_match_char ('-') == MATCH_YES
)
1135 rop
= OMP_REDUCTION_MINUS
;
1136 else if (gfc_match (".and.") == MATCH_YES
)
1137 rop
= OMP_REDUCTION_AND
;
1138 else if (gfc_match (".or.") == MATCH_YES
)
1139 rop
= OMP_REDUCTION_OR
;
1140 else if (gfc_match (".eqv.") == MATCH_YES
)
1141 rop
= OMP_REDUCTION_EQV
;
1142 else if (gfc_match (".neqv.") == MATCH_YES
)
1143 rop
= OMP_REDUCTION_NEQV
;
1144 if (rop
!= OMP_REDUCTION_NONE
)
1145 snprintf (buffer
, sizeof buffer
, "operator %s",
1146 gfc_op2string ((gfc_intrinsic_op
) rop
));
1147 else if (gfc_match_defined_op_name (buffer
+ 1, 1) == MATCH_YES
)
1150 strcat (buffer
, ".");
1152 else if (gfc_match_name (buffer
) == MATCH_YES
)
1155 const char *n
= buffer
;
1157 gfc_find_symbol (buffer
, NULL
, 1, &sym
);
1160 if (sym
->attr
.intrinsic
)
1162 else if ((sym
->attr
.flavor
!= FL_UNKNOWN
1163 && sym
->attr
.flavor
!= FL_PROCEDURE
)
1164 || sym
->attr
.external
1165 || sym
->attr
.generic
1169 || sym
->attr
.subroutine
1170 || sym
->attr
.pointer
1172 || sym
->attr
.cray_pointer
1173 || sym
->attr
.cray_pointee
1174 || (sym
->attr
.proc
!= PROC_UNKNOWN
1175 && sym
->attr
.proc
!= PROC_INTRINSIC
)
1176 || sym
->attr
.if_source
!= IFSRC_UNKNOWN
1177 || sym
== sym
->ns
->proc_name
)
1186 rop
= OMP_REDUCTION_NONE
;
1187 else if (strcmp (n
, "max") == 0)
1188 rop
= OMP_REDUCTION_MAX
;
1189 else if (strcmp (n
, "min") == 0)
1190 rop
= OMP_REDUCTION_MIN
;
1191 else if (strcmp (n
, "iand") == 0)
1192 rop
= OMP_REDUCTION_IAND
;
1193 else if (strcmp (n
, "ior") == 0)
1194 rop
= OMP_REDUCTION_IOR
;
1195 else if (strcmp (n
, "ieor") == 0)
1196 rop
= OMP_REDUCTION_IEOR
;
1197 if (rop
!= OMP_REDUCTION_NONE
1199 && ! sym
->attr
.intrinsic
1200 && ! sym
->attr
.use_assoc
1201 && ((sym
->attr
.flavor
== FL_UNKNOWN
1202 && !gfc_add_flavor (&sym
->attr
, FL_PROCEDURE
,
1204 || !gfc_add_intrinsic (&sym
->attr
, NULL
)))
1205 rop
= OMP_REDUCTION_NONE
;
1211 ? gfc_find_omp_udr (gfc_current_ns
, buffer
, NULL
) : NULL
);
1212 gfc_omp_namelist
**head
= NULL
;
1213 if (rop
== OMP_REDUCTION_NONE
&& udr
)
1214 rop
= OMP_REDUCTION_USER
;
1216 if (gfc_match_omp_variable_list (" :",
1217 &c
->lists
[OMP_LIST_REDUCTION
],
1219 openacc
) == MATCH_YES
)
1221 gfc_omp_namelist
*n
;
1222 if (rop
== OMP_REDUCTION_NONE
)
1226 gfc_error_now ("!$OMP DECLARE REDUCTION %s not found "
1227 "at %L", buffer
, &old_loc
);
1228 gfc_free_omp_namelist (n
);
1231 for (n
= *head
; n
; n
= n
->next
)
1233 n
->u
.reduction_op
= rop
;
1236 n
->udr
= gfc_get_omp_namelist_udr ();
1243 gfc_current_locus
= old_loc
;
1247 if ((mask
& OMP_CLAUSE_SAFELEN
)
1248 && c
->safelen_expr
== NULL
1249 && gfc_match ("safelen ( %e )", &c
->safelen_expr
) == MATCH_YES
)
1251 if ((mask
& OMP_CLAUSE_SCHEDULE
)
1252 && c
->sched_kind
== OMP_SCHED_NONE
1253 && gfc_match ("schedule ( ") == MATCH_YES
)
1255 if (gfc_match ("static") == MATCH_YES
)
1256 c
->sched_kind
= OMP_SCHED_STATIC
;
1257 else if (gfc_match ("dynamic") == MATCH_YES
)
1258 c
->sched_kind
= OMP_SCHED_DYNAMIC
;
1259 else if (gfc_match ("guided") == MATCH_YES
)
1260 c
->sched_kind
= OMP_SCHED_GUIDED
;
1261 else if (gfc_match ("runtime") == MATCH_YES
)
1262 c
->sched_kind
= OMP_SCHED_RUNTIME
;
1263 else if (gfc_match ("auto") == MATCH_YES
)
1264 c
->sched_kind
= OMP_SCHED_AUTO
;
1265 if (c
->sched_kind
!= OMP_SCHED_NONE
)
1268 if (c
->sched_kind
!= OMP_SCHED_RUNTIME
1269 && c
->sched_kind
!= OMP_SCHED_AUTO
)
1270 m
= gfc_match (" , %e )", &c
->chunk_size
);
1272 m
= gfc_match_char (')');
1274 c
->sched_kind
= OMP_SCHED_NONE
;
1276 if (c
->sched_kind
!= OMP_SCHED_NONE
)
1279 gfc_current_locus
= old_loc
;
1281 if ((mask
& OMP_CLAUSE_HOST_SELF
)
1282 && gfc_match ("self ( ") == MATCH_YES
1283 && gfc_match_omp_map_clause (&c
->lists
[OMP_LIST_MAP
],
1284 OMP_MAP_FORCE_FROM
))
1286 if ((mask
& OMP_CLAUSE_SEQ
)
1288 && gfc_match ("seq") == MATCH_YES
)
1294 if ((mask
& OMP_CLAUSE_SHARED
)
1295 && gfc_match_omp_variable_list ("shared (",
1296 &c
->lists
[OMP_LIST_SHARED
],
1299 if ((mask
& OMP_CLAUSE_SIMDLEN
)
1300 && c
->simdlen_expr
== NULL
1301 && gfc_match ("simdlen ( %e )", &c
->simdlen_expr
) == MATCH_YES
)
1305 if ((mask
& OMP_CLAUSE_THREAD_LIMIT
)
1306 && c
->thread_limit
== NULL
1307 && gfc_match ("thread_limit ( %e )",
1308 &c
->thread_limit
) == MATCH_YES
)
1310 if ((mask
& OMP_CLAUSE_TILE
)
1312 && match_oacc_expr_list ("tile (", &c
->tile_list
,
1315 if ((mask
& OMP_CLAUSE_TO
)
1316 && gfc_match_omp_variable_list ("to (",
1317 &c
->lists
[OMP_LIST_TO
], false,
1318 NULL
, &head
, true) == MATCH_YES
)
1322 if ((mask
& OMP_CLAUSE_UNIFORM
)
1323 && gfc_match_omp_variable_list ("uniform (",
1324 &c
->lists
[OMP_LIST_UNIFORM
],
1325 false) == MATCH_YES
)
1327 if ((mask
& OMP_CLAUSE_UNTIED
)
1329 && gfc_match ("untied") == MATCH_YES
)
1331 c
->untied
= needs_space
= true;
1334 if ((mask
& OMP_CLAUSE_USE_DEVICE
)
1335 && gfc_match_omp_variable_list ("use_device (",
1336 &c
->lists
[OMP_LIST_USE_DEVICE
],
1341 /* VECTOR_LENGTH must be matched before VECTOR, because the latter
1342 doesn't unconditionally match '('. */
1343 if ((mask
& OMP_CLAUSE_VECTOR_LENGTH
)
1344 && c
->vector_length_expr
== NULL
1345 && (gfc_match ("vector_length ( %e )", &c
->vector_length_expr
)
1348 if ((mask
& OMP_CLAUSE_VECTOR
)
1350 && gfc_match ("vector") == MATCH_YES
)
1353 match m
= match_oacc_clause_gwv (c
, GOMP_DIM_VECTOR
);
1354 if (m
== MATCH_ERROR
)
1356 gfc_current_locus
= old_loc
;
1365 if ((mask
& OMP_CLAUSE_WAIT
)
1367 && gfc_match ("wait") == MATCH_YES
)
1370 match m
= match_oacc_expr_list (" (", &c
->wait_list
, false);
1371 if (m
== MATCH_ERROR
)
1373 gfc_current_locus
= old_loc
;
1376 else if (m
== MATCH_NO
)
1380 if ((mask
& OMP_CLAUSE_WORKER
)
1382 && gfc_match ("worker") == MATCH_YES
)
1385 match m
= match_oacc_clause_gwv (c
, GOMP_DIM_WORKER
);
1386 if (m
== MATCH_ERROR
)
1388 gfc_current_locus
= old_loc
;
1391 else if (m
== MATCH_NO
)
1400 if (gfc_match_omp_eos () != MATCH_YES
)
1402 gfc_free_omp_clauses (c
);
1411 #define OACC_PARALLEL_CLAUSES \
1412 (OMP_CLAUSE_IF | OMP_CLAUSE_ASYNC | OMP_CLAUSE_NUM_GANGS \
1413 | OMP_CLAUSE_NUM_WORKERS | OMP_CLAUSE_VECTOR_LENGTH | OMP_CLAUSE_REDUCTION \
1414 | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
1415 | OMP_CLAUSE_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_PRESENT_OR_COPY \
1416 | OMP_CLAUSE_PRESENT_OR_COPYIN | OMP_CLAUSE_PRESENT_OR_COPYOUT \
1417 | OMP_CLAUSE_PRESENT_OR_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_PRIVATE \
1418 | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT)
1419 #define OACC_KERNELS_CLAUSES \
1420 (OMP_CLAUSE_IF | OMP_CLAUSE_ASYNC | OMP_CLAUSE_DEVICEPTR \
1421 | OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
1422 | OMP_CLAUSE_CREATE | OMP_CLAUSE_PRESENT | OMP_CLAUSE_PRESENT_OR_COPY \
1423 | OMP_CLAUSE_PRESENT_OR_COPYIN | OMP_CLAUSE_PRESENT_OR_COPYOUT \
1424 | OMP_CLAUSE_PRESENT_OR_CREATE | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_WAIT)
1425 #define OACC_DATA_CLAUSES \
1426 (OMP_CLAUSE_IF | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_COPY \
1427 | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT | OMP_CLAUSE_CREATE \
1428 | OMP_CLAUSE_PRESENT | OMP_CLAUSE_PRESENT_OR_COPY \
1429 | OMP_CLAUSE_PRESENT_OR_COPYIN | OMP_CLAUSE_PRESENT_OR_COPYOUT \
1430 | OMP_CLAUSE_PRESENT_OR_CREATE)
1431 #define OACC_LOOP_CLAUSES \
1432 (OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER \
1433 | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ | OMP_CLAUSE_INDEPENDENT \
1434 | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_AUTO \
1436 #define OACC_PARALLEL_LOOP_CLAUSES \
1437 (OACC_LOOP_CLAUSES | OACC_PARALLEL_CLAUSES)
1438 #define OACC_KERNELS_LOOP_CLAUSES \
1439 (OACC_LOOP_CLAUSES | OACC_KERNELS_CLAUSES)
1440 #define OACC_HOST_DATA_CLAUSES OMP_CLAUSE_USE_DEVICE
1441 #define OACC_DECLARE_CLAUSES \
1442 (OMP_CLAUSE_COPY | OMP_CLAUSE_COPYIN | OMP_CLAUSE_COPYOUT \
1443 | OMP_CLAUSE_CREATE | OMP_CLAUSE_DEVICEPTR | OMP_CLAUSE_DEVICE_RESIDENT \
1444 | OMP_CLAUSE_PRESENT | OMP_CLAUSE_PRESENT_OR_COPY \
1445 | OMP_CLAUSE_PRESENT_OR_COPYIN | OMP_CLAUSE_PRESENT_OR_COPYOUT \
1446 | OMP_CLAUSE_PRESENT_OR_CREATE | OMP_CLAUSE_LINK)
1447 #define OACC_UPDATE_CLAUSES \
1448 (OMP_CLAUSE_IF | OMP_CLAUSE_ASYNC | OMP_CLAUSE_HOST_SELF \
1449 | OMP_CLAUSE_OACC_DEVICE | OMP_CLAUSE_WAIT)
1450 #define OACC_ENTER_DATA_CLAUSES \
1451 (OMP_CLAUSE_IF | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT | OMP_CLAUSE_COPYIN \
1452 | OMP_CLAUSE_CREATE | OMP_CLAUSE_PRESENT_OR_COPYIN \
1453 | OMP_CLAUSE_PRESENT_OR_CREATE)
1454 #define OACC_EXIT_DATA_CLAUSES \
1455 (OMP_CLAUSE_IF | OMP_CLAUSE_ASYNC | OMP_CLAUSE_WAIT | OMP_CLAUSE_COPYOUT \
1456 | OMP_CLAUSE_DELETE)
1457 #define OACC_WAIT_CLAUSES \
1459 #define OACC_ROUTINE_CLAUSES \
1460 (OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ)
1464 match_acc (gfc_exec_op op
, uint64_t mask
)
1467 if (gfc_match_omp_clauses (&c
, mask
, false, false, true) != MATCH_YES
)
1470 new_st
.ext
.omp_clauses
= c
;
1475 gfc_match_oacc_parallel_loop (void)
1477 return match_acc (EXEC_OACC_PARALLEL_LOOP
, OACC_PARALLEL_LOOP_CLAUSES
);
1482 gfc_match_oacc_parallel (void)
1484 return match_acc (EXEC_OACC_PARALLEL
, OACC_PARALLEL_CLAUSES
);
1489 gfc_match_oacc_kernels_loop (void)
1491 return match_acc (EXEC_OACC_KERNELS_LOOP
, OACC_KERNELS_LOOP_CLAUSES
);
1496 gfc_match_oacc_kernels (void)
1498 return match_acc (EXEC_OACC_KERNELS
, OACC_KERNELS_CLAUSES
);
1503 gfc_match_oacc_data (void)
1505 return match_acc (EXEC_OACC_DATA
, OACC_DATA_CLAUSES
);
1510 gfc_match_oacc_host_data (void)
1512 return match_acc (EXEC_OACC_HOST_DATA
, OACC_HOST_DATA_CLAUSES
);
1517 gfc_match_oacc_loop (void)
1519 return match_acc (EXEC_OACC_LOOP
, OACC_LOOP_CLAUSES
);
1524 gfc_match_oacc_declare (void)
1527 gfc_omp_namelist
*n
;
1528 gfc_namespace
*ns
= gfc_current_ns
;
1529 gfc_oacc_declare
*new_oc
;
1530 bool module_var
= false;
1531 locus where
= gfc_current_locus
;
1533 if (gfc_match_omp_clauses (&c
, OACC_DECLARE_CLAUSES
, false, false, true)
1537 for (n
= c
->lists
[OMP_LIST_DEVICE_RESIDENT
]; n
!= NULL
; n
= n
->next
)
1538 n
->sym
->attr
.oacc_declare_device_resident
= 1;
1540 for (n
= c
->lists
[OMP_LIST_LINK
]; n
!= NULL
; n
= n
->next
)
1541 n
->sym
->attr
.oacc_declare_link
= 1;
1543 for (n
= c
->lists
[OMP_LIST_MAP
]; n
!= NULL
; n
= n
->next
)
1545 gfc_symbol
*s
= n
->sym
;
1547 if (s
->ns
->proc_name
&& s
->ns
->proc_name
->attr
.proc
== PROC_MODULE
)
1549 if (n
->u
.map_op
!= OMP_MAP_FORCE_ALLOC
1550 && n
->u
.map_op
!= OMP_MAP_FORCE_TO
)
1552 gfc_error ("Invalid clause in module with $!ACC DECLARE at %L",
1560 if (s
->attr
.use_assoc
)
1562 gfc_error ("Variable is USE-associated with $!ACC DECLARE at %L",
1567 if ((s
->attr
.dimension
|| s
->attr
.codimension
)
1568 && s
->attr
.dummy
&& s
->as
->type
!= AS_EXPLICIT
)
1570 gfc_error ("Assumed-size dummy array with $!ACC DECLARE at %L",
1575 switch (n
->u
.map_op
)
1577 case OMP_MAP_FORCE_ALLOC
:
1578 s
->attr
.oacc_declare_create
= 1;
1581 case OMP_MAP_FORCE_TO
:
1582 s
->attr
.oacc_declare_copyin
= 1;
1585 case OMP_MAP_FORCE_DEVICEPTR
:
1586 s
->attr
.oacc_declare_deviceptr
= 1;
1594 new_oc
= gfc_get_oacc_declare ();
1595 new_oc
->next
= ns
->oacc_declare
;
1596 new_oc
->module_var
= module_var
;
1597 new_oc
->clauses
= c
;
1598 new_oc
->loc
= gfc_current_locus
;
1599 ns
->oacc_declare
= new_oc
;
1606 gfc_match_oacc_update (void)
1609 locus here
= gfc_current_locus
;
1611 if (gfc_match_omp_clauses (&c
, OACC_UPDATE_CLAUSES
, false, false, true)
1615 if (!c
->lists
[OMP_LIST_MAP
])
1617 gfc_error ("%<acc update%> must contain at least one "
1618 "%<device%> or %<host%> or %<self%> clause at %L", &here
);
1622 new_st
.op
= EXEC_OACC_UPDATE
;
1623 new_st
.ext
.omp_clauses
= c
;
1629 gfc_match_oacc_enter_data (void)
1631 return match_acc (EXEC_OACC_ENTER_DATA
, OACC_ENTER_DATA_CLAUSES
);
1636 gfc_match_oacc_exit_data (void)
1638 return match_acc (EXEC_OACC_EXIT_DATA
, OACC_EXIT_DATA_CLAUSES
);
1643 gfc_match_oacc_wait (void)
1645 gfc_omp_clauses
*c
= gfc_get_omp_clauses ();
1646 gfc_expr_list
*wait_list
= NULL
, *el
;
1650 m
= match_oacc_expr_list (" (", &wait_list
, true);
1651 if (m
== MATCH_ERROR
)
1653 else if (m
== MATCH_YES
)
1656 if (gfc_match_omp_clauses (&c
, OACC_WAIT_CLAUSES
, space
, space
, true)
1661 for (el
= wait_list
; el
; el
= el
->next
)
1663 if (el
->expr
== NULL
)
1665 gfc_error ("Invalid argument to $!ACC WAIT at %L",
1666 &wait_list
->expr
->where
);
1670 if (!gfc_resolve_expr (el
->expr
)
1671 || el
->expr
->ts
.type
!= BT_INTEGER
|| el
->expr
->rank
!= 0
1672 || el
->expr
->expr_type
!= EXPR_CONSTANT
)
1674 gfc_error ("WAIT clause at %L requires a scalar INTEGER expression",
1680 c
->wait_list
= wait_list
;
1681 new_st
.op
= EXEC_OACC_WAIT
;
1682 new_st
.ext
.omp_clauses
= c
;
1688 gfc_match_oacc_cache (void)
1690 gfc_omp_clauses
*c
= gfc_get_omp_clauses ();
1691 /* The OpenACC cache directive explicitly only allows "array elements or
1692 subarrays", which we're currently not checking here. Either check this
1693 after the call of gfc_match_omp_variable_list, or add something like a
1694 only_sections variant next to its allow_sections parameter. */
1695 match m
= gfc_match_omp_variable_list (" (",
1696 &c
->lists
[OMP_LIST_CACHE
], true,
1700 gfc_free_omp_clauses(c
);
1704 if (gfc_current_state() != COMP_DO
1705 && gfc_current_state() != COMP_DO_CONCURRENT
)
1707 gfc_error ("ACC CACHE directive must be inside of loop %C");
1708 gfc_free_omp_clauses(c
);
1712 new_st
.op
= EXEC_OACC_CACHE
;
1713 new_st
.ext
.omp_clauses
= c
;
1717 /* Determine the loop level for a routine. */
1720 gfc_oacc_routine_dims (gfc_omp_clauses
*clauses
)
1729 level
= GOMP_DIM_GANG
, mask
|= GOMP_DIM_MASK (level
);
1730 if (clauses
->worker
)
1731 level
= GOMP_DIM_WORKER
, mask
|= GOMP_DIM_MASK (level
);
1732 if (clauses
->vector
)
1733 level
= GOMP_DIM_VECTOR
, mask
|= GOMP_DIM_MASK (level
);
1735 level
= GOMP_DIM_MAX
, mask
|= GOMP_DIM_MASK (level
);
1737 if (mask
!= (mask
& -mask
))
1738 gfc_error ("Multiple loop axes specified for routine");
1742 level
= GOMP_DIM_MAX
;
1748 gfc_match_oacc_routine (void)
1751 gfc_symbol
*sym
= NULL
;
1753 gfc_omp_clauses
*c
= NULL
;
1754 gfc_oacc_routine_name
*n
= NULL
;
1756 old_loc
= gfc_current_locus
;
1758 m
= gfc_match (" (");
1760 if (gfc_current_ns
->proc_name
1761 && gfc_current_ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
1764 gfc_error ("Only the !$ACC ROUTINE form without "
1765 "list is allowed in interface block at %C");
1771 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
1774 m
= gfc_match_name (buffer
);
1777 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, buffer
);
1781 if (strcmp (sym
->name
, gfc_current_ns
->proc_name
->name
) == 0)
1787 && !sym
->attr
.external
1788 && !sym
->attr
.function
1789 && !sym
->attr
.subroutine
))
1791 gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, "
1792 "invalid function name %s",
1793 (sym
) ? sym
->name
: buffer
);
1794 gfc_current_locus
= old_loc
;
1800 gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C");
1801 gfc_current_locus
= old_loc
;
1805 if (gfc_match_char (')') != MATCH_YES
)
1807 gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting"
1809 gfc_current_locus
= old_loc
;
1814 if (gfc_match_omp_eos () != MATCH_YES
1815 && (gfc_match_omp_clauses (&c
, OACC_ROUTINE_CLAUSES
, false, false, true)
1821 n
= gfc_get_oacc_routine_name ();
1825 if (gfc_current_ns
->oacc_routine_names
!= NULL
)
1826 n
->next
= gfc_current_ns
->oacc_routine_names
;
1828 gfc_current_ns
->oacc_routine_names
= n
;
1830 else if (gfc_current_ns
->proc_name
)
1832 if (!gfc_add_omp_declare_target (&gfc_current_ns
->proc_name
->attr
,
1833 gfc_current_ns
->proc_name
->name
,
1836 gfc_current_ns
->proc_name
->attr
.oacc_function
1837 = gfc_oacc_routine_dims (c
) + 1;
1842 else if (gfc_current_ns
->oacc_routine
)
1843 gfc_current_ns
->oacc_routine_clauses
= c
;
1845 new_st
.op
= EXEC_OACC_ROUTINE
;
1846 new_st
.ext
.omp_clauses
= c
;
1850 gfc_current_locus
= old_loc
;
1855 #define OMP_PARALLEL_CLAUSES \
1856 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \
1857 | OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IF \
1858 | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_PROC_BIND)
1859 #define OMP_DECLARE_SIMD_CLAUSES \
1860 (OMP_CLAUSE_SIMDLEN | OMP_CLAUSE_LINEAR | OMP_CLAUSE_UNIFORM \
1861 | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_INBRANCH | OMP_CLAUSE_NOTINBRANCH)
1862 #define OMP_DO_CLAUSES \
1863 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
1864 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
1865 | OMP_CLAUSE_SCHEDULE | OMP_CLAUSE_ORDERED | OMP_CLAUSE_COLLAPSE)
1866 #define OMP_SECTIONS_CLAUSES \
1867 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
1868 | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
1869 #define OMP_SIMD_CLAUSES \
1870 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
1871 | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_SAFELEN | OMP_CLAUSE_LINEAR \
1872 | OMP_CLAUSE_ALIGNED)
1873 #define OMP_TASK_CLAUSES \
1874 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \
1875 | OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED \
1876 | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE | OMP_CLAUSE_DEPEND)
1877 #define OMP_TARGET_CLAUSES \
1878 (OMP_CLAUSE_DEVICE | OMP_CLAUSE_MAP | OMP_CLAUSE_IF)
1879 #define OMP_TARGET_DATA_CLAUSES \
1880 (OMP_CLAUSE_DEVICE | OMP_CLAUSE_MAP | OMP_CLAUSE_IF)
1881 #define OMP_TARGET_UPDATE_CLAUSES \
1882 (OMP_CLAUSE_DEVICE | OMP_CLAUSE_IF | OMP_CLAUSE_TO | OMP_CLAUSE_FROM)
1883 #define OMP_TEAMS_CLAUSES \
1884 (OMP_CLAUSE_NUM_TEAMS | OMP_CLAUSE_THREAD_LIMIT | OMP_CLAUSE_DEFAULT \
1885 | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \
1886 | OMP_CLAUSE_REDUCTION)
1887 #define OMP_DISTRIBUTE_CLAUSES \
1888 (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_COLLAPSE \
1889 | OMP_CLAUSE_DIST_SCHEDULE)
1893 match_omp (gfc_exec_op op
, unsigned int mask
)
1896 if (gfc_match_omp_clauses (&c
, mask
) != MATCH_YES
)
1899 new_st
.ext
.omp_clauses
= c
;
1905 gfc_match_omp_critical (void)
1907 char n
[GFC_MAX_SYMBOL_LEN
+1];
1909 if (gfc_match (" ( %n )", n
) != MATCH_YES
)
1911 if (gfc_match_omp_eos () != MATCH_YES
)
1913 gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
1916 new_st
.op
= EXEC_OMP_CRITICAL
;
1917 new_st
.ext
.omp_name
= n
[0] ? xstrdup (n
) : NULL
;
1923 gfc_match_omp_distribute (void)
1925 return match_omp (EXEC_OMP_DISTRIBUTE
, OMP_DISTRIBUTE_CLAUSES
);
1930 gfc_match_omp_distribute_parallel_do (void)
1932 return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO
,
1933 OMP_DISTRIBUTE_CLAUSES
| OMP_PARALLEL_CLAUSES
1939 gfc_match_omp_distribute_parallel_do_simd (void)
1941 return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
,
1942 (OMP_DISTRIBUTE_CLAUSES
| OMP_PARALLEL_CLAUSES
1943 | OMP_DO_CLAUSES
| OMP_SIMD_CLAUSES
)
1944 & ~OMP_CLAUSE_ORDERED
);
1949 gfc_match_omp_distribute_simd (void)
1951 return match_omp (EXEC_OMP_DISTRIBUTE_SIMD
,
1952 OMP_DISTRIBUTE_CLAUSES
| OMP_SIMD_CLAUSES
);
1957 gfc_match_omp_do (void)
1959 return match_omp (EXEC_OMP_DO
, OMP_DO_CLAUSES
);
1964 gfc_match_omp_do_simd (void)
1966 return match_omp (EXEC_OMP_DO_SIMD
, ((OMP_DO_CLAUSES
| OMP_SIMD_CLAUSES
)
1967 & ~OMP_CLAUSE_ORDERED
));
1972 gfc_match_omp_flush (void)
1974 gfc_omp_namelist
*list
= NULL
;
1975 gfc_match_omp_variable_list (" (", &list
, true);
1976 if (gfc_match_omp_eos () != MATCH_YES
)
1978 gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
1979 gfc_free_omp_namelist (list
);
1982 new_st
.op
= EXEC_OMP_FLUSH
;
1983 new_st
.ext
.omp_namelist
= list
;
1989 gfc_match_omp_declare_simd (void)
1991 locus where
= gfc_current_locus
;
1992 gfc_symbol
*proc_name
;
1994 gfc_omp_declare_simd
*ods
;
1996 if (gfc_match (" ( %s ) ", &proc_name
) != MATCH_YES
)
1999 if (gfc_match_omp_clauses (&c
, OMP_DECLARE_SIMD_CLAUSES
, true,
2000 false) != MATCH_YES
)
2003 ods
= gfc_get_omp_declare_simd ();
2005 ods
->proc_name
= proc_name
;
2007 ods
->next
= gfc_current_ns
->omp_declare_simd
;
2008 gfc_current_ns
->omp_declare_simd
= ods
;
2014 match_udr_expr (gfc_symtree
*omp_sym1
, gfc_symtree
*omp_sym2
)
2017 locus old_loc
= gfc_current_locus
;
2018 char sname
[GFC_MAX_SYMBOL_LEN
+ 1];
2020 gfc_namespace
*ns
= gfc_current_ns
;
2021 gfc_expr
*lvalue
= NULL
, *rvalue
= NULL
;
2023 gfc_actual_arglist
*arglist
;
2025 m
= gfc_match (" %v =", &lvalue
);
2027 gfc_current_locus
= old_loc
;
2030 m
= gfc_match (" %e )", &rvalue
);
2033 ns
->code
= gfc_get_code (EXEC_ASSIGN
);
2034 ns
->code
->expr1
= lvalue
;
2035 ns
->code
->expr2
= rvalue
;
2036 ns
->code
->loc
= old_loc
;
2040 gfc_current_locus
= old_loc
;
2041 gfc_free_expr (lvalue
);
2044 m
= gfc_match (" %n", sname
);
2048 if (strcmp (sname
, omp_sym1
->name
) == 0
2049 || strcmp (sname
, omp_sym2
->name
) == 0)
2052 gfc_current_ns
= ns
->parent
;
2053 if (gfc_get_ha_sym_tree (sname
, &st
))
2057 if (sym
->attr
.flavor
!= FL_PROCEDURE
2058 && sym
->attr
.flavor
!= FL_UNKNOWN
)
2061 if (!sym
->attr
.generic
2062 && !sym
->attr
.subroutine
2063 && !sym
->attr
.function
)
2065 if (!(sym
->attr
.external
&& !sym
->attr
.referenced
))
2067 /* ...create a symbol in this scope... */
2068 if (sym
->ns
!= gfc_current_ns
2069 && gfc_get_sym_tree (sname
, NULL
, &st
, false) == 1)
2072 if (sym
!= st
->n
.sym
)
2076 /* ...and then to try to make the symbol into a subroutine. */
2077 if (!gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
))
2081 gfc_set_sym_referenced (sym
);
2082 gfc_gobble_whitespace ();
2083 if (gfc_peek_ascii_char () != '(')
2086 gfc_current_ns
= ns
;
2087 m
= gfc_match_actual_arglist (1, &arglist
);
2091 if (gfc_match_char (')') != MATCH_YES
)
2094 ns
->code
= gfc_get_code (EXEC_CALL
);
2095 ns
->code
->symtree
= st
;
2096 ns
->code
->ext
.actual
= arglist
;
2097 ns
->code
->loc
= old_loc
;
2102 gfc_omp_udr_predef (gfc_omp_reduction_op rop
, const char *name
,
2103 gfc_typespec
*ts
, const char **n
)
2105 if (!gfc_numeric_ts (ts
) && ts
->type
!= BT_LOGICAL
)
2110 case OMP_REDUCTION_PLUS
:
2111 case OMP_REDUCTION_MINUS
:
2112 case OMP_REDUCTION_TIMES
:
2113 return ts
->type
!= BT_LOGICAL
;
2114 case OMP_REDUCTION_AND
:
2115 case OMP_REDUCTION_OR
:
2116 case OMP_REDUCTION_EQV
:
2117 case OMP_REDUCTION_NEQV
:
2118 return ts
->type
== BT_LOGICAL
;
2119 case OMP_REDUCTION_USER
:
2120 if (name
[0] != '.' && (ts
->type
== BT_INTEGER
|| ts
->type
== BT_REAL
))
2124 gfc_find_symbol (name
, NULL
, 1, &sym
);
2127 if (sym
->attr
.intrinsic
)
2129 else if ((sym
->attr
.flavor
!= FL_UNKNOWN
2130 && sym
->attr
.flavor
!= FL_PROCEDURE
)
2131 || sym
->attr
.external
2132 || sym
->attr
.generic
2136 || sym
->attr
.subroutine
2137 || sym
->attr
.pointer
2139 || sym
->attr
.cray_pointer
2140 || sym
->attr
.cray_pointee
2141 || (sym
->attr
.proc
!= PROC_UNKNOWN
2142 && sym
->attr
.proc
!= PROC_INTRINSIC
)
2143 || sym
->attr
.if_source
!= IFSRC_UNKNOWN
2144 || sym
== sym
->ns
->proc_name
)
2152 && (strcmp (*n
, "max") == 0 || strcmp (*n
, "min") == 0))
2155 && ts
->type
== BT_INTEGER
2156 && (strcmp (*n
, "iand") == 0
2157 || strcmp (*n
, "ior") == 0
2158 || strcmp (*n
, "ieor") == 0))
2169 gfc_omp_udr_find (gfc_symtree
*st
, gfc_typespec
*ts
)
2171 gfc_omp_udr
*omp_udr
;
2176 for (omp_udr
= st
->n
.omp_udr
; omp_udr
; omp_udr
= omp_udr
->next
)
2177 if (omp_udr
->ts
.type
== ts
->type
2178 || ((omp_udr
->ts
.type
== BT_DERIVED
|| omp_udr
->ts
.type
== BT_CLASS
)
2179 && (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
)))
2181 if (omp_udr
->ts
.type
== BT_DERIVED
|| omp_udr
->ts
.type
== BT_CLASS
)
2183 if (strcmp (omp_udr
->ts
.u
.derived
->name
, ts
->u
.derived
->name
) == 0)
2186 else if (omp_udr
->ts
.kind
== ts
->kind
)
2188 if (omp_udr
->ts
.type
== BT_CHARACTER
)
2190 if (omp_udr
->ts
.u
.cl
->length
== NULL
2191 || ts
->u
.cl
->length
== NULL
)
2193 if (omp_udr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2195 if (ts
->u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
2197 if (omp_udr
->ts
.u
.cl
->length
->ts
.type
!= BT_INTEGER
)
2199 if (ts
->u
.cl
->length
->ts
.type
!= BT_INTEGER
)
2201 if (gfc_compare_expr (omp_udr
->ts
.u
.cl
->length
,
2202 ts
->u
.cl
->length
, INTRINSIC_EQ
) != 0)
2212 gfc_match_omp_declare_reduction (void)
2215 gfc_intrinsic_op op
;
2216 char name
[GFC_MAX_SYMBOL_LEN
+ 3];
2217 auto_vec
<gfc_typespec
, 5> tss
;
2221 locus where
= gfc_current_locus
;
2222 locus end_loc
= gfc_current_locus
;
2223 bool end_loc_set
= false;
2224 gfc_omp_reduction_op rop
= OMP_REDUCTION_NONE
;
2226 if (gfc_match_char ('(') != MATCH_YES
)
2229 m
= gfc_match (" %o : ", &op
);
2230 if (m
== MATCH_ERROR
)
2234 snprintf (name
, sizeof name
, "operator %s", gfc_op2string (op
));
2235 rop
= (gfc_omp_reduction_op
) op
;
2239 m
= gfc_match_defined_op_name (name
+ 1, 1);
2240 if (m
== MATCH_ERROR
)
2246 if (gfc_match (" : ") != MATCH_YES
)
2251 if (gfc_match (" %n : ", name
) != MATCH_YES
)
2254 rop
= OMP_REDUCTION_USER
;
2257 m
= gfc_match_type_spec (&ts
);
2260 /* Treat len=: the same as len=*. */
2261 if (ts
.type
== BT_CHARACTER
)
2262 ts
.deferred
= false;
2265 while (gfc_match_char (',') == MATCH_YES
)
2267 m
= gfc_match_type_spec (&ts
);
2272 if (gfc_match_char (':') != MATCH_YES
)
2275 st
= gfc_find_symtree (gfc_current_ns
->omp_udr_root
, name
);
2276 for (i
= 0; i
< tss
.length (); i
++)
2278 gfc_symtree
*omp_out
, *omp_in
;
2279 gfc_symtree
*omp_priv
= NULL
, *omp_orig
= NULL
;
2280 gfc_namespace
*combiner_ns
, *initializer_ns
= NULL
;
2281 gfc_omp_udr
*prev_udr
, *omp_udr
;
2282 const char *predef_name
= NULL
;
2284 omp_udr
= gfc_get_omp_udr ();
2285 omp_udr
->name
= gfc_get_string (name
);
2287 omp_udr
->ts
= tss
[i
];
2288 omp_udr
->where
= where
;
2290 gfc_current_ns
= combiner_ns
= gfc_get_namespace (gfc_current_ns
, 1);
2291 combiner_ns
->proc_name
= combiner_ns
->parent
->proc_name
;
2293 gfc_get_sym_tree ("omp_out", combiner_ns
, &omp_out
, false);
2294 gfc_get_sym_tree ("omp_in", combiner_ns
, &omp_in
, false);
2295 combiner_ns
->omp_udr_ns
= 1;
2296 omp_out
->n
.sym
->ts
= tss
[i
];
2297 omp_in
->n
.sym
->ts
= tss
[i
];
2298 omp_out
->n
.sym
->attr
.omp_udr_artificial_var
= 1;
2299 omp_in
->n
.sym
->attr
.omp_udr_artificial_var
= 1;
2300 omp_out
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
2301 omp_in
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
2302 gfc_commit_symbols ();
2303 omp_udr
->combiner_ns
= combiner_ns
;
2304 omp_udr
->omp_out
= omp_out
->n
.sym
;
2305 omp_udr
->omp_in
= omp_in
->n
.sym
;
2307 locus old_loc
= gfc_current_locus
;
2309 if (!match_udr_expr (omp_out
, omp_in
))
2312 gfc_current_locus
= old_loc
;
2313 gfc_current_ns
= combiner_ns
->parent
;
2314 gfc_undo_symbols ();
2315 gfc_free_omp_udr (omp_udr
);
2319 if (gfc_match (" initializer ( ") == MATCH_YES
)
2321 gfc_current_ns
= combiner_ns
->parent
;
2322 initializer_ns
= gfc_get_namespace (gfc_current_ns
, 1);
2323 gfc_current_ns
= initializer_ns
;
2324 initializer_ns
->proc_name
= initializer_ns
->parent
->proc_name
;
2326 gfc_get_sym_tree ("omp_priv", initializer_ns
, &omp_priv
, false);
2327 gfc_get_sym_tree ("omp_orig", initializer_ns
, &omp_orig
, false);
2328 initializer_ns
->omp_udr_ns
= 1;
2329 omp_priv
->n
.sym
->ts
= tss
[i
];
2330 omp_orig
->n
.sym
->ts
= tss
[i
];
2331 omp_priv
->n
.sym
->attr
.omp_udr_artificial_var
= 1;
2332 omp_orig
->n
.sym
->attr
.omp_udr_artificial_var
= 1;
2333 omp_priv
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
2334 omp_orig
->n
.sym
->attr
.flavor
= FL_VARIABLE
;
2335 gfc_commit_symbols ();
2336 omp_udr
->initializer_ns
= initializer_ns
;
2337 omp_udr
->omp_priv
= omp_priv
->n
.sym
;
2338 omp_udr
->omp_orig
= omp_orig
->n
.sym
;
2340 if (!match_udr_expr (omp_priv
, omp_orig
))
2344 gfc_current_ns
= combiner_ns
->parent
;
2348 end_loc
= gfc_current_locus
;
2350 gfc_current_locus
= old_loc
;
2352 prev_udr
= gfc_omp_udr_find (st
, &tss
[i
]);
2353 if (gfc_omp_udr_predef (rop
, name
, &tss
[i
], &predef_name
)
2354 /* Don't error on !$omp declare reduction (min : integer : ...)
2355 just yet, there could be integer :: min afterwards,
2356 making it valid. When the UDR is resolved, we'll get
2358 && (rop
!= OMP_REDUCTION_USER
|| name
[0] == '.'))
2361 gfc_error_now ("Redefinition of predefined %s "
2362 "!$OMP DECLARE REDUCTION at %L",
2363 predef_name
, &where
);
2365 gfc_error_now ("Redefinition of predefined "
2366 "!$OMP DECLARE REDUCTION at %L", &where
);
2370 gfc_error_now ("Redefinition of !$OMP DECLARE REDUCTION at %L",
2372 gfc_error_now ("Previous !$OMP DECLARE REDUCTION at %L",
2377 omp_udr
->next
= st
->n
.omp_udr
;
2378 st
->n
.omp_udr
= omp_udr
;
2382 st
= gfc_new_symtree (&gfc_current_ns
->omp_udr_root
, name
);
2383 st
->n
.omp_udr
= omp_udr
;
2389 gfc_current_locus
= end_loc
;
2390 if (gfc_match_omp_eos () != MATCH_YES
)
2392 gfc_error ("Unexpected junk after !$OMP DECLARE REDUCTION at %C");
2393 gfc_current_locus
= where
;
2405 gfc_match_omp_declare_target (void)
2408 char n
[GFC_MAX_SYMBOL_LEN
+1];
2413 old_loc
= gfc_current_locus
;
2415 m
= gfc_match (" (");
2417 if (gfc_current_ns
->proc_name
2418 && gfc_current_ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
2421 gfc_error ("Only the !$OMP DECLARE TARGET form without "
2422 "list is allowed in interface block at %C");
2427 && gfc_current_ns
->proc_name
2428 && gfc_match_omp_eos () == MATCH_YES
)
2430 if (!gfc_add_omp_declare_target (&gfc_current_ns
->proc_name
->attr
,
2431 gfc_current_ns
->proc_name
->name
,
2442 m
= gfc_match_symbol (&sym
, 0);
2446 if (sym
->attr
.in_common
)
2447 gfc_error_now ("OMP DECLARE TARGET on a variable at %C is an "
2448 "element of a COMMON block");
2449 else if (!gfc_add_omp_declare_target (&sym
->attr
, sym
->name
,
2459 m
= gfc_match (" / %n /", n
);
2460 if (m
== MATCH_ERROR
)
2462 if (m
== MATCH_NO
|| n
[0] == '\0')
2465 st
= gfc_find_symtree (gfc_current_ns
->common_root
, n
);
2468 gfc_error ("COMMON block /%s/ not found at %C", n
);
2471 st
->n
.common
->omp_declare_target
= 1;
2472 for (sym
= st
->n
.common
->head
; sym
; sym
= sym
->common_next
)
2473 if (!gfc_add_omp_declare_target (&sym
->attr
, sym
->name
,
2478 if (gfc_match_char (')') == MATCH_YES
)
2480 if (gfc_match_char (',') != MATCH_YES
)
2484 if (gfc_match_omp_eos () != MATCH_YES
)
2486 gfc_error ("Unexpected junk after !$OMP DECLARE TARGET at %C");
2492 gfc_error ("Syntax error in !$OMP DECLARE TARGET list at %C");
2495 gfc_current_locus
= old_loc
;
2501 gfc_match_omp_threadprivate (void)
2504 char n
[GFC_MAX_SYMBOL_LEN
+1];
2509 old_loc
= gfc_current_locus
;
2511 m
= gfc_match (" (");
2517 m
= gfc_match_symbol (&sym
, 0);
2521 if (sym
->attr
.in_common
)
2522 gfc_error_now ("Threadprivate variable at %C is an element of "
2524 else if (!gfc_add_threadprivate (&sym
->attr
, sym
->name
, &sym
->declared_at
))
2533 m
= gfc_match (" / %n /", n
);
2534 if (m
== MATCH_ERROR
)
2536 if (m
== MATCH_NO
|| n
[0] == '\0')
2539 st
= gfc_find_symtree (gfc_current_ns
->common_root
, n
);
2542 gfc_error ("COMMON block /%s/ not found at %C", n
);
2545 st
->n
.common
->threadprivate
= 1;
2546 for (sym
= st
->n
.common
->head
; sym
; sym
= sym
->common_next
)
2547 if (!gfc_add_threadprivate (&sym
->attr
, sym
->name
, &sym
->declared_at
))
2551 if (gfc_match_char (')') == MATCH_YES
)
2553 if (gfc_match_char (',') != MATCH_YES
)
2557 if (gfc_match_omp_eos () != MATCH_YES
)
2559 gfc_error ("Unexpected junk after OMP THREADPRIVATE at %C");
2566 gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C");
2569 gfc_current_locus
= old_loc
;
2575 gfc_match_omp_parallel (void)
2577 return match_omp (EXEC_OMP_PARALLEL
, OMP_PARALLEL_CLAUSES
);
2582 gfc_match_omp_parallel_do (void)
2584 return match_omp (EXEC_OMP_PARALLEL_DO
,
2585 OMP_PARALLEL_CLAUSES
| OMP_DO_CLAUSES
);
2590 gfc_match_omp_parallel_do_simd (void)
2592 return match_omp (EXEC_OMP_PARALLEL_DO_SIMD
,
2593 (OMP_PARALLEL_CLAUSES
| OMP_DO_CLAUSES
| OMP_SIMD_CLAUSES
)
2594 & ~OMP_CLAUSE_ORDERED
);
2599 gfc_match_omp_parallel_sections (void)
2601 return match_omp (EXEC_OMP_PARALLEL_SECTIONS
,
2602 OMP_PARALLEL_CLAUSES
| OMP_SECTIONS_CLAUSES
);
2607 gfc_match_omp_parallel_workshare (void)
2609 return match_omp (EXEC_OMP_PARALLEL_WORKSHARE
, OMP_PARALLEL_CLAUSES
);
2614 gfc_match_omp_sections (void)
2616 return match_omp (EXEC_OMP_SECTIONS
, OMP_SECTIONS_CLAUSES
);
2621 gfc_match_omp_simd (void)
2623 return match_omp (EXEC_OMP_SIMD
, OMP_SIMD_CLAUSES
);
2628 gfc_match_omp_single (void)
2630 return match_omp (EXEC_OMP_SINGLE
,
2631 OMP_CLAUSE_PRIVATE
| OMP_CLAUSE_FIRSTPRIVATE
);
2636 gfc_match_omp_task (void)
2638 return match_omp (EXEC_OMP_TASK
, OMP_TASK_CLAUSES
);
2643 gfc_match_omp_taskwait (void)
2645 if (gfc_match_omp_eos () != MATCH_YES
)
2647 gfc_error ("Unexpected junk after TASKWAIT clause at %C");
2650 new_st
.op
= EXEC_OMP_TASKWAIT
;
2651 new_st
.ext
.omp_clauses
= NULL
;
2657 gfc_match_omp_taskyield (void)
2659 if (gfc_match_omp_eos () != MATCH_YES
)
2661 gfc_error ("Unexpected junk after TASKYIELD clause at %C");
2664 new_st
.op
= EXEC_OMP_TASKYIELD
;
2665 new_st
.ext
.omp_clauses
= NULL
;
2671 gfc_match_omp_target (void)
2673 return match_omp (EXEC_OMP_TARGET
, OMP_TARGET_CLAUSES
);
2678 gfc_match_omp_target_data (void)
2680 return match_omp (EXEC_OMP_TARGET_DATA
, OMP_TARGET_DATA_CLAUSES
);
2685 gfc_match_omp_target_teams (void)
2687 return match_omp (EXEC_OMP_TARGET_TEAMS
,
2688 OMP_TARGET_CLAUSES
| OMP_TEAMS_CLAUSES
);
2693 gfc_match_omp_target_teams_distribute (void)
2695 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
,
2696 OMP_TARGET_CLAUSES
| OMP_TEAMS_CLAUSES
2697 | OMP_DISTRIBUTE_CLAUSES
);
2702 gfc_match_omp_target_teams_distribute_parallel_do (void)
2704 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
,
2705 OMP_TARGET_CLAUSES
| OMP_TEAMS_CLAUSES
2706 | OMP_DISTRIBUTE_CLAUSES
| OMP_PARALLEL_CLAUSES
2712 gfc_match_omp_target_teams_distribute_parallel_do_simd (void)
2714 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
,
2715 (OMP_TARGET_CLAUSES
| OMP_TEAMS_CLAUSES
2716 | OMP_DISTRIBUTE_CLAUSES
| OMP_PARALLEL_CLAUSES
2717 | OMP_DO_CLAUSES
| OMP_SIMD_CLAUSES
)
2718 & ~OMP_CLAUSE_ORDERED
);
2723 gfc_match_omp_target_teams_distribute_simd (void)
2725 return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
,
2726 OMP_TARGET_CLAUSES
| OMP_TEAMS_CLAUSES
2727 | OMP_DISTRIBUTE_CLAUSES
| OMP_SIMD_CLAUSES
);
2732 gfc_match_omp_target_update (void)
2734 return match_omp (EXEC_OMP_TARGET_UPDATE
, OMP_TARGET_UPDATE_CLAUSES
);
2739 gfc_match_omp_teams (void)
2741 return match_omp (EXEC_OMP_TEAMS
, OMP_TEAMS_CLAUSES
);
2746 gfc_match_omp_teams_distribute (void)
2748 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE
,
2749 OMP_TEAMS_CLAUSES
| OMP_DISTRIBUTE_CLAUSES
);
2754 gfc_match_omp_teams_distribute_parallel_do (void)
2756 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
,
2757 OMP_TEAMS_CLAUSES
| OMP_DISTRIBUTE_CLAUSES
2758 | OMP_PARALLEL_CLAUSES
| OMP_DO_CLAUSES
);
2763 gfc_match_omp_teams_distribute_parallel_do_simd (void)
2765 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
,
2766 (OMP_TEAMS_CLAUSES
| OMP_DISTRIBUTE_CLAUSES
2767 | OMP_PARALLEL_CLAUSES
| OMP_DO_CLAUSES
2768 | OMP_SIMD_CLAUSES
) & ~OMP_CLAUSE_ORDERED
);
2773 gfc_match_omp_teams_distribute_simd (void)
2775 return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
,
2776 OMP_TEAMS_CLAUSES
| OMP_DISTRIBUTE_CLAUSES
2777 | OMP_SIMD_CLAUSES
);
2782 gfc_match_omp_workshare (void)
2784 if (gfc_match_omp_eos () != MATCH_YES
)
2786 gfc_error ("Unexpected junk after $OMP WORKSHARE statement at %C");
2789 new_st
.op
= EXEC_OMP_WORKSHARE
;
2790 new_st
.ext
.omp_clauses
= gfc_get_omp_clauses ();
2796 gfc_match_omp_master (void)
2798 if (gfc_match_omp_eos () != MATCH_YES
)
2800 gfc_error ("Unexpected junk after $OMP MASTER statement at %C");
2803 new_st
.op
= EXEC_OMP_MASTER
;
2804 new_st
.ext
.omp_clauses
= NULL
;
2810 gfc_match_omp_ordered (void)
2812 if (gfc_match_omp_eos () != MATCH_YES
)
2814 gfc_error ("Unexpected junk after $OMP ORDERED statement at %C");
2817 new_st
.op
= EXEC_OMP_ORDERED
;
2818 new_st
.ext
.omp_clauses
= NULL
;
2824 gfc_match_omp_oacc_atomic (bool omp_p
)
2826 gfc_omp_atomic_op op
= GFC_OMP_ATOMIC_UPDATE
;
2828 if (gfc_match ("% seq_cst") == MATCH_YES
)
2830 locus old_loc
= gfc_current_locus
;
2831 if (seq_cst
&& gfc_match_char (',') == MATCH_YES
)
2834 || gfc_match_space () == MATCH_YES
)
2836 gfc_gobble_whitespace ();
2837 if (gfc_match ("update") == MATCH_YES
)
2838 op
= GFC_OMP_ATOMIC_UPDATE
;
2839 else if (gfc_match ("read") == MATCH_YES
)
2840 op
= GFC_OMP_ATOMIC_READ
;
2841 else if (gfc_match ("write") == MATCH_YES
)
2842 op
= GFC_OMP_ATOMIC_WRITE
;
2843 else if (gfc_match ("capture") == MATCH_YES
)
2844 op
= GFC_OMP_ATOMIC_CAPTURE
;
2848 gfc_current_locus
= old_loc
;
2852 && (gfc_match (", seq_cst") == MATCH_YES
2853 || gfc_match ("% seq_cst") == MATCH_YES
))
2857 if (gfc_match_omp_eos () != MATCH_YES
)
2859 gfc_error ("Unexpected junk after $OMP ATOMIC statement at %C");
2862 new_st
.op
= (omp_p
? EXEC_OMP_ATOMIC
: EXEC_OACC_ATOMIC
);
2864 op
= (gfc_omp_atomic_op
) (op
| GFC_OMP_ATOMIC_SEQ_CST
);
2865 new_st
.ext
.omp_atomic
= op
;
2870 gfc_match_oacc_atomic (void)
2872 return gfc_match_omp_oacc_atomic (false);
2876 gfc_match_omp_atomic (void)
2878 return gfc_match_omp_oacc_atomic (true);
2882 gfc_match_omp_barrier (void)
2884 if (gfc_match_omp_eos () != MATCH_YES
)
2886 gfc_error ("Unexpected junk after $OMP BARRIER statement at %C");
2889 new_st
.op
= EXEC_OMP_BARRIER
;
2890 new_st
.ext
.omp_clauses
= NULL
;
2896 gfc_match_omp_taskgroup (void)
2898 if (gfc_match_omp_eos () != MATCH_YES
)
2900 gfc_error ("Unexpected junk after $OMP TASKGROUP statement at %C");
2903 new_st
.op
= EXEC_OMP_TASKGROUP
;
2908 static enum gfc_omp_cancel_kind
2909 gfc_match_omp_cancel_kind (void)
2911 if (gfc_match_space () != MATCH_YES
)
2912 return OMP_CANCEL_UNKNOWN
;
2913 if (gfc_match ("parallel") == MATCH_YES
)
2914 return OMP_CANCEL_PARALLEL
;
2915 if (gfc_match ("sections") == MATCH_YES
)
2916 return OMP_CANCEL_SECTIONS
;
2917 if (gfc_match ("do") == MATCH_YES
)
2918 return OMP_CANCEL_DO
;
2919 if (gfc_match ("taskgroup") == MATCH_YES
)
2920 return OMP_CANCEL_TASKGROUP
;
2921 return OMP_CANCEL_UNKNOWN
;
2926 gfc_match_omp_cancel (void)
2929 enum gfc_omp_cancel_kind kind
= gfc_match_omp_cancel_kind ();
2930 if (kind
== OMP_CANCEL_UNKNOWN
)
2932 if (gfc_match_omp_clauses (&c
, OMP_CLAUSE_IF
, false) != MATCH_YES
)
2935 new_st
.op
= EXEC_OMP_CANCEL
;
2936 new_st
.ext
.omp_clauses
= c
;
2942 gfc_match_omp_cancellation_point (void)
2945 enum gfc_omp_cancel_kind kind
= gfc_match_omp_cancel_kind ();
2946 if (kind
== OMP_CANCEL_UNKNOWN
)
2948 if (gfc_match_omp_eos () != MATCH_YES
)
2950 gfc_error ("Unexpected junk after $OMP CANCELLATION POINT statement "
2954 c
= gfc_get_omp_clauses ();
2956 new_st
.op
= EXEC_OMP_CANCELLATION_POINT
;
2957 new_st
.ext
.omp_clauses
= c
;
2963 gfc_match_omp_end_nowait (void)
2965 bool nowait
= false;
2966 if (gfc_match ("% nowait") == MATCH_YES
)
2968 if (gfc_match_omp_eos () != MATCH_YES
)
2970 gfc_error ("Unexpected junk after NOWAIT clause at %C");
2973 new_st
.op
= EXEC_OMP_END_NOWAIT
;
2974 new_st
.ext
.omp_bool
= nowait
;
2980 gfc_match_omp_end_single (void)
2983 if (gfc_match ("% nowait") == MATCH_YES
)
2985 new_st
.op
= EXEC_OMP_END_NOWAIT
;
2986 new_st
.ext
.omp_bool
= true;
2989 if (gfc_match_omp_clauses (&c
, OMP_CLAUSE_COPYPRIVATE
) != MATCH_YES
)
2991 new_st
.op
= EXEC_OMP_END_SINGLE
;
2992 new_st
.ext
.omp_clauses
= c
;
2998 oacc_is_loop (gfc_code
*code
)
3000 return code
->op
== EXEC_OACC_PARALLEL_LOOP
3001 || code
->op
== EXEC_OACC_KERNELS_LOOP
3002 || code
->op
== EXEC_OACC_LOOP
;
3006 resolve_oacc_scalar_int_expr (gfc_expr
*expr
, const char *clause
)
3008 if (!gfc_resolve_expr (expr
)
3009 || expr
->ts
.type
!= BT_INTEGER
|| expr
->rank
!= 0)
3010 gfc_error ("%s clause at %L requires a scalar INTEGER expression",
3011 clause
, &expr
->where
);
3016 resolve_oacc_positive_int_expr (gfc_expr
*expr
, const char *clause
)
3018 resolve_oacc_scalar_int_expr (expr
, clause
);
3019 if (expr
->expr_type
== EXPR_CONSTANT
&& expr
->ts
.type
== BT_INTEGER
3020 && mpz_sgn(expr
->value
.integer
) <= 0)
3021 gfc_warning (0, "INTEGER expression of %s clause at %L must be positive",
3022 clause
, &expr
->where
);
3025 /* Emits error when symbol is pointer, cray pointer or cray pointee
3026 of derived of polymorphic type. */
3029 check_symbol_not_pointer (gfc_symbol
*sym
, locus loc
, const char *name
)
3031 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.pointer
)
3032 gfc_error ("POINTER object %qs of derived type in %s clause at %L",
3033 sym
->name
, name
, &loc
);
3034 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.cray_pointer
)
3035 gfc_error ("Cray pointer object of derived type %qs in %s clause at %L",
3036 sym
->name
, name
, &loc
);
3037 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.cray_pointee
)
3038 gfc_error ("Cray pointee object of derived type %qs in %s clause at %L",
3039 sym
->name
, name
, &loc
);
3041 if ((sym
->ts
.type
== BT_ASSUMED
&& sym
->attr
.pointer
)
3042 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
3043 && CLASS_DATA (sym
)->attr
.pointer
))
3044 gfc_error ("POINTER object %qs of polymorphic type in %s clause at %L",
3045 sym
->name
, name
, &loc
);
3046 if ((sym
->ts
.type
== BT_ASSUMED
&& sym
->attr
.cray_pointer
)
3047 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
3048 && CLASS_DATA (sym
)->attr
.cray_pointer
))
3049 gfc_error ("Cray pointer object of polymorphic type %qs in %s clause at %L",
3050 sym
->name
, name
, &loc
);
3051 if ((sym
->ts
.type
== BT_ASSUMED
&& sym
->attr
.cray_pointee
)
3052 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
3053 && CLASS_DATA (sym
)->attr
.cray_pointee
))
3054 gfc_error ("Cray pointee object of polymorphic type %qs in %s clause at %L",
3055 sym
->name
, name
, &loc
);
3058 /* Emits error when symbol represents assumed size/rank array. */
3061 check_array_not_assumed (gfc_symbol
*sym
, locus loc
, const char *name
)
3063 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
3064 gfc_error ("Assumed size array %qs in %s clause at %L",
3065 sym
->name
, name
, &loc
);
3066 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_RANK
)
3067 gfc_error ("Assumed rank array %qs in %s clause at %L",
3068 sym
->name
, name
, &loc
);
3069 if (sym
->as
&& sym
->as
->type
== AS_DEFERRED
&& sym
->attr
.pointer
3070 && !sym
->attr
.contiguous
)
3071 gfc_error ("Noncontiguous deferred shape array %qs in %s clause at %L",
3072 sym
->name
, name
, &loc
);
3076 resolve_oacc_data_clauses (gfc_symbol
*sym
, locus loc
, const char *name
)
3078 if (sym
->ts
.type
== BT_DERIVED
&& sym
->attr
.allocatable
)
3079 gfc_error ("ALLOCATABLE object %qs of derived type in %s clause at %L",
3080 sym
->name
, name
, &loc
);
3081 if ((sym
->ts
.type
== BT_ASSUMED
&& sym
->attr
.allocatable
)
3082 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
3083 && CLASS_DATA (sym
)->attr
.allocatable
))
3084 gfc_error ("ALLOCATABLE object %qs of polymorphic type "
3085 "in %s clause at %L", sym
->name
, name
, &loc
);
3086 check_symbol_not_pointer (sym
, loc
, name
);
3087 check_array_not_assumed (sym
, loc
, name
);
3091 resolve_oacc_deviceptr_clause (gfc_symbol
*sym
, locus loc
, const char *name
)
3093 if (sym
->attr
.pointer
3094 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
3095 && CLASS_DATA (sym
)->attr
.class_pointer
))
3096 gfc_error ("POINTER object %qs in %s clause at %L",
3097 sym
->name
, name
, &loc
);
3098 if (sym
->attr
.cray_pointer
3099 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
3100 && CLASS_DATA (sym
)->attr
.cray_pointer
))
3101 gfc_error ("Cray pointer object %qs in %s clause at %L",
3102 sym
->name
, name
, &loc
);
3103 if (sym
->attr
.cray_pointee
3104 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
3105 && CLASS_DATA (sym
)->attr
.cray_pointee
))
3106 gfc_error ("Cray pointee object %qs in %s clause at %L",
3107 sym
->name
, name
, &loc
);
3108 if (sym
->attr
.allocatable
3109 || (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)
3110 && CLASS_DATA (sym
)->attr
.allocatable
))
3111 gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
3112 sym
->name
, name
, &loc
);
3113 if (sym
->attr
.value
)
3114 gfc_error ("VALUE object %qs in %s clause at %L",
3115 sym
->name
, name
, &loc
);
3116 check_array_not_assumed (sym
, loc
, name
);
3120 struct resolve_omp_udr_callback_data
3122 gfc_symbol
*sym1
, *sym2
;
3127 resolve_omp_udr_callback (gfc_expr
**e
, int *, void *data
)
3129 struct resolve_omp_udr_callback_data
*rcd
3130 = (struct resolve_omp_udr_callback_data
*) data
;
3131 if ((*e
)->expr_type
== EXPR_VARIABLE
3132 && ((*e
)->symtree
->n
.sym
== rcd
->sym1
3133 || (*e
)->symtree
->n
.sym
== rcd
->sym2
))
3135 gfc_ref
*ref
= gfc_get_ref ();
3136 ref
->type
= REF_ARRAY
;
3137 ref
->u
.ar
.where
= (*e
)->where
;
3138 ref
->u
.ar
.as
= (*e
)->symtree
->n
.sym
->as
;
3139 ref
->u
.ar
.type
= AR_FULL
;
3140 ref
->u
.ar
.dimen
= 0;
3141 ref
->next
= (*e
)->ref
;
3149 resolve_omp_udr_callback2 (gfc_expr
**e
, int *, void *)
3151 if ((*e
)->expr_type
== EXPR_FUNCTION
3152 && (*e
)->value
.function
.isym
== NULL
)
3154 gfc_symbol
*sym
= (*e
)->symtree
->n
.sym
;
3155 if (!sym
->attr
.intrinsic
3156 && sym
->attr
.if_source
== IFSRC_UNKNOWN
)
3157 gfc_error ("Implicitly declared function %s used in "
3158 "!$OMP DECLARE REDUCTION at %L ", sym
->name
, &(*e
)->where
);
3165 resolve_omp_udr_clause (gfc_omp_namelist
*n
, gfc_namespace
*ns
,
3166 gfc_symbol
*sym1
, gfc_symbol
*sym2
)
3169 gfc_symbol sym1_copy
, sym2_copy
;
3171 if (ns
->code
->op
== EXEC_ASSIGN
)
3173 copy
= gfc_get_code (EXEC_ASSIGN
);
3174 copy
->expr1
= gfc_copy_expr (ns
->code
->expr1
);
3175 copy
->expr2
= gfc_copy_expr (ns
->code
->expr2
);
3179 copy
= gfc_get_code (EXEC_CALL
);
3180 copy
->symtree
= ns
->code
->symtree
;
3181 copy
->ext
.actual
= gfc_copy_actual_arglist (ns
->code
->ext
.actual
);
3183 copy
->loc
= ns
->code
->loc
;
3188 sym1
->name
= sym1_copy
.name
;
3189 sym2
->name
= sym2_copy
.name
;
3190 ns
->proc_name
= ns
->parent
->proc_name
;
3191 if (n
->sym
->attr
.dimension
)
3193 struct resolve_omp_udr_callback_data rcd
;
3196 gfc_code_walker (©
, gfc_dummy_code_callback
,
3197 resolve_omp_udr_callback
, &rcd
);
3199 gfc_resolve_code (copy
, gfc_current_ns
);
3200 if (copy
->op
== EXEC_CALL
&& copy
->resolved_isym
== NULL
)
3202 gfc_symbol
*sym
= copy
->resolved_sym
;
3204 && !sym
->attr
.intrinsic
3205 && sym
->attr
.if_source
== IFSRC_UNKNOWN
)
3206 gfc_error ("Implicitly declared subroutine %s used in "
3207 "!$OMP DECLARE REDUCTION at %L ", sym
->name
,
3210 gfc_code_walker (©
, gfc_dummy_code_callback
,
3211 resolve_omp_udr_callback2
, NULL
);
3217 /* OpenMP directive resolving routines. */
3220 resolve_omp_clauses (gfc_code
*code
, gfc_omp_clauses
*omp_clauses
,
3221 gfc_namespace
*ns
, bool openacc
= false)
3223 gfc_omp_namelist
*n
;
3226 static const char *clause_names
[]
3227 = { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
3228 "COPYIN", "UNIFORM", "ALIGNED", "LINEAR", "DEPEND", "MAP",
3229 "TO", "FROM", "REDUCTION", "DEVICE_RESIDENT", "LINK", "USE_DEVICE",
3232 if (omp_clauses
== NULL
)
3235 if (omp_clauses
->if_expr
)
3237 gfc_expr
*expr
= omp_clauses
->if_expr
;
3238 if (!gfc_resolve_expr (expr
)
3239 || expr
->ts
.type
!= BT_LOGICAL
|| expr
->rank
!= 0)
3240 gfc_error ("IF clause at %L requires a scalar LOGICAL expression",
3243 if (omp_clauses
->final_expr
)
3245 gfc_expr
*expr
= omp_clauses
->final_expr
;
3246 if (!gfc_resolve_expr (expr
)
3247 || expr
->ts
.type
!= BT_LOGICAL
|| expr
->rank
!= 0)
3248 gfc_error ("FINAL clause at %L requires a scalar LOGICAL expression",
3251 if (omp_clauses
->num_threads
)
3253 gfc_expr
*expr
= omp_clauses
->num_threads
;
3254 if (!gfc_resolve_expr (expr
)
3255 || expr
->ts
.type
!= BT_INTEGER
|| expr
->rank
!= 0)
3256 gfc_error ("NUM_THREADS clause at %L requires a scalar "
3257 "INTEGER expression", &expr
->where
);
3259 if (omp_clauses
->chunk_size
)
3261 gfc_expr
*expr
= omp_clauses
->chunk_size
;
3262 if (!gfc_resolve_expr (expr
)
3263 || expr
->ts
.type
!= BT_INTEGER
|| expr
->rank
!= 0)
3264 gfc_error ("SCHEDULE clause's chunk_size at %L requires "
3265 "a scalar INTEGER expression", &expr
->where
);
3266 else if (expr
->expr_type
== EXPR_CONSTANT
3267 && expr
->ts
.type
== BT_INTEGER
3268 && mpz_sgn (expr
->value
.integer
) <= 0)
3269 gfc_warning (0, "INTEGER expression of SCHEDULE clause's chunk_size "
3270 "at %L must be positive", &expr
->where
);
3273 /* Check that no symbol appears on multiple clauses, except that
3274 a symbol can appear on both firstprivate and lastprivate. */
3275 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
3276 for (n
= omp_clauses
->lists
[list
]; n
; n
= n
->next
)
3279 if (n
->sym
->attr
.flavor
== FL_VARIABLE
3280 || n
->sym
->attr
.proc_pointer
3281 || (!code
&& (!n
->sym
->attr
.dummy
|| n
->sym
->ns
!= ns
)))
3283 if (!code
&& (!n
->sym
->attr
.dummy
|| n
->sym
->ns
!= ns
))
3284 gfc_error ("Variable %qs is not a dummy argument at %L",
3285 n
->sym
->name
, &n
->where
);
3288 if (n
->sym
->attr
.flavor
== FL_PROCEDURE
3289 && n
->sym
->result
== n
->sym
3290 && n
->sym
->attr
.function
)
3292 if (gfc_current_ns
->proc_name
== n
->sym
3293 || (gfc_current_ns
->parent
3294 && gfc_current_ns
->parent
->proc_name
== n
->sym
))
3296 if (gfc_current_ns
->proc_name
->attr
.entry_master
)
3298 gfc_entry_list
*el
= gfc_current_ns
->entries
;
3299 for (; el
; el
= el
->next
)
3300 if (el
->sym
== n
->sym
)
3305 if (gfc_current_ns
->parent
3306 && gfc_current_ns
->parent
->proc_name
->attr
.entry_master
)
3308 gfc_entry_list
*el
= gfc_current_ns
->parent
->entries
;
3309 for (; el
; el
= el
->next
)
3310 if (el
->sym
== n
->sym
)
3316 gfc_error ("Object %qs is not a variable at %L", n
->sym
->name
,
3320 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
3321 if (list
!= OMP_LIST_FIRSTPRIVATE
3322 && list
!= OMP_LIST_LASTPRIVATE
3323 && list
!= OMP_LIST_ALIGNED
3324 && list
!= OMP_LIST_DEPEND
3325 && (list
!= OMP_LIST_MAP
|| openacc
)
3326 && list
!= OMP_LIST_FROM
3327 && list
!= OMP_LIST_TO
3328 && (list
!= OMP_LIST_REDUCTION
|| !openacc
))
3329 for (n
= omp_clauses
->lists
[list
]; n
; n
= n
->next
)
3332 gfc_error ("Symbol %qs present on multiple clauses at %L",
3333 n
->sym
->name
, &n
->where
);
3338 gcc_assert (OMP_LIST_LASTPRIVATE
== OMP_LIST_FIRSTPRIVATE
+ 1);
3339 for (list
= OMP_LIST_FIRSTPRIVATE
; list
<= OMP_LIST_LASTPRIVATE
; list
++)
3340 for (n
= omp_clauses
->lists
[list
]; n
; n
= n
->next
)
3343 gfc_error ("Symbol %qs present on multiple clauses at %L",
3344 n
->sym
->name
, &n
->where
);
3348 for (n
= omp_clauses
->lists
[OMP_LIST_FIRSTPRIVATE
]; n
; n
= n
->next
)
3351 gfc_error ("Symbol %qs present on multiple clauses at %L",
3352 n
->sym
->name
, &n
->where
);
3356 for (n
= omp_clauses
->lists
[OMP_LIST_LASTPRIVATE
]; n
; n
= n
->next
)
3359 for (n
= omp_clauses
->lists
[OMP_LIST_LASTPRIVATE
]; n
; n
= n
->next
)
3362 gfc_error ("Symbol %qs present on multiple clauses at %L",
3363 n
->sym
->name
, &n
->where
);
3368 for (n
= omp_clauses
->lists
[OMP_LIST_ALIGNED
]; n
; n
= n
->next
)
3371 for (n
= omp_clauses
->lists
[OMP_LIST_ALIGNED
]; n
; n
= n
->next
)
3374 gfc_error ("Symbol %qs present on multiple clauses at %L",
3375 n
->sym
->name
, &n
->where
);
3380 /* OpenACC reductions. */
3383 for (n
= omp_clauses
->lists
[OMP_LIST_REDUCTION
]; n
; n
= n
->next
)
3386 for (n
= omp_clauses
->lists
[OMP_LIST_REDUCTION
]; n
; n
= n
->next
)
3389 gfc_error ("Symbol %qs present on multiple clauses at %L",
3390 n
->sym
->name
, &n
->where
);
3394 /* OpenACC does not support reductions on arrays. */
3396 gfc_error ("Array %qs is not permitted in reduction at %L",
3397 n
->sym
->name
, &n
->where
);
3401 for (n
= omp_clauses
->lists
[OMP_LIST_TO
]; n
; n
= n
->next
)
3403 for (n
= omp_clauses
->lists
[OMP_LIST_FROM
]; n
; n
= n
->next
)
3404 if (n
->expr
== NULL
)
3406 for (n
= omp_clauses
->lists
[OMP_LIST_TO
]; n
; n
= n
->next
)
3408 if (n
->expr
== NULL
&& n
->sym
->mark
)
3409 gfc_error ("Symbol %qs present on both FROM and TO clauses at %L",
3410 n
->sym
->name
, &n
->where
);
3415 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
3416 if ((n
= omp_clauses
->lists
[list
]) != NULL
)
3420 if (list
< OMP_LIST_NUM
)
3421 name
= clause_names
[list
];
3427 case OMP_LIST_COPYIN
:
3428 for (; n
!= NULL
; n
= n
->next
)
3430 if (!n
->sym
->attr
.threadprivate
)
3431 gfc_error ("Non-THREADPRIVATE object %qs in COPYIN clause"
3432 " at %L", n
->sym
->name
, &n
->where
);
3435 case OMP_LIST_COPYPRIVATE
:
3436 for (; n
!= NULL
; n
= n
->next
)
3438 if (n
->sym
->as
&& n
->sym
->as
->type
== AS_ASSUMED_SIZE
)
3439 gfc_error ("Assumed size array %qs in COPYPRIVATE clause "
3440 "at %L", n
->sym
->name
, &n
->where
);
3441 if (n
->sym
->attr
.pointer
&& n
->sym
->attr
.intent
== INTENT_IN
)
3442 gfc_error ("INTENT(IN) POINTER %qs in COPYPRIVATE clause "
3443 "at %L", n
->sym
->name
, &n
->where
);
3446 case OMP_LIST_SHARED
:
3447 for (; n
!= NULL
; n
= n
->next
)
3449 if (n
->sym
->attr
.threadprivate
)
3450 gfc_error ("THREADPRIVATE object %qs in SHARED clause at "
3451 "%L", n
->sym
->name
, &n
->where
);
3452 if (n
->sym
->attr
.cray_pointee
)
3453 gfc_error ("Cray pointee %qs in SHARED clause at %L",
3454 n
->sym
->name
, &n
->where
);
3455 if (n
->sym
->attr
.associate_var
)
3456 gfc_error ("ASSOCIATE name %qs in SHARED clause at %L",
3457 n
->sym
->name
, &n
->where
);
3460 case OMP_LIST_ALIGNED
:
3461 for (; n
!= NULL
; n
= n
->next
)
3463 if (!n
->sym
->attr
.pointer
3464 && !n
->sym
->attr
.allocatable
3465 && !n
->sym
->attr
.cray_pointer
3466 && (n
->sym
->ts
.type
!= BT_DERIVED
3467 || (n
->sym
->ts
.u
.derived
->from_intmod
3468 != INTMOD_ISO_C_BINDING
)
3469 || (n
->sym
->ts
.u
.derived
->intmod_sym_id
3470 != ISOCBINDING_PTR
)))
3471 gfc_error ("%qs in ALIGNED clause must be POINTER, "
3472 "ALLOCATABLE, Cray pointer or C_PTR at %L",
3473 n
->sym
->name
, &n
->where
);
3476 gfc_expr
*expr
= n
->expr
;
3478 if (!gfc_resolve_expr (expr
)
3479 || expr
->ts
.type
!= BT_INTEGER
3481 || gfc_extract_int (expr
, &alignment
)
3483 gfc_error ("%qs in ALIGNED clause at %L requires a scalar "
3484 "positive constant integer alignment "
3485 "expression", n
->sym
->name
, &n
->where
);
3489 case OMP_LIST_DEPEND
:
3493 case OMP_LIST_CACHE
:
3494 for (; n
!= NULL
; n
= n
->next
)
3498 if (!gfc_resolve_expr (n
->expr
)
3499 || n
->expr
->expr_type
!= EXPR_VARIABLE
3500 || n
->expr
->ref
== NULL
3501 || n
->expr
->ref
->next
3502 || n
->expr
->ref
->type
!= REF_ARRAY
)
3503 gfc_error ("%qs in %s clause at %L is not a proper "
3504 "array section", n
->sym
->name
, name
,
3506 else if (n
->expr
->ref
->u
.ar
.codimen
)
3507 gfc_error ("Coarrays not supported in %s clause at %L",
3512 gfc_array_ref
*ar
= &n
->expr
->ref
->u
.ar
;
3513 for (i
= 0; i
< ar
->dimen
; i
++)
3516 gfc_error ("Stride should not be specified for "
3517 "array section in %s clause at %L",
3521 else if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
3522 && ar
->dimen_type
[i
] != DIMEN_RANGE
)
3524 gfc_error ("%qs in %s clause at %L is not a "
3525 "proper array section",
3526 n
->sym
->name
, name
, &n
->where
);
3529 else if (list
== OMP_LIST_DEPEND
3531 && ar
->start
[i
]->expr_type
== EXPR_CONSTANT
3533 && ar
->end
[i
]->expr_type
== EXPR_CONSTANT
3534 && mpz_cmp (ar
->start
[i
]->value
.integer
,
3535 ar
->end
[i
]->value
.integer
) > 0)
3537 gfc_error ("%qs in DEPEND clause at %L is a "
3538 "zero size array section",
3539 n
->sym
->name
, &n
->where
);
3546 if (list
== OMP_LIST_MAP
3547 && n
->u
.map_op
== OMP_MAP_FORCE_DEVICEPTR
)
3548 resolve_oacc_deviceptr_clause (n
->sym
, n
->where
, name
);
3550 resolve_oacc_data_clauses (n
->sym
, n
->where
, name
);
3554 if (list
!= OMP_LIST_DEPEND
)
3555 for (n
= omp_clauses
->lists
[list
]; n
!= NULL
; n
= n
->next
)
3557 n
->sym
->attr
.referenced
= 1;
3558 if (n
->sym
->attr
.threadprivate
)
3559 gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
3560 n
->sym
->name
, name
, &n
->where
);
3561 if (n
->sym
->attr
.cray_pointee
)
3562 gfc_error ("Cray pointee %qs in %s clause at %L",
3563 n
->sym
->name
, name
, &n
->where
);
3567 for (; n
!= NULL
; n
= n
->next
)
3570 if (n
->sym
->attr
.threadprivate
)
3571 gfc_error ("THREADPRIVATE object %qs in %s clause at %L",
3572 n
->sym
->name
, name
, &n
->where
);
3573 if (n
->sym
->attr
.cray_pointee
)
3574 gfc_error ("Cray pointee %qs in %s clause at %L",
3575 n
->sym
->name
, name
, &n
->where
);
3576 if (n
->sym
->attr
.associate_var
)
3577 gfc_error ("ASSOCIATE name %qs in %s clause at %L",
3578 n
->sym
->name
, name
, &n
->where
);
3579 if (list
!= OMP_LIST_PRIVATE
)
3581 if (n
->sym
->attr
.proc_pointer
&& list
== OMP_LIST_REDUCTION
)
3582 gfc_error ("Procedure pointer %qs in %s clause at %L",
3583 n
->sym
->name
, name
, &n
->where
);
3584 if (n
->sym
->attr
.pointer
&& list
== OMP_LIST_REDUCTION
)
3585 gfc_error ("POINTER object %qs in %s clause at %L",
3586 n
->sym
->name
, name
, &n
->where
);
3587 if (n
->sym
->attr
.cray_pointer
&& list
== OMP_LIST_REDUCTION
)
3588 gfc_error ("Cray pointer %qs in %s clause at %L",
3589 n
->sym
->name
, name
, &n
->where
);
3592 && (oacc_is_loop (code
) || code
->op
== EXEC_OACC_PARALLEL
))
3593 check_array_not_assumed (n
->sym
, n
->where
, name
);
3594 else if (n
->sym
->as
&& n
->sym
->as
->type
== AS_ASSUMED_SIZE
)
3595 gfc_error ("Assumed size array %qs in %s clause at %L",
3596 n
->sym
->name
, name
, &n
->where
);
3597 if (n
->sym
->attr
.in_namelist
&& list
!= OMP_LIST_REDUCTION
)
3598 gfc_error ("Variable %qs in %s clause is used in "
3599 "NAMELIST statement at %L",
3600 n
->sym
->name
, name
, &n
->where
);
3601 if (n
->sym
->attr
.pointer
&& n
->sym
->attr
.intent
== INTENT_IN
)
3604 case OMP_LIST_PRIVATE
:
3605 case OMP_LIST_LASTPRIVATE
:
3606 case OMP_LIST_LINEAR
:
3607 /* case OMP_LIST_REDUCTION: */
3608 gfc_error ("INTENT(IN) POINTER %qs in %s clause at %L",
3609 n
->sym
->name
, name
, &n
->where
);
3617 case OMP_LIST_REDUCTION
:
3618 switch (n
->u
.reduction_op
)
3620 case OMP_REDUCTION_PLUS
:
3621 case OMP_REDUCTION_TIMES
:
3622 case OMP_REDUCTION_MINUS
:
3623 if (!gfc_numeric_ts (&n
->sym
->ts
))
3626 case OMP_REDUCTION_AND
:
3627 case OMP_REDUCTION_OR
:
3628 case OMP_REDUCTION_EQV
:
3629 case OMP_REDUCTION_NEQV
:
3630 if (n
->sym
->ts
.type
!= BT_LOGICAL
)
3633 case OMP_REDUCTION_MAX
:
3634 case OMP_REDUCTION_MIN
:
3635 if (n
->sym
->ts
.type
!= BT_INTEGER
3636 && n
->sym
->ts
.type
!= BT_REAL
)
3639 case OMP_REDUCTION_IAND
:
3640 case OMP_REDUCTION_IOR
:
3641 case OMP_REDUCTION_IEOR
:
3642 if (n
->sym
->ts
.type
!= BT_INTEGER
)
3645 case OMP_REDUCTION_USER
:
3655 const char *udr_name
= NULL
;
3658 udr_name
= n
->udr
->udr
->name
;
3660 = gfc_find_omp_udr (NULL
, udr_name
,
3662 if (n
->udr
->udr
== NULL
)
3670 if (udr_name
== NULL
)
3671 switch (n
->u
.reduction_op
)
3673 case OMP_REDUCTION_PLUS
:
3674 case OMP_REDUCTION_TIMES
:
3675 case OMP_REDUCTION_MINUS
:
3676 case OMP_REDUCTION_AND
:
3677 case OMP_REDUCTION_OR
:
3678 case OMP_REDUCTION_EQV
:
3679 case OMP_REDUCTION_NEQV
:
3680 udr_name
= gfc_op2string ((gfc_intrinsic_op
)
3683 case OMP_REDUCTION_MAX
:
3686 case OMP_REDUCTION_MIN
:
3689 case OMP_REDUCTION_IAND
:
3692 case OMP_REDUCTION_IOR
:
3695 case OMP_REDUCTION_IEOR
:
3701 gfc_error ("!$OMP DECLARE REDUCTION %s not found "
3702 "for type %s at %L", udr_name
,
3703 gfc_typename (&n
->sym
->ts
), &n
->where
);
3707 gfc_omp_udr
*udr
= n
->udr
->udr
;
3708 n
->u
.reduction_op
= OMP_REDUCTION_USER
;
3710 = resolve_omp_udr_clause (n
, udr
->combiner_ns
,
3713 if (udr
->initializer_ns
)
3715 = resolve_omp_udr_clause (n
,
3716 udr
->initializer_ns
,
3722 case OMP_LIST_LINEAR
:
3723 if (n
->sym
->ts
.type
!= BT_INTEGER
)
3724 gfc_error ("LINEAR variable %qs must be INTEGER "
3725 "at %L", n
->sym
->name
, &n
->where
);
3726 else if (!code
&& !n
->sym
->attr
.value
)
3727 gfc_error ("LINEAR dummy argument %qs must have VALUE "
3728 "attribute at %L", n
->sym
->name
, &n
->where
);
3731 gfc_expr
*expr
= n
->expr
;
3732 if (!gfc_resolve_expr (expr
)
3733 || expr
->ts
.type
!= BT_INTEGER
3735 gfc_error ("%qs in LINEAR clause at %L requires "
3736 "a scalar integer linear-step expression",
3737 n
->sym
->name
, &n
->where
);
3738 else if (!code
&& expr
->expr_type
!= EXPR_CONSTANT
)
3739 gfc_error ("%qs in LINEAR clause at %L requires "
3740 "a constant integer linear-step expression",
3741 n
->sym
->name
, &n
->where
);
3744 /* Workaround for PR middle-end/26316, nothing really needs
3745 to be done here for OMP_LIST_PRIVATE. */
3746 case OMP_LIST_PRIVATE
:
3747 gcc_assert (code
&& code
->op
!= EXEC_NOP
);
3749 case OMP_LIST_USE_DEVICE
:
3750 if (n
->sym
->attr
.allocatable
3751 || (n
->sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (n
->sym
)
3752 && CLASS_DATA (n
->sym
)->attr
.allocatable
))
3753 gfc_error ("ALLOCATABLE object %qs in %s clause at %L",
3754 n
->sym
->name
, name
, &n
->where
);
3755 if (n
->sym
->attr
.pointer
3756 || (n
->sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (n
->sym
)
3757 && CLASS_DATA (n
->sym
)->attr
.class_pointer
))
3758 gfc_error ("POINTER object %qs in %s clause at %L",
3759 n
->sym
->name
, name
, &n
->where
);
3760 if (n
->sym
->attr
.cray_pointer
)
3761 gfc_error ("Cray pointer object %qs in %s clause at %L",
3762 n
->sym
->name
, name
, &n
->where
);
3763 if (n
->sym
->attr
.cray_pointee
)
3764 gfc_error ("Cray pointee object %qs in %s clause at %L",
3765 n
->sym
->name
, name
, &n
->where
);
3767 case OMP_LIST_DEVICE_RESIDENT
:
3768 check_symbol_not_pointer (n
->sym
, n
->where
, name
);
3769 check_array_not_assumed (n
->sym
, n
->where
, name
);
3778 if (omp_clauses
->safelen_expr
)
3780 gfc_expr
*expr
= omp_clauses
->safelen_expr
;
3781 if (!gfc_resolve_expr (expr
)
3782 || expr
->ts
.type
!= BT_INTEGER
|| expr
->rank
!= 0)
3783 gfc_error ("SAFELEN clause at %L requires a scalar "
3784 "INTEGER expression", &expr
->where
);
3786 if (omp_clauses
->simdlen_expr
)
3788 gfc_expr
*expr
= omp_clauses
->simdlen_expr
;
3789 if (!gfc_resolve_expr (expr
)
3790 || expr
->ts
.type
!= BT_INTEGER
|| expr
->rank
!= 0)
3791 gfc_error ("SIMDLEN clause at %L requires a scalar "
3792 "INTEGER expression", &expr
->where
);
3794 if (omp_clauses
->num_teams
)
3796 gfc_expr
*expr
= omp_clauses
->num_teams
;
3797 if (!gfc_resolve_expr (expr
)
3798 || expr
->ts
.type
!= BT_INTEGER
|| expr
->rank
!= 0)
3799 gfc_error ("NUM_TEAMS clause at %L requires a scalar "
3800 "INTEGER expression", &expr
->where
);
3802 if (omp_clauses
->device
)
3804 gfc_expr
*expr
= omp_clauses
->device
;
3805 if (!gfc_resolve_expr (expr
)
3806 || expr
->ts
.type
!= BT_INTEGER
|| expr
->rank
!= 0)
3807 gfc_error ("DEVICE clause at %L requires a scalar "
3808 "INTEGER expression", &expr
->where
);
3810 if (omp_clauses
->dist_chunk_size
)
3812 gfc_expr
*expr
= omp_clauses
->dist_chunk_size
;
3813 if (!gfc_resolve_expr (expr
)
3814 || expr
->ts
.type
!= BT_INTEGER
|| expr
->rank
!= 0)
3815 gfc_error ("DIST_SCHEDULE clause's chunk_size at %L requires "
3816 "a scalar INTEGER expression", &expr
->where
);
3818 if (omp_clauses
->thread_limit
)
3820 gfc_expr
*expr
= omp_clauses
->thread_limit
;
3821 if (!gfc_resolve_expr (expr
)
3822 || expr
->ts
.type
!= BT_INTEGER
|| expr
->rank
!= 0)
3823 gfc_error ("THREAD_LIMIT clause at %L requires a scalar "
3824 "INTEGER expression", &expr
->where
);
3826 if (omp_clauses
->async
)
3827 if (omp_clauses
->async_expr
)
3828 resolve_oacc_scalar_int_expr (omp_clauses
->async_expr
, "ASYNC");
3829 if (omp_clauses
->num_gangs_expr
)
3830 resolve_oacc_positive_int_expr (omp_clauses
->num_gangs_expr
, "NUM_GANGS");
3831 if (omp_clauses
->num_workers_expr
)
3832 resolve_oacc_positive_int_expr (omp_clauses
->num_workers_expr
,
3834 if (omp_clauses
->vector_length_expr
)
3835 resolve_oacc_positive_int_expr (omp_clauses
->vector_length_expr
,
3837 if (omp_clauses
->gang_num_expr
)
3838 resolve_oacc_positive_int_expr (omp_clauses
->gang_num_expr
, "GANG");
3839 if (omp_clauses
->gang_static_expr
)
3840 resolve_oacc_positive_int_expr (omp_clauses
->gang_static_expr
, "GANG");
3841 if (omp_clauses
->worker_expr
)
3842 resolve_oacc_positive_int_expr (omp_clauses
->worker_expr
, "WORKER");
3843 if (omp_clauses
->vector_expr
)
3844 resolve_oacc_positive_int_expr (omp_clauses
->vector_expr
, "VECTOR");
3845 if (omp_clauses
->wait
)
3846 if (omp_clauses
->wait_list
)
3847 for (el
= omp_clauses
->wait_list
; el
; el
= el
->next
)
3848 resolve_oacc_scalar_int_expr (el
->expr
, "WAIT");
3852 /* Return true if SYM is ever referenced in EXPR except in the SE node. */
3855 expr_references_sym (gfc_expr
*e
, gfc_symbol
*s
, gfc_expr
*se
)
3857 gfc_actual_arglist
*arg
;
3858 if (e
== NULL
|| e
== se
)
3860 switch (e
->expr_type
)
3865 case EXPR_STRUCTURE
:
3867 if (e
->symtree
!= NULL
3868 && e
->symtree
->n
.sym
== s
)
3871 case EXPR_SUBSTRING
:
3873 && (expr_references_sym (e
->ref
->u
.ss
.start
, s
, se
)
3874 || expr_references_sym (e
->ref
->u
.ss
.end
, s
, se
)))
3878 if (expr_references_sym (e
->value
.op
.op2
, s
, se
))
3880 return expr_references_sym (e
->value
.op
.op1
, s
, se
);
3882 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
3883 if (expr_references_sym (arg
->expr
, s
, se
))
3892 /* If EXPR is a conversion function that widens the type
3893 if WIDENING is true or narrows the type if WIDENING is false,
3894 return the inner expression, otherwise return NULL. */
3897 is_conversion (gfc_expr
*expr
, bool widening
)
3899 gfc_typespec
*ts1
, *ts2
;
3901 if (expr
->expr_type
!= EXPR_FUNCTION
3902 || expr
->value
.function
.isym
== NULL
3903 || expr
->value
.function
.esym
!= NULL
3904 || expr
->value
.function
.isym
->id
!= GFC_ISYM_CONVERSION
)
3910 ts2
= &expr
->value
.function
.actual
->expr
->ts
;
3914 ts1
= &expr
->value
.function
.actual
->expr
->ts
;
3918 if (ts1
->type
> ts2
->type
3919 || (ts1
->type
== ts2
->type
&& ts1
->kind
> ts2
->kind
))
3920 return expr
->value
.function
.actual
->expr
;
3927 resolve_omp_atomic (gfc_code
*code
)
3929 gfc_code
*atomic_code
= code
;
3931 gfc_expr
*expr2
, *expr2_tmp
;
3932 gfc_omp_atomic_op aop
3933 = (gfc_omp_atomic_op
) (atomic_code
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
);
3935 code
= code
->block
->next
;
3936 gcc_assert (code
->op
== EXEC_ASSIGN
);
3937 gcc_assert (((aop
!= GFC_OMP_ATOMIC_CAPTURE
) && code
->next
== NULL
)
3938 || ((aop
== GFC_OMP_ATOMIC_CAPTURE
)
3939 && code
->next
!= NULL
3940 && code
->next
->op
== EXEC_ASSIGN
3941 && code
->next
->next
== NULL
));
3943 if (code
->expr1
->expr_type
!= EXPR_VARIABLE
3944 || code
->expr1
->symtree
== NULL
3945 || code
->expr1
->rank
!= 0
3946 || (code
->expr1
->ts
.type
!= BT_INTEGER
3947 && code
->expr1
->ts
.type
!= BT_REAL
3948 && code
->expr1
->ts
.type
!= BT_COMPLEX
3949 && code
->expr1
->ts
.type
!= BT_LOGICAL
))
3951 gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
3952 "intrinsic type at %L", &code
->loc
);
3956 var
= code
->expr1
->symtree
->n
.sym
;
3957 expr2
= is_conversion (code
->expr2
, false);
3960 if (aop
== GFC_OMP_ATOMIC_READ
|| aop
== GFC_OMP_ATOMIC_WRITE
)
3961 expr2
= is_conversion (code
->expr2
, true);
3963 expr2
= code
->expr2
;
3968 case GFC_OMP_ATOMIC_READ
:
3969 if (expr2
->expr_type
!= EXPR_VARIABLE
3970 || expr2
->symtree
== NULL
3972 || (expr2
->ts
.type
!= BT_INTEGER
3973 && expr2
->ts
.type
!= BT_REAL
3974 && expr2
->ts
.type
!= BT_COMPLEX
3975 && expr2
->ts
.type
!= BT_LOGICAL
))
3976 gfc_error ("!$OMP ATOMIC READ statement must read from a scalar "
3977 "variable of intrinsic type at %L", &expr2
->where
);
3979 case GFC_OMP_ATOMIC_WRITE
:
3980 if (expr2
->rank
!= 0 || expr_references_sym (code
->expr2
, var
, NULL
))
3981 gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr "
3982 "must be scalar and cannot reference var at %L",
3985 case GFC_OMP_ATOMIC_CAPTURE
:
3987 if (expr2
== code
->expr2
)
3989 expr2_tmp
= is_conversion (code
->expr2
, true);
3990 if (expr2_tmp
== NULL
)
3993 if (expr2_tmp
->expr_type
== EXPR_VARIABLE
)
3995 if (expr2_tmp
->symtree
== NULL
3996 || expr2_tmp
->rank
!= 0
3997 || (expr2_tmp
->ts
.type
!= BT_INTEGER
3998 && expr2_tmp
->ts
.type
!= BT_REAL
3999 && expr2_tmp
->ts
.type
!= BT_COMPLEX
4000 && expr2_tmp
->ts
.type
!= BT_LOGICAL
)
4001 || expr2_tmp
->symtree
->n
.sym
== var
)
4003 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read from "
4004 "a scalar variable of intrinsic type at %L",
4008 var
= expr2_tmp
->symtree
->n
.sym
;
4010 if (code
->expr1
->expr_type
!= EXPR_VARIABLE
4011 || code
->expr1
->symtree
== NULL
4012 || code
->expr1
->rank
!= 0
4013 || (code
->expr1
->ts
.type
!= BT_INTEGER
4014 && code
->expr1
->ts
.type
!= BT_REAL
4015 && code
->expr1
->ts
.type
!= BT_COMPLEX
4016 && code
->expr1
->ts
.type
!= BT_LOGICAL
))
4018 gfc_error ("!$OMP ATOMIC CAPTURE update statement must set "
4019 "a scalar variable of intrinsic type at %L",
4020 &code
->expr1
->where
);
4023 if (code
->expr1
->symtree
->n
.sym
!= var
)
4025 gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
4026 "different variable than update statement writes "
4027 "into at %L", &code
->expr1
->where
);
4030 expr2
= is_conversion (code
->expr2
, false);
4032 expr2
= code
->expr2
;
4039 if (gfc_expr_attr (code
->expr1
).allocatable
)
4041 gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L",
4046 if (aop
== GFC_OMP_ATOMIC_CAPTURE
4047 && code
->next
== NULL
4048 && code
->expr2
->rank
== 0
4049 && !expr_references_sym (code
->expr2
, var
, NULL
))
4050 atomic_code
->ext
.omp_atomic
4051 = (gfc_omp_atomic_op
) (atomic_code
->ext
.omp_atomic
4052 | GFC_OMP_ATOMIC_SWAP
);
4053 else if (expr2
->expr_type
== EXPR_OP
)
4055 gfc_expr
*v
= NULL
, *e
, *c
;
4056 gfc_intrinsic_op op
= expr2
->value
.op
.op
;
4057 gfc_intrinsic_op alt_op
= INTRINSIC_NONE
;
4061 case INTRINSIC_PLUS
:
4062 alt_op
= INTRINSIC_MINUS
;
4064 case INTRINSIC_TIMES
:
4065 alt_op
= INTRINSIC_DIVIDE
;
4067 case INTRINSIC_MINUS
:
4068 alt_op
= INTRINSIC_PLUS
;
4070 case INTRINSIC_DIVIDE
:
4071 alt_op
= INTRINSIC_TIMES
;
4077 alt_op
= INTRINSIC_NEQV
;
4079 case INTRINSIC_NEQV
:
4080 alt_op
= INTRINSIC_EQV
;
4083 gfc_error ("!$OMP ATOMIC assignment operator must be binary "
4084 "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
4089 /* Check for var = var op expr resp. var = expr op var where
4090 expr doesn't reference var and var op expr is mathematically
4091 equivalent to var op (expr) resp. expr op var equivalent to
4092 (expr) op var. We rely here on the fact that the matcher
4093 for x op1 y op2 z where op1 and op2 have equal precedence
4094 returns (x op1 y) op2 z. */
4095 e
= expr2
->value
.op
.op2
;
4096 if (e
->expr_type
== EXPR_VARIABLE
4097 && e
->symtree
!= NULL
4098 && e
->symtree
->n
.sym
== var
)
4100 else if ((c
= is_conversion (e
, true)) != NULL
4101 && c
->expr_type
== EXPR_VARIABLE
4102 && c
->symtree
!= NULL
4103 && c
->symtree
->n
.sym
== var
)
4107 gfc_expr
**p
= NULL
, **q
;
4108 for (q
= &expr2
->value
.op
.op1
; (e
= *q
) != NULL
; )
4109 if (e
->expr_type
== EXPR_VARIABLE
4110 && e
->symtree
!= NULL
4111 && e
->symtree
->n
.sym
== var
)
4116 else if ((c
= is_conversion (e
, true)) != NULL
)
4117 q
= &e
->value
.function
.actual
->expr
;
4118 else if (e
->expr_type
!= EXPR_OP
4119 || (e
->value
.op
.op
!= op
4120 && e
->value
.op
.op
!= alt_op
)
4126 q
= &e
->value
.op
.op1
;
4131 gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
4132 "or var = expr op var at %L", &expr2
->where
);
4139 switch (e
->value
.op
.op
)
4141 case INTRINSIC_MINUS
:
4142 case INTRINSIC_DIVIDE
:
4144 case INTRINSIC_NEQV
:
4145 gfc_error ("!$OMP ATOMIC var = var op expr not "
4146 "mathematically equivalent to var = var op "
4147 "(expr) at %L", &expr2
->where
);
4153 /* Canonicalize into var = var op (expr). */
4154 *p
= e
->value
.op
.op2
;
4155 e
->value
.op
.op2
= expr2
;
4157 if (code
->expr2
== expr2
)
4158 code
->expr2
= expr2
= e
;
4160 code
->expr2
->value
.function
.actual
->expr
= expr2
= e
;
4162 if (!gfc_compare_types (&expr2
->value
.op
.op1
->ts
, &expr2
->ts
))
4164 for (p
= &expr2
->value
.op
.op1
; *p
!= v
;
4165 p
= &(*p
)->value
.function
.actual
->expr
)
4168 gfc_free_expr (expr2
->value
.op
.op1
);
4169 expr2
->value
.op
.op1
= v
;
4170 gfc_convert_type (v
, &expr2
->ts
, 2);
4175 if (e
->rank
!= 0 || expr_references_sym (code
->expr2
, var
, v
))
4177 gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
4178 "must be scalar and cannot reference var at %L",
4183 else if (expr2
->expr_type
== EXPR_FUNCTION
4184 && expr2
->value
.function
.isym
!= NULL
4185 && expr2
->value
.function
.esym
== NULL
4186 && expr2
->value
.function
.actual
!= NULL
4187 && expr2
->value
.function
.actual
->next
!= NULL
)
4189 gfc_actual_arglist
*arg
, *var_arg
;
4191 switch (expr2
->value
.function
.isym
->id
)
4199 if (expr2
->value
.function
.actual
->next
->next
!= NULL
)
4201 gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
4202 "or IEOR must have two arguments at %L",
4208 gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
4209 "MIN, MAX, IAND, IOR or IEOR at %L",
4215 for (arg
= expr2
->value
.function
.actual
; arg
; arg
= arg
->next
)
4217 if ((arg
== expr2
->value
.function
.actual
4218 || (var_arg
== NULL
&& arg
->next
== NULL
))
4219 && arg
->expr
->expr_type
== EXPR_VARIABLE
4220 && arg
->expr
->symtree
!= NULL
4221 && arg
->expr
->symtree
->n
.sym
== var
)
4223 else if (expr_references_sym (arg
->expr
, var
, NULL
))
4225 gfc_error ("!$OMP ATOMIC intrinsic arguments except one must "
4226 "not reference %qs at %L",
4227 var
->name
, &arg
->expr
->where
);
4230 if (arg
->expr
->rank
!= 0)
4232 gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
4233 "at %L", &arg
->expr
->where
);
4238 if (var_arg
== NULL
)
4240 gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
4241 "be %qs at %L", var
->name
, &expr2
->where
);
4245 if (var_arg
!= expr2
->value
.function
.actual
)
4247 /* Canonicalize, so that var comes first. */
4248 gcc_assert (var_arg
->next
== NULL
);
4249 for (arg
= expr2
->value
.function
.actual
;
4250 arg
->next
!= var_arg
; arg
= arg
->next
)
4252 var_arg
->next
= expr2
->value
.function
.actual
;
4253 expr2
->value
.function
.actual
= var_arg
;
4258 gfc_error ("!$OMP ATOMIC assignment must have an operator or "
4259 "intrinsic on right hand side at %L", &expr2
->where
);
4261 if (aop
== GFC_OMP_ATOMIC_CAPTURE
&& code
->next
)
4264 if (code
->expr1
->expr_type
!= EXPR_VARIABLE
4265 || code
->expr1
->symtree
== NULL
4266 || code
->expr1
->rank
!= 0
4267 || (code
->expr1
->ts
.type
!= BT_INTEGER
4268 && code
->expr1
->ts
.type
!= BT_REAL
4269 && code
->expr1
->ts
.type
!= BT_COMPLEX
4270 && code
->expr1
->ts
.type
!= BT_LOGICAL
))
4272 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must set "
4273 "a scalar variable of intrinsic type at %L",
4274 &code
->expr1
->where
);
4278 expr2
= is_conversion (code
->expr2
, false);
4281 expr2
= is_conversion (code
->expr2
, true);
4283 expr2
= code
->expr2
;
4286 if (expr2
->expr_type
!= EXPR_VARIABLE
4287 || expr2
->symtree
== NULL
4289 || (expr2
->ts
.type
!= BT_INTEGER
4290 && expr2
->ts
.type
!= BT_REAL
4291 && expr2
->ts
.type
!= BT_COMPLEX
4292 && expr2
->ts
.type
!= BT_LOGICAL
))
4294 gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read "
4295 "from a scalar variable of intrinsic type at %L",
4299 if (expr2
->symtree
->n
.sym
!= var
)
4301 gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
4302 "different variable than update statement writes "
4303 "into at %L", &expr2
->where
);
4310 struct fortran_omp_context
4313 hash_set
<gfc_symbol
*> *sharing_clauses
;
4314 hash_set
<gfc_symbol
*> *private_iterators
;
4315 struct fortran_omp_context
*previous
;
4318 static gfc_code
*omp_current_do_code
;
4319 static int omp_current_do_collapse
;
4322 gfc_resolve_omp_do_blocks (gfc_code
*code
, gfc_namespace
*ns
)
4324 if (code
->block
->next
&& code
->block
->next
->op
== EXEC_DO
)
4329 omp_current_do_code
= code
->block
->next
;
4330 omp_current_do_collapse
= code
->ext
.omp_clauses
->collapse
;
4331 for (i
= 1, c
= omp_current_do_code
; i
< omp_current_do_collapse
; i
++)
4334 if (c
->op
!= EXEC_DO
|| c
->next
== NULL
)
4337 if (c
->op
!= EXEC_DO
)
4340 if (i
< omp_current_do_collapse
|| omp_current_do_collapse
<= 0)
4341 omp_current_do_collapse
= 1;
4343 gfc_resolve_blocks (code
->block
, ns
);
4344 omp_current_do_collapse
= 0;
4345 omp_current_do_code
= NULL
;
4350 gfc_resolve_omp_parallel_blocks (gfc_code
*code
, gfc_namespace
*ns
)
4352 struct fortran_omp_context ctx
;
4353 gfc_omp_clauses
*omp_clauses
= code
->ext
.omp_clauses
;
4354 gfc_omp_namelist
*n
;
4358 ctx
.sharing_clauses
= new hash_set
<gfc_symbol
*>;
4359 ctx
.private_iterators
= new hash_set
<gfc_symbol
*>;
4360 ctx
.previous
= omp_current_ctx
;
4361 ctx
.is_openmp
= true;
4362 omp_current_ctx
= &ctx
;
4364 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
4367 case OMP_LIST_SHARED
:
4368 case OMP_LIST_PRIVATE
:
4369 case OMP_LIST_FIRSTPRIVATE
:
4370 case OMP_LIST_LASTPRIVATE
:
4371 case OMP_LIST_REDUCTION
:
4372 case OMP_LIST_LINEAR
:
4373 for (n
= omp_clauses
->lists
[list
]; n
; n
= n
->next
)
4374 ctx
.sharing_clauses
->add (n
->sym
);
4382 case EXEC_OMP_PARALLEL_DO
:
4383 case EXEC_OMP_PARALLEL_DO_SIMD
:
4384 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
4385 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4386 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4387 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4388 case EXEC_OMP_TEAMS_DISTRIBUTE
:
4389 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4390 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4391 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
4392 gfc_resolve_omp_do_blocks (code
, ns
);
4395 gfc_resolve_blocks (code
->block
, ns
);
4398 omp_current_ctx
= ctx
.previous
;
4399 delete ctx
.sharing_clauses
;
4400 delete ctx
.private_iterators
;
4404 /* Save and clear openmp.c private state. */
4407 gfc_omp_save_and_clear_state (struct gfc_omp_saved_state
*state
)
4409 state
->ptrs
[0] = omp_current_ctx
;
4410 state
->ptrs
[1] = omp_current_do_code
;
4411 state
->ints
[0] = omp_current_do_collapse
;
4412 omp_current_ctx
= NULL
;
4413 omp_current_do_code
= NULL
;
4414 omp_current_do_collapse
= 0;
4418 /* Restore openmp.c private state from the saved state. */
4421 gfc_omp_restore_state (struct gfc_omp_saved_state
*state
)
4423 omp_current_ctx
= (struct fortran_omp_context
*) state
->ptrs
[0];
4424 omp_current_do_code
= (gfc_code
*) state
->ptrs
[1];
4425 omp_current_do_collapse
= state
->ints
[0];
4429 /* Note a DO iterator variable. This is special in !$omp parallel
4430 construct, where they are predetermined private. */
4433 gfc_resolve_do_iterator (gfc_code
*code
, gfc_symbol
*sym
)
4435 int i
= omp_current_do_collapse
;
4436 gfc_code
*c
= omp_current_do_code
;
4438 if (sym
->attr
.threadprivate
)
4441 /* !$omp do and !$omp parallel do iteration variable is predetermined
4442 private just in the !$omp do resp. !$omp parallel do construct,
4443 with no implications for the outer parallel constructs. */
4453 if (omp_current_ctx
== NULL
)
4456 /* An openacc context may represent a data clause. Abort if so. */
4457 if (!omp_current_ctx
->is_openmp
&& !oacc_is_loop (omp_current_ctx
->code
))
4460 if (omp_current_ctx
->is_openmp
4461 && omp_current_ctx
->sharing_clauses
->contains (sym
))
4464 if (! omp_current_ctx
->private_iterators
->add (sym
))
4466 gfc_omp_clauses
*omp_clauses
= omp_current_ctx
->code
->ext
.omp_clauses
;
4467 gfc_omp_namelist
*p
;
4469 p
= gfc_get_omp_namelist ();
4471 p
->next
= omp_clauses
->lists
[OMP_LIST_PRIVATE
];
4472 omp_clauses
->lists
[OMP_LIST_PRIVATE
] = p
;
4478 resolve_omp_do (gfc_code
*code
)
4480 gfc_code
*do_code
, *c
;
4481 int list
, i
, collapse
;
4482 gfc_omp_namelist
*n
;
4485 bool is_simd
= false;
4489 case EXEC_OMP_DISTRIBUTE
: name
= "!$OMP DISTRIBUTE"; break;
4490 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
4491 name
= "!$OMP DISTRIBUTE PARALLEL DO";
4493 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4494 name
= "!$OMP DISTRIBUTE PARALLEL DO SIMD";
4497 case EXEC_OMP_DISTRIBUTE_SIMD
:
4498 name
= "!$OMP DISTRIBUTE SIMD";
4501 case EXEC_OMP_DO
: name
= "!$OMP DO"; break;
4502 case EXEC_OMP_DO_SIMD
: name
= "!$OMP DO SIMD"; is_simd
= true; break;
4503 case EXEC_OMP_PARALLEL_DO
: name
= "!$OMP PARALLEL DO"; break;
4504 case EXEC_OMP_PARALLEL_DO_SIMD
:
4505 name
= "!$OMP PARALLEL DO SIMD";
4508 case EXEC_OMP_SIMD
: name
= "!$OMP SIMD"; is_simd
= true; break;
4509 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
4510 name
= "!$OMP TARGET TEAMS_DISTRIBUTE";
4512 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4513 name
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
4515 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4516 name
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
4519 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4520 name
= "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
4523 case EXEC_OMP_TEAMS_DISTRIBUTE
: name
= "!$OMP TEAMS_DISTRIBUTE"; break;
4524 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4525 name
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
4527 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4528 name
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
4531 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
4532 name
= "!$OMP TEAMS DISTRIBUTE SIMD";
4535 default: gcc_unreachable ();
4538 if (code
->ext
.omp_clauses
)
4539 resolve_omp_clauses (code
, code
->ext
.omp_clauses
, NULL
);
4541 do_code
= code
->block
->next
;
4542 collapse
= code
->ext
.omp_clauses
->collapse
;
4545 for (i
= 1; i
<= collapse
; i
++)
4547 if (do_code
->op
== EXEC_DO_WHILE
)
4549 gfc_error ("%s cannot be a DO WHILE or DO without loop control "
4550 "at %L", name
, &do_code
->loc
);
4553 if (do_code
->op
== EXEC_DO_CONCURRENT
)
4555 gfc_error ("%s cannot be a DO CONCURRENT loop at %L", name
,
4559 gcc_assert (do_code
->op
== EXEC_DO
);
4560 if (do_code
->ext
.iterator
->var
->ts
.type
!= BT_INTEGER
)
4561 gfc_error ("%s iteration variable must be of type integer at %L",
4562 name
, &do_code
->loc
);
4563 dovar
= do_code
->ext
.iterator
->var
->symtree
->n
.sym
;
4564 if (dovar
->attr
.threadprivate
)
4565 gfc_error ("%s iteration variable must not be THREADPRIVATE "
4566 "at %L", name
, &do_code
->loc
);
4567 if (code
->ext
.omp_clauses
)
4568 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
4570 ? (list
!= OMP_LIST_PRIVATE
&& list
!= OMP_LIST_LASTPRIVATE
)
4571 : code
->ext
.omp_clauses
->collapse
> 1
4572 ? (list
!= OMP_LIST_LASTPRIVATE
)
4573 : (list
!= OMP_LIST_LINEAR
))
4574 for (n
= code
->ext
.omp_clauses
->lists
[list
]; n
; n
= n
->next
)
4575 if (dovar
== n
->sym
)
4578 gfc_error ("%s iteration variable present on clause "
4579 "other than PRIVATE or LASTPRIVATE at %L",
4580 name
, &do_code
->loc
);
4581 else if (code
->ext
.omp_clauses
->collapse
> 1)
4582 gfc_error ("%s iteration variable present on clause "
4583 "other than LASTPRIVATE at %L",
4584 name
, &do_code
->loc
);
4586 gfc_error ("%s iteration variable present on clause "
4587 "other than LINEAR at %L",
4588 name
, &do_code
->loc
);
4593 gfc_code
*do_code2
= code
->block
->next
;
4596 for (j
= 1; j
< i
; j
++)
4598 gfc_symbol
*ivar
= do_code2
->ext
.iterator
->var
->symtree
->n
.sym
;
4600 || gfc_find_sym_in_expr (ivar
, do_code
->ext
.iterator
->start
)
4601 || gfc_find_sym_in_expr (ivar
, do_code
->ext
.iterator
->end
)
4602 || gfc_find_sym_in_expr (ivar
, do_code
->ext
.iterator
->step
))
4604 gfc_error ("%s collapsed loops don't form rectangular "
4605 "iteration space at %L", name
, &do_code
->loc
);
4610 do_code2
= do_code2
->block
->next
;
4615 for (c
= do_code
->next
; c
; c
= c
->next
)
4616 if (c
->op
!= EXEC_NOP
&& c
->op
!= EXEC_CONTINUE
)
4618 gfc_error ("collapsed %s loops not perfectly nested at %L",
4624 do_code
= do_code
->block
;
4625 if (do_code
->op
!= EXEC_DO
&& do_code
->op
!= EXEC_DO_WHILE
)
4627 gfc_error ("not enough DO loops for collapsed %s at %L",
4631 do_code
= do_code
->next
;
4633 || (do_code
->op
!= EXEC_DO
&& do_code
->op
!= EXEC_DO_WHILE
))
4635 gfc_error ("not enough DO loops for collapsed %s at %L",
4643 oacc_is_parallel (gfc_code
*code
)
4645 return code
->op
== EXEC_OACC_PARALLEL
|| code
->op
== EXEC_OACC_PARALLEL_LOOP
;
4649 oacc_is_kernels (gfc_code
*code
)
4651 return code
->op
== EXEC_OACC_KERNELS
|| code
->op
== EXEC_OACC_KERNELS_LOOP
;
4654 static gfc_statement
4655 omp_code_to_statement (gfc_code
*code
)
4659 case EXEC_OMP_PARALLEL
:
4660 return ST_OMP_PARALLEL
;
4661 case EXEC_OMP_PARALLEL_SECTIONS
:
4662 return ST_OMP_PARALLEL_SECTIONS
;
4663 case EXEC_OMP_SECTIONS
:
4664 return ST_OMP_SECTIONS
;
4665 case EXEC_OMP_ORDERED
:
4666 return ST_OMP_ORDERED
;
4667 case EXEC_OMP_CRITICAL
:
4668 return ST_OMP_CRITICAL
;
4669 case EXEC_OMP_MASTER
:
4670 return ST_OMP_MASTER
;
4671 case EXEC_OMP_SINGLE
:
4672 return ST_OMP_SINGLE
;
4675 case EXEC_OMP_WORKSHARE
:
4676 return ST_OMP_WORKSHARE
;
4677 case EXEC_OMP_PARALLEL_WORKSHARE
:
4678 return ST_OMP_PARALLEL_WORKSHARE
;
4686 static gfc_statement
4687 oacc_code_to_statement (gfc_code
*code
)
4691 case EXEC_OACC_PARALLEL
:
4692 return ST_OACC_PARALLEL
;
4693 case EXEC_OACC_KERNELS
:
4694 return ST_OACC_KERNELS
;
4695 case EXEC_OACC_DATA
:
4696 return ST_OACC_DATA
;
4697 case EXEC_OACC_HOST_DATA
:
4698 return ST_OACC_HOST_DATA
;
4699 case EXEC_OACC_PARALLEL_LOOP
:
4700 return ST_OACC_PARALLEL_LOOP
;
4701 case EXEC_OACC_KERNELS_LOOP
:
4702 return ST_OACC_KERNELS_LOOP
;
4703 case EXEC_OACC_LOOP
:
4704 return ST_OACC_LOOP
;
4705 case EXEC_OACC_ATOMIC
:
4706 return ST_OACC_ATOMIC
;
4713 resolve_oacc_directive_inside_omp_region (gfc_code
*code
)
4715 if (omp_current_ctx
!= NULL
&& omp_current_ctx
->is_openmp
)
4717 gfc_statement st
= omp_code_to_statement (omp_current_ctx
->code
);
4718 gfc_statement oacc_st
= oacc_code_to_statement (code
);
4719 gfc_error ("The %s directive cannot be specified within "
4720 "a %s region at %L", gfc_ascii_statement (oacc_st
),
4721 gfc_ascii_statement (st
), &code
->loc
);
4726 resolve_omp_directive_inside_oacc_region (gfc_code
*code
)
4728 if (omp_current_ctx
!= NULL
&& !omp_current_ctx
->is_openmp
)
4730 gfc_statement st
= oacc_code_to_statement (omp_current_ctx
->code
);
4731 gfc_statement omp_st
= omp_code_to_statement (code
);
4732 gfc_error ("The %s directive cannot be specified within "
4733 "a %s region at %L", gfc_ascii_statement (omp_st
),
4734 gfc_ascii_statement (st
), &code
->loc
);
4740 resolve_oacc_nested_loops (gfc_code
*code
, gfc_code
* do_code
, int collapse
,
4747 for (i
= 1; i
<= collapse
; i
++)
4749 if (do_code
->op
== EXEC_DO_WHILE
)
4751 gfc_error ("!$ACC LOOP cannot be a DO WHILE or DO without loop control "
4752 "at %L", &do_code
->loc
);
4755 gcc_assert (do_code
->op
== EXEC_DO
|| do_code
->op
== EXEC_DO_CONCURRENT
);
4756 if (do_code
->ext
.iterator
->var
->ts
.type
!= BT_INTEGER
)
4757 gfc_error ("!$ACC LOOP iteration variable must be of type integer at %L",
4759 dovar
= do_code
->ext
.iterator
->var
->symtree
->n
.sym
;
4762 gfc_code
*do_code2
= code
->block
->next
;
4765 for (j
= 1; j
< i
; j
++)
4767 gfc_symbol
*ivar
= do_code2
->ext
.iterator
->var
->symtree
->n
.sym
;
4769 || gfc_find_sym_in_expr (ivar
, do_code
->ext
.iterator
->start
)
4770 || gfc_find_sym_in_expr (ivar
, do_code
->ext
.iterator
->end
)
4771 || gfc_find_sym_in_expr (ivar
, do_code
->ext
.iterator
->step
))
4773 gfc_error ("!$ACC LOOP %s loops don't form rectangular iteration space at %L",
4774 clause
, &do_code
->loc
);
4779 do_code2
= do_code2
->block
->next
;
4784 for (c
= do_code
->next
; c
; c
= c
->next
)
4785 if (c
->op
!= EXEC_NOP
&& c
->op
!= EXEC_CONTINUE
)
4787 gfc_error ("%s !$ACC LOOP loops not perfectly nested at %L",
4793 do_code
= do_code
->block
;
4794 if (do_code
->op
!= EXEC_DO
&& do_code
->op
!= EXEC_DO_WHILE
4795 && do_code
->op
!= EXEC_DO_CONCURRENT
)
4797 gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
4798 clause
, &code
->loc
);
4801 do_code
= do_code
->next
;
4803 || (do_code
->op
!= EXEC_DO
&& do_code
->op
!= EXEC_DO_WHILE
4804 && do_code
->op
!= EXEC_DO_CONCURRENT
))
4806 gfc_error ("not enough DO loops for %s !$ACC LOOP at %L",
4807 clause
, &code
->loc
);
4815 resolve_oacc_params_in_parallel (gfc_code
*code
, const char *clause
,
4818 fortran_omp_context
*c
;
4820 if (oacc_is_parallel (code
))
4821 gfc_error ("!$ACC LOOP %s in PARALLEL region doesn't allow "
4822 "%s arguments at %L", clause
, arg
, &code
->loc
);
4823 for (c
= omp_current_ctx
; c
; c
= c
->previous
)
4825 if (oacc_is_loop (c
->code
))
4827 if (oacc_is_parallel (c
->code
))
4828 gfc_error ("!$ACC LOOP %s in PARALLEL region doesn't allow "
4829 "%s arguments at %L", clause
, arg
, &code
->loc
);
4835 resolve_oacc_loop_blocks (gfc_code
*code
)
4837 fortran_omp_context
*c
;
4839 if (!oacc_is_loop (code
))
4842 if (code
->op
== EXEC_OACC_LOOP
)
4843 for (c
= omp_current_ctx
; c
; c
= c
->previous
)
4845 if (oacc_is_loop (c
->code
))
4847 if (code
->ext
.omp_clauses
->gang
)
4849 if (c
->code
->ext
.omp_clauses
->gang
)
4850 gfc_error ("Loop parallelized across gangs is not allowed "
4851 "inside another loop parallelized across gangs at %L",
4853 if (c
->code
->ext
.omp_clauses
->worker
)
4854 gfc_error ("Loop parallelized across gangs is not allowed "
4855 "inside loop parallelized across workers at %L",
4857 if (c
->code
->ext
.omp_clauses
->vector
)
4858 gfc_error ("Loop parallelized across gangs is not allowed "
4859 "inside loop parallelized across workers at %L",
4862 if (code
->ext
.omp_clauses
->worker
)
4864 if (c
->code
->ext
.omp_clauses
->worker
)
4865 gfc_error ("Loop parallelized across workers is not allowed "
4866 "inside another loop parallelized across workers at %L",
4868 if (c
->code
->ext
.omp_clauses
->vector
)
4869 gfc_error ("Loop parallelized across workers is not allowed "
4870 "inside another loop parallelized across vectors at %L",
4873 if (code
->ext
.omp_clauses
->vector
)
4874 if (c
->code
->ext
.omp_clauses
->vector
)
4875 gfc_error ("Loop parallelized across vectors is not allowed "
4876 "inside another loop parallelized across vectors at %L",
4880 if (oacc_is_parallel (c
->code
) || oacc_is_kernels (c
->code
))
4884 if (code
->ext
.omp_clauses
->seq
)
4886 if (code
->ext
.omp_clauses
->independent
)
4887 gfc_error ("Clause SEQ conflicts with INDEPENDENT at %L", &code
->loc
);
4888 if (code
->ext
.omp_clauses
->gang
)
4889 gfc_error ("Clause SEQ conflicts with GANG at %L", &code
->loc
);
4890 if (code
->ext
.omp_clauses
->worker
)
4891 gfc_error ("Clause SEQ conflicts with WORKER at %L", &code
->loc
);
4892 if (code
->ext
.omp_clauses
->vector
)
4893 gfc_error ("Clause SEQ conflicts with VECTOR at %L", &code
->loc
);
4894 if (code
->ext
.omp_clauses
->par_auto
)
4895 gfc_error ("Clause SEQ conflicts with AUTO at %L", &code
->loc
);
4897 if (code
->ext
.omp_clauses
->par_auto
)
4899 if (code
->ext
.omp_clauses
->gang
)
4900 gfc_error ("Clause AUTO conflicts with GANG at %L", &code
->loc
);
4901 if (code
->ext
.omp_clauses
->worker
)
4902 gfc_error ("Clause AUTO conflicts with WORKER at %L", &code
->loc
);
4903 if (code
->ext
.omp_clauses
->vector
)
4904 gfc_error ("Clause AUTO conflicts with VECTOR at %L", &code
->loc
);
4906 if (code
->ext
.omp_clauses
->tile_list
&& code
->ext
.omp_clauses
->gang
4907 && code
->ext
.omp_clauses
->worker
&& code
->ext
.omp_clauses
->vector
)
4908 gfc_error ("Tiled loop cannot be parallelized across gangs, workers and "
4909 "vectors at the same time at %L", &code
->loc
);
4911 if (code
->ext
.omp_clauses
->gang
4912 && code
->ext
.omp_clauses
->gang_num_expr
)
4913 resolve_oacc_params_in_parallel (code
, "GANG", "num");
4915 if (code
->ext
.omp_clauses
->worker
4916 && code
->ext
.omp_clauses
->worker_expr
)
4917 resolve_oacc_params_in_parallel (code
, "WORKER", "num");
4919 if (code
->ext
.omp_clauses
->vector
4920 && code
->ext
.omp_clauses
->vector_expr
)
4921 resolve_oacc_params_in_parallel (code
, "VECTOR", "length");
4923 if (code
->ext
.omp_clauses
->tile_list
)
4927 for (el
= code
->ext
.omp_clauses
->tile_list
; el
; el
= el
->next
)
4930 if (el
->expr
== NULL
)
4932 /* NULL expressions are used to represent '*' arguments.
4933 Convert those to a -1 expressions. */
4934 el
->expr
= gfc_get_constant_expr (BT_INTEGER
,
4935 gfc_default_integer_kind
,
4937 mpz_set_si (el
->expr
->value
.integer
, -1);
4941 resolve_oacc_positive_int_expr (el
->expr
, "TILE");
4942 if (el
->expr
->expr_type
!= EXPR_CONSTANT
)
4943 gfc_error ("TILE requires constant expression at %L",
4947 resolve_oacc_nested_loops (code
, code
->block
->next
, num
, "tiled");
4953 gfc_resolve_oacc_blocks (gfc_code
*code
, gfc_namespace
*ns
)
4955 fortran_omp_context ctx
;
4957 resolve_oacc_loop_blocks (code
);
4960 ctx
.sharing_clauses
= NULL
;
4961 ctx
.private_iterators
= new hash_set
<gfc_symbol
*>;
4962 ctx
.previous
= omp_current_ctx
;
4963 ctx
.is_openmp
= false;
4964 omp_current_ctx
= &ctx
;
4966 gfc_resolve_blocks (code
->block
, ns
);
4968 omp_current_ctx
= ctx
.previous
;
4969 delete ctx
.private_iterators
;
4974 resolve_oacc_loop (gfc_code
*code
)
4979 if (code
->ext
.omp_clauses
)
4980 resolve_omp_clauses (code
, code
->ext
.omp_clauses
, NULL
, true);
4982 do_code
= code
->block
->next
;
4983 collapse
= code
->ext
.omp_clauses
->collapse
;
4987 resolve_oacc_nested_loops (code
, do_code
, collapse
, "collapsed");
4991 gfc_resolve_oacc_declare (gfc_namespace
*ns
)
4994 gfc_omp_namelist
*n
;
4995 gfc_oacc_declare
*oc
;
4997 if (ns
->oacc_declare
== NULL
)
5000 for (oc
= ns
->oacc_declare
; oc
; oc
= oc
->next
)
5002 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
5003 for (n
= oc
->clauses
->lists
[list
]; n
; n
= n
->next
)
5006 if (n
->sym
->attr
.flavor
== FL_PARAMETER
)
5008 gfc_error ("PARAMETER object %qs is not allowed at %L",
5009 n
->sym
->name
, &oc
->loc
);
5013 if (n
->expr
&& n
->expr
->ref
->type
== REF_ARRAY
)
5015 gfc_error ("Array sections: %qs not allowed in"
5016 " $!ACC DECLARE at %L", n
->sym
->name
, &oc
->loc
);
5021 for (n
= oc
->clauses
->lists
[OMP_LIST_DEVICE_RESIDENT
]; n
; n
= n
->next
)
5022 check_array_not_assumed (n
->sym
, oc
->loc
, "DEVICE_RESIDENT");
5025 for (oc
= ns
->oacc_declare
; oc
; oc
= oc
->next
)
5027 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
5028 for (n
= oc
->clauses
->lists
[list
]; n
; n
= n
->next
)
5032 gfc_error ("Symbol %qs present on multiple clauses at %L",
5033 n
->sym
->name
, &oc
->loc
);
5041 for (oc
= ns
->oacc_declare
; oc
; oc
= oc
->next
)
5043 for (list
= 0; list
< OMP_LIST_NUM
; list
++)
5044 for (n
= oc
->clauses
->lists
[list
]; n
; n
= n
->next
)
5050 gfc_resolve_oacc_directive (gfc_code
*code
, gfc_namespace
*ns ATTRIBUTE_UNUSED
)
5052 resolve_oacc_directive_inside_omp_region (code
);
5056 case EXEC_OACC_PARALLEL
:
5057 case EXEC_OACC_KERNELS
:
5058 case EXEC_OACC_DATA
:
5059 case EXEC_OACC_HOST_DATA
:
5060 case EXEC_OACC_UPDATE
:
5061 case EXEC_OACC_ENTER_DATA
:
5062 case EXEC_OACC_EXIT_DATA
:
5063 case EXEC_OACC_WAIT
:
5064 case EXEC_OACC_CACHE
:
5065 resolve_omp_clauses (code
, code
->ext
.omp_clauses
, NULL
, true);
5067 case EXEC_OACC_PARALLEL_LOOP
:
5068 case EXEC_OACC_KERNELS_LOOP
:
5069 case EXEC_OACC_LOOP
:
5070 resolve_oacc_loop (code
);
5072 case EXEC_OACC_ATOMIC
:
5073 resolve_omp_atomic (code
);
5081 /* Resolve OpenMP directive clauses and check various requirements
5082 of each directive. */
5085 gfc_resolve_omp_directive (gfc_code
*code
, gfc_namespace
*ns ATTRIBUTE_UNUSED
)
5087 resolve_omp_directive_inside_oacc_region (code
);
5089 if (code
->op
!= EXEC_OMP_ATOMIC
)
5090 gfc_maybe_initialize_eh ();
5094 case EXEC_OMP_DISTRIBUTE
:
5095 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
5096 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
5097 case EXEC_OMP_DISTRIBUTE_SIMD
:
5099 case EXEC_OMP_DO_SIMD
:
5100 case EXEC_OMP_PARALLEL_DO
:
5101 case EXEC_OMP_PARALLEL_DO_SIMD
:
5103 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
5104 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5105 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5106 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
5107 case EXEC_OMP_TEAMS_DISTRIBUTE
:
5108 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5109 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5110 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
5111 resolve_omp_do (code
);
5113 case EXEC_OMP_CANCEL
:
5114 case EXEC_OMP_PARALLEL_WORKSHARE
:
5115 case EXEC_OMP_PARALLEL
:
5116 case EXEC_OMP_PARALLEL_SECTIONS
:
5117 case EXEC_OMP_SECTIONS
:
5118 case EXEC_OMP_SINGLE
:
5119 case EXEC_OMP_TARGET
:
5120 case EXEC_OMP_TARGET_DATA
:
5121 case EXEC_OMP_TARGET_TEAMS
:
5123 case EXEC_OMP_TEAMS
:
5124 case EXEC_OMP_WORKSHARE
:
5125 if (code
->ext
.omp_clauses
)
5126 resolve_omp_clauses (code
, code
->ext
.omp_clauses
, NULL
);
5128 case EXEC_OMP_TARGET_UPDATE
:
5129 if (code
->ext
.omp_clauses
)
5130 resolve_omp_clauses (code
, code
->ext
.omp_clauses
, NULL
);
5131 if (code
->ext
.omp_clauses
== NULL
5132 || (code
->ext
.omp_clauses
->lists
[OMP_LIST_TO
] == NULL
5133 && code
->ext
.omp_clauses
->lists
[OMP_LIST_FROM
] == NULL
))
5134 gfc_error ("OMP TARGET UPDATE at %L requires at least one TO or "
5135 "FROM clause", &code
->loc
);
5137 case EXEC_OMP_ATOMIC
:
5138 resolve_omp_atomic (code
);
5145 /* Resolve !$omp declare simd constructs in NS. */
5148 gfc_resolve_omp_declare_simd (gfc_namespace
*ns
)
5150 gfc_omp_declare_simd
*ods
;
5152 for (ods
= ns
->omp_declare_simd
; ods
; ods
= ods
->next
)
5154 if (ods
->proc_name
!= ns
->proc_name
)
5155 gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure "
5156 "%qs at %L", ns
->proc_name
->name
, &ods
->where
);
5158 resolve_omp_clauses (NULL
, ods
->clauses
, ns
);
5162 struct omp_udr_callback_data
5164 gfc_omp_udr
*omp_udr
;
5165 bool is_initializer
;
5169 omp_udr_callback (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
5172 struct omp_udr_callback_data
*cd
= (struct omp_udr_callback_data
*) data
;
5173 if ((*e
)->expr_type
== EXPR_VARIABLE
)
5175 if (cd
->is_initializer
)
5177 if ((*e
)->symtree
->n
.sym
!= cd
->omp_udr
->omp_priv
5178 && (*e
)->symtree
->n
.sym
!= cd
->omp_udr
->omp_orig
)
5179 gfc_error ("Variable other than OMP_PRIV or OMP_ORIG used in "
5180 "INITIALIZER clause of !$OMP DECLARE REDUCTION at %L",
5185 if ((*e
)->symtree
->n
.sym
!= cd
->omp_udr
->omp_out
5186 && (*e
)->symtree
->n
.sym
!= cd
->omp_udr
->omp_in
)
5187 gfc_error ("Variable other than OMP_OUT or OMP_IN used in "
5188 "combiner of !$OMP DECLARE REDUCTION at %L",
5195 /* Resolve !$omp declare reduction constructs. */
5198 gfc_resolve_omp_udr (gfc_omp_udr
*omp_udr
)
5200 gfc_actual_arglist
*a
;
5201 const char *predef_name
= NULL
;
5203 switch (omp_udr
->rop
)
5205 case OMP_REDUCTION_PLUS
:
5206 case OMP_REDUCTION_TIMES
:
5207 case OMP_REDUCTION_MINUS
:
5208 case OMP_REDUCTION_AND
:
5209 case OMP_REDUCTION_OR
:
5210 case OMP_REDUCTION_EQV
:
5211 case OMP_REDUCTION_NEQV
:
5212 case OMP_REDUCTION_MAX
:
5213 case OMP_REDUCTION_USER
:
5216 gfc_error ("Invalid operator for !$OMP DECLARE REDUCTION %s at %L",
5217 omp_udr
->name
, &omp_udr
->where
);
5221 if (gfc_omp_udr_predef (omp_udr
->rop
, omp_udr
->name
,
5222 &omp_udr
->ts
, &predef_name
))
5225 gfc_error_now ("Redefinition of predefined %s "
5226 "!$OMP DECLARE REDUCTION at %L",
5227 predef_name
, &omp_udr
->where
);
5229 gfc_error_now ("Redefinition of predefined "
5230 "!$OMP DECLARE REDUCTION at %L", &omp_udr
->where
);
5234 if (omp_udr
->ts
.type
== BT_CHARACTER
5235 && omp_udr
->ts
.u
.cl
->length
5236 && omp_udr
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
5238 gfc_error ("CHARACTER length in !$OMP DECLARE REDUCTION %s not "
5239 "constant at %L", omp_udr
->name
, &omp_udr
->where
);
5243 struct omp_udr_callback_data cd
;
5244 cd
.omp_udr
= omp_udr
;
5245 cd
.is_initializer
= false;
5246 gfc_code_walker (&omp_udr
->combiner_ns
->code
, gfc_dummy_code_callback
,
5247 omp_udr_callback
, &cd
);
5248 if (omp_udr
->combiner_ns
->code
->op
== EXEC_CALL
)
5250 for (a
= omp_udr
->combiner_ns
->code
->ext
.actual
; a
; a
= a
->next
)
5251 if (a
->expr
== NULL
)
5254 gfc_error ("Subroutine call with alternate returns in combiner "
5255 "of !$OMP DECLARE REDUCTION at %L",
5256 &omp_udr
->combiner_ns
->code
->loc
);
5258 if (omp_udr
->initializer_ns
)
5260 cd
.is_initializer
= true;
5261 gfc_code_walker (&omp_udr
->initializer_ns
->code
, gfc_dummy_code_callback
,
5262 omp_udr_callback
, &cd
);
5263 if (omp_udr
->initializer_ns
->code
->op
== EXEC_CALL
)
5265 for (a
= omp_udr
->initializer_ns
->code
->ext
.actual
; a
; a
= a
->next
)
5266 if (a
->expr
== NULL
)
5269 gfc_error ("Subroutine call with alternate returns in "
5270 "INITIALIZER clause of !$OMP DECLARE REDUCTION "
5271 "at %L", &omp_udr
->initializer_ns
->code
->loc
);
5272 for (a
= omp_udr
->initializer_ns
->code
->ext
.actual
; a
; a
= a
->next
)
5274 && a
->expr
->expr_type
== EXPR_VARIABLE
5275 && a
->expr
->symtree
->n
.sym
== omp_udr
->omp_priv
5276 && a
->expr
->ref
== NULL
)
5279 gfc_error ("One of actual subroutine arguments in INITIALIZER "
5280 "clause of !$OMP DECLARE REDUCTION must be OMP_PRIV "
5281 "at %L", &omp_udr
->initializer_ns
->code
->loc
);
5284 else if (omp_udr
->ts
.type
== BT_DERIVED
5285 && !gfc_has_default_initializer (omp_udr
->ts
.u
.derived
))
5287 gfc_error ("Missing INITIALIZER clause for !$OMP DECLARE REDUCTION "
5288 "of derived type without default initializer at %L",
5295 gfc_resolve_omp_udrs (gfc_symtree
*st
)
5297 gfc_omp_udr
*omp_udr
;
5301 gfc_resolve_omp_udrs (st
->left
);
5302 gfc_resolve_omp_udrs (st
->right
);
5303 for (omp_udr
= st
->n
.omp_udr
; omp_udr
; omp_udr
= omp_udr
->next
)
5304 gfc_resolve_omp_udr (omp_udr
);